From ehuelsmann at common-lisp.net Sun Mar 1 20:11:45 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 01 Mar 2009 20:11:45 +0000 Subject: [armedbear-cvs] r11691 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 1 20:11:40 2009 New Revision: 11691 Log: Don't box values which have well-defined meanings within the Lisp system (ie LispObject-s) when returning from JCALL/JCALL-RAW. Essentially, this moves Java.java::makeLispObject() to JavaObject.java::getInstance(); partially because I discovered makeLispObject() very late in the game. This change however, makes for more efficient boxing/unboxing in a change-to-come. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/JavaObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Sun Mar 1 20:11:40 2009 @@ -112,7 +112,7 @@ @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - return new JavaObject(javaClass(arg)); + return JavaObject.getInstance(javaClass(arg)); } }; @@ -151,7 +151,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return makeLispObject((JFIELD_RAW.execute(args)).javaInstance()); + return JavaObject.getInstance((JFIELD_RAW.execute(args)).javaInstance(), true); } }; @@ -214,7 +214,7 @@ f.set(instance,args[3].javaInstance(fieldType)); return args[3]; } - return new JavaObject(f.get(instance)); + return JavaObject.getInstance(f.get(instance)); } catch (NoSuchFieldException e) { error(new LispError("no such field")); @@ -256,14 +256,14 @@ for (int i = 1; i < args.length; i++) { parameterTypes[i-1] = javaClass(args[i]); } - return new JavaObject(c.getConstructor(parameterTypes)); + return JavaObject.getInstance(c.getConstructor(parameterTypes)); } // Parameter types not explicitly specified. Constructor[] constructors = c.getConstructors(); for (int i = 0; i < constructors.length; i++) { Constructor constructor = constructors[i]; if (constructor.getParameterTypes().length == argCount) - return new JavaObject(constructor); + return JavaObject.getInstance(constructor); } throw new NoSuchMethodException(); } @@ -301,8 +301,8 @@ Class[] parameterTypes = new Class[args.length-2]; for (int i = 2; i < args.length; i++) parameterTypes[i-2] = javaClass(args[i]); - return new JavaObject(c.getMethod(methodName, - parameterTypes)); + return JavaObject.getInstance(c.getMethod(methodName, + parameterTypes)); } // Parameter types were not explicitly specified. Method[] methods = c.getMethods(); @@ -310,7 +310,7 @@ Method method = methods[i]; if (method.getName().equals(methodName) && method.getParameterTypes().length == argCount) - return new JavaObject(method); + return JavaObject.getInstance(method); } throw new NoSuchMethodException(); } @@ -346,7 +346,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return makeLispObject((JSTATIC_RAW.execute(args)).javaInstance()); + return JavaObject.getInstance((JSTATIC_RAW.execute(args)).javaInstance(), true); } }; @@ -398,7 +398,7 @@ methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); } Object result = m.invoke(null, methodArgs); - return new JavaObject(result); + return JavaObject.getInstance(result); } catch (Throwable t) { if (t instanceof InvocationTargetException) @@ -410,7 +410,7 @@ Symbol.SIGNAL.execute( condition, Keyword.CAUSE, - new JavaObject(t), + JavaObject.getInstance(t), Keyword.FORMAT_CONTROL, new SimpleString(getMessage(t))); } @@ -441,7 +441,7 @@ initargs[i-1] = arg.javaInstance(argTypes[i-1]); } } - return new JavaObject(constructor.newInstance(initargs)); + return JavaObject.getInstance(constructor.newInstance(initargs)); } catch (Throwable t) { if (t instanceof InvocationTargetException) @@ -453,7 +453,7 @@ Symbol.SIGNAL.execute( condition, Keyword.CAUSE, - new JavaObject(t), + JavaObject.getInstance(t), Keyword.FORMAT_CONTROL, new SimpleString(getMessage(t))); } @@ -477,7 +477,7 @@ int[] dimensions = new int[args.length - 1]; for (int i = 1; i < args.length; i++) dimensions[i-1] = ((Integer)args[i].javaInstance()).intValue(); - return new JavaObject(Array.newInstance(c, dimensions)); + return JavaObject.getInstance(Array.newInstance(c, dimensions)); } catch (Throwable t) { error(new JavaException(t)); @@ -495,7 +495,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return makeLispObject((JARRAY_REF_RAW.execute(args)).javaInstance()); + return JavaObject.getInstance((JARRAY_REF_RAW.execute(args)).javaInstance(), true); } }; @@ -513,7 +513,7 @@ Object a = args[0].javaInstance(); for (int i = 1; i 0;) - v.aset(i, new JavaObject(array[i])); - return v; - } - if (obj instanceof LispObject) - return (LispObject) obj; - return new JavaObject(obj); - } - private static final String getMessage(Throwable t) { String message = t.getMessage(); Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Sun Mar 1 20:11:40 2009 @@ -33,6 +33,8 @@ package org.armedbear.lisp; +import java.math.BigInteger; + public final class JavaObject extends LispObject { private final Object obj; @@ -76,6 +78,92 @@ return obj; } + /** Encapsulates obj, if required. + * If obj is a {@link LispObject}, it's returned as-is. + * + * @param obj Any java object + * @return obj or a new JavaObject encapsulating obj + */ + public final static LispObject getInstance(Object obj) { + if (obj == null) + return new JavaObject(null); + + if (obj instanceof LispObject) + return (LispObject)obj; + + return new JavaObject(obj); + } + + /** Encapsulates obj, if required. + * If obj is a {@link LispObject}, it's returned as-is. + * If obj is of a type which can be mapped to a lisp type, + * an object of the mapped type is returned, if translated is true. + * + * @param obj + * @param translated + * @return a LispObject representing or encapsulating obj + */ + public final static LispObject getInstance(Object obj, boolean translated) + throws ConditionThrowable + { + if (! translated) + return getInstance(obj); + + if (obj == null) return NIL; + + if (obj instanceof LispObject) + return (LispObject)obj; + + if (obj instanceof String) + return new SimpleString((String)obj); + + if (obj instanceof Number) { + // Number types ordered according to decreasing + // estimated chances of occurrance + + if (obj instanceof Integer) + return Fixnum.getInstance(((Integer)obj).intValue()); + + if (obj instanceof Float) + return new SingleFloat((Float)obj); + + if (obj instanceof Double) + return new DoubleFloat((Double)obj); + + if (obj instanceof Long) + return LispInteger.getInstance(((Long)obj).longValue()); + + if (obj instanceof BigInteger) + return new Bignum((BigInteger)obj); + + if (obj instanceof Short) + return Fixnum.getInstance(((Short)obj).shortValue()); + + if (obj instanceof Byte) + return Fixnum.getInstance(((Byte)obj).byteValue()); + // We don't handle BigDecimal: it doesn't map to a Lisp type + } + + if (obj instanceof Boolean) + return ((Boolean)obj).booleanValue() ? T : NIL; + + if (obj instanceof Character) + return new LispCharacter((Character)obj); + + if (obj instanceof Object[]) { + Object[] array = (Object[]) obj; + SimpleVector v = new SimpleVector(array.length); + for (int i = array.length; i-- > 0;) + v.aset(i, JavaObject.getInstance(array[i])); + return v; + } + // TODO + // We might want to handle: + // - streams + // - others? + return new JavaObject(obj); + } + @Override public Object javaInstance() { From ehuelsmann at common-lisp.net Sun Mar 1 20:14:35 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 01 Mar 2009 20:14:35 +0000 Subject: [armedbear-cvs] r11692 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 1 20:14:32 2009 New Revision: 11692 Log: Add 2 missing @Override annotations. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Sun Mar 1 20:14:32 2009 @@ -731,7 +731,8 @@ new Primitive("%jget-property-value", PACKAGE_JAVA, true, "java-object property-name") { - public LispObject execute(LispObject javaObject, LispObject propertyName) throws ConditionThrowable { + @Override + public LispObject execute(LispObject javaObject, LispObject propertyName) throws ConditionThrowable { try { Object obj = javaObject.javaInstance(); PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName); @@ -755,7 +756,8 @@ new Primitive("%jset-property-value", PACKAGE_JAVA, true, "java-object property-name value") { - public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable { + @Override + public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable { Object obj = null; try { obj = javaObject.javaInstance(); From ehuelsmann at common-lisp.net Sun Mar 1 20:47:50 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 01 Mar 2009 20:47:50 +0000 Subject: [armedbear-cvs] r11693 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 1 20:47:49 2009 New Revision: 11693 Log: Make boxing/unboxing more efficient: Instead of "calling the boxing function from the one which maps to lisp values only to discard the value-box (the object in which the value has been boxed) right afterwards", don't box when not required. The change is realised by delegating the boxing and translating code-paths to a helper function which boxes/translates upon request using JavaObject.getInstance(object, translated). Modified: trunk/abcl/src/org/armedbear/lisp/Java.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Sun Mar 1 20:47:49 2009 @@ -144,6 +144,82 @@ // to store value in a field of the instance. The class is // derived from the instance. // + + private static final LispObject jfield(Primitive fun, LispObject[] args, boolean translate) + throws ConditionThrowable + { + if (args.length < 2 || args.length > 4) + error(new WrongNumberOfArgumentsException(fun)); + String fieldName = null; + Class c; + Field f; + Class fieldType; + Object instance = null; + try { + if (args[1] instanceof AbstractString) { + // Cases 1-5. + fieldName = args[1].getStringValue(); + c = javaClass(args[0]); + } else { + // Cases 6 and 7. + fieldName = args[0].getStringValue(); + instance = JavaObject.getObject(args[1]); + c = instance.getClass(); + } + f = c.getField(fieldName); + fieldType = f.getType(); + switch (args.length) { + case 2: + // Cases 1 and 6. + break; + case 3: + // Cases 2,3, and 7. + if (instance == null) { + // Cases 2 and 3. + if (args[2] instanceof JavaObject) { + // Case 2. + instance = JavaObject.getObject(args[2]); + break; + } else { + // Case 3. + f.set(null,args[2].javaInstance(fieldType)); + return args[2]; + } + } else { + // Case 7. + f.set(instance,args[2].javaInstance(fieldType)); + return args[2]; + } + case 4: + // Cases 4 and 5. + if (args[2] != NIL) { + // Case 4. + instance = JavaObject.getObject(args[2]); + } + f.set(instance,args[3].javaInstance(fieldType)); + return args[3]; + } + return JavaObject.getInstance(f.get(instance), translate); + } + catch (NoSuchFieldException e) { + error(new LispError("no such field")); + } + catch (SecurityException e) { + error(new LispError("inaccessible field")); + } + catch (IllegalAccessException e) { + error(new LispError("illegal access")); + } + catch (IllegalArgumentException e) { + error(new LispError("illegal argument")); + } + catch (Throwable t) { + error(new LispError(getMessage(t))); + } + // Not reached. + return NIL; + } + private static final Primitive JFIELD = new Primitive("jfield", PACKAGE_JAVA, true, "class-ref-or-field field-or-instance &optional instance value") @@ -151,7 +227,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return JavaObject.getInstance((JFIELD_RAW.execute(args)).javaInstance(), true); + return jfield(this, args, true); } }; @@ -163,76 +239,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - if (args.length < 2 || args.length > 4) - error(new WrongNumberOfArgumentsException(this)); - String fieldName = null; - Class c; - Field f; - Class fieldType; - Object instance = null; - try { - if (args[1] instanceof AbstractString) { - // Cases 1-5. - fieldName = args[1].getStringValue(); - c = javaClass(args[0]); - } else { - // Cases 6 and 7. - fieldName = args[0].getStringValue(); - instance = JavaObject.getObject(args[1]); - c = instance.getClass(); - } - f = c.getField(fieldName); - fieldType = f.getType(); - switch (args.length) { - case 2: - // Cases 1 and 6. - break; - case 3: - // Cases 2,3, and 7. - if (instance == null) { - // Cases 2 and 3. - if (args[2] instanceof JavaObject) { - // Case 2. - instance = JavaObject.getObject(args[2]); - break; - } else { - // Case 3. - f.set(null,args[2].javaInstance(fieldType)); - return args[2]; - } - } else { - // Case 7. - f.set(instance,args[2].javaInstance(fieldType)); - return args[2]; - } - case 4: - // Cases 4 and 5. - if (args[2] != NIL) { - // Case 4. - instance = JavaObject.getObject(args[2]); - } - f.set(instance,args[3].javaInstance(fieldType)); - return args[3]; - } - return JavaObject.getInstance(f.get(instance)); - } - catch (NoSuchFieldException e) { - error(new LispError("no such field")); - } - catch (SecurityException e) { - error(new LispError("inaccessible field")); - } - catch (IllegalAccessException e) { - error(new LispError("illegal access")); - } - catch (IllegalArgumentException e) { - error(new LispError("illegal argument")); - } - catch (Throwable t) { - error(new LispError(getMessage(t))); - } - // Not reached. - return NIL; + return jfield(this, args, false); } }; @@ -339,6 +346,69 @@ } }; + private static final LispObject jstatic(Primitive fun, LispObject[] args, boolean translate) + throws ConditionThrowable + { + if (args.length < 2) + error(new WrongNumberOfArgumentsException(fun)); + try { + Method m = null; + LispObject methodRef = args[0]; + if (methodRef instanceof JavaObject) { + Object obj = ((JavaObject)methodRef).getObject(); + if (obj instanceof Method) + m = (Method) obj; + } else if (methodRef instanceof AbstractString) { + Class c = javaClass(args[1]); + if (c != null) { + String methodName = methodRef.getStringValue(); + Method[] methods = c.getMethods(); + int argCount = args.length - 2; + for (int i = 0; i < methods.length; i++) { + Method method = methods[i]; + if (!Modifier.isStatic(method.getModifiers()) + || method.getParameterTypes().length != argCount) + continue; + if (method.getName().equals(methodName)) { + m = method; + break; + } + } + if (m == null) + error(new LispError("no such method")); + } + } else + error(new TypeError("wrong type: " + methodRef)); + Object[] methodArgs = new Object[args.length-2]; + Class[] argTypes = m.getParameterTypes(); + for (int i = 2; i < args.length; i++) { + LispObject arg = args[i]; + if (arg == NIL) + methodArgs[i-2] = null; + else + methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); + } + Object result = m.invoke(null, methodArgs); + return JavaObject.getInstance(result, translate); + } + catch (Throwable t) { + if (t instanceof InvocationTargetException) + t = t.getCause(); + Symbol condition = getCondition(t.getClass()); + if (condition == null) + error(new JavaException(t)); + else + Symbol.SIGNAL.execute( + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t))); + } + // Not reached. + return NIL; + } + // ### jstatic method class &rest args private static final Primitive JSTATIC = new Primitive("jstatic", PACKAGE_JAVA, true, "method class &rest args") @@ -346,7 +416,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return JavaObject.getInstance((JSTATIC_RAW.execute(args)).javaInstance(), true); + return jstatic(this, args, true); } }; @@ -358,64 +428,7 @@ @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - if (args.length < 2) - error(new WrongNumberOfArgumentsException(this)); - try { - Method m = null; - LispObject methodRef = args[0]; - if (methodRef instanceof JavaObject) { - Object obj = ((JavaObject)methodRef).getObject(); - if (obj instanceof Method) - m = (Method) obj; - } else if (methodRef instanceof AbstractString) { - Class c = javaClass(args[1]); - if (c != null) { - String methodName = methodRef.getStringValue(); - Method[] methods = c.getMethods(); - int argCount = args.length - 2; - for (int i = 0; i < methods.length; i++) { - Method method = methods[i]; - if (!Modifier.isStatic(method.getModifiers()) - || method.getParameterTypes().length != argCount) - continue; - if (method.getName().equals(methodName)) { - m = method; - break; - } - } - if (m == null) - error(new LispError("no such method")); - } - } else - error(new TypeError("wrong type: " + methodRef)); - Object[] methodArgs = new Object[args.length-2]; - Class[] argTypes = m.getParameterTypes(); - for (int i = 2; i < args.length; i++) { - LispObject arg = args[i]; - if (arg == NIL) - methodArgs[i-2] = null; - else - methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); - } - Object result = m.invoke(null, methodArgs); - return JavaObject.getInstance(result); - } - catch (Throwable t) { - if (t instanceof InvocationTargetException) - t = t.getCause(); - Symbol condition = getCondition(t.getClass()); - if (condition == null) - error(new JavaException(t)); - else - Symbol.SIGNAL.execute( - condition, - Keyword.CAUSE, - JavaObject.getInstance(t), - Keyword.FORMAT_CONTROL, - new SimpleString(getMessage(t))); - } - // Not reached. - return NIL; + return jstatic(this, args, false); } }; @@ -487,6 +500,34 @@ } }; + private static final LispObject jarray_ref(Primitive fun, LispObject[] args, boolean translate) + throws ConditionThrowable + { + if (args.length < 2) + error(new WrongNumberOfArgumentsException(fun)); + try { + Object a = args[0].javaInstance(); + for (int i = 1; i= 2); // Verified by callers. + if (args.length < 2) + error(new WrongNumberOfArgumentsException(fun)); final LispObject methodArg = args[0]; final LispObject instanceArg = args[1]; final Object instance; @@ -630,7 +648,7 @@ else methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); } - return method.invoke(instance, methodArgs); + return JavaObject.getInstance(method.invoke(instance, methodArgs), translate); } catch (ConditionThrowable t) { throw t; From ehuelsmann at common-lisp.net Sun Mar 1 21:58:37 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 01 Mar 2009 21:58:37 +0000 Subject: [armedbear-cvs] r11694 - public_html Message-ID: Author: ehuelsmann Date: Sun Mar 1 21:58:34 2009 New Revision: 11694 Log: Update website to show our new release. Added: public_html/release-notes-0.13.shtml Modified: public_html/index.shtml public_html/testimonials.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Mar 1 21:58:34 2009 @@ -6,15 +6,30 @@ <!--#include virtual="project-name" --> +

-
-

Armed Bear

- The right of the people to keep and arm bears shall not be infringed! + +
+ + + + + + + + + + + +
Overview
Latest release: 0.0.13Release notes
What people say about ABCL
WikiFAQ (to be created)
@@ -36,11 +51,11 @@ same as used by GNU Classpath and J2SE (Java).

ABCL runs on platforms that support Java 1.5 (or later), including Linux, - Windows, and Mac OS X. + Windows, Mac OS X and the BSD family.

ABCL is free software and comes with ABSOLUTELY NO WARRANTY.

- The latest version is 0.12.0, released December 14, 2008. + The latest version is 0.13.0, released February 28, 2009. @@ -61,10 +76,10 @@
- abcl-0.12.0.tar.gz + abcl-0.13.0.tar.gz (source, 656652 bytes)

- abcl-0.12.0.zip + abcl-0.13.0.zip (source, 1130754 bytes)
@@ -93,20 +108,22 @@ quality of ABCL being good enough for their needs though. See the testimonials page.

- ABCL 0.12.0 fails 44 out of 21702 tests in the GCL ANSI test suite - in interpreted mode. In compiled mode ABCL 0.12.0 fails 48 tests, - coming from ca 65 in the last release. - Most notable recent fixes relate to special variables handling - and making sure the compiler uses the correct environments with, e.g., - LET/LET* and FLET/LABELS. + ABCL 0.13.0 fails 44 out of 21702 tests in the ANSI test suite + in interpreted mode. In compiled mode ABCL 0.13.0 also fails 44 tests, + coming from ca 48 in the last release. + Most notable recent fixes relate to issues found through running + the Maxima test suite. 0.13.0 is now able to run the test suite + without crashing. Before, some testcases could not be completed, + causing Java side errors. This is the issue resolved. The Maxima + tests don't run without errors, still.

- ABCL's CLOS is intolerably slow and does not handle on-the-fly + ABCL's CLOS is slow and does not handle on-the-fly redefinition of classes correctly. There is no support for the long form of DEFINE-METHOD-COMBINATION, and certain other required CLOS features are also missing. Enough CLOS is there to run ASDF and CL-PPCRE, if you're in no hurry. There's no MOP worth mentioning.

- Since this is an early public release, there might be build problems as + Since this is an early release, there might be build problems as well as runtime bugs.

Please report problems to the j development mailing list @@ -134,11 +151,10 @@ Java 1.5 is recommended. There are - - performance issues with early versions of Java 1.6. To build ABCL, you'll need - the full JDK; the JRE is not enough.
- Recent performance tests have shown Java 1.6 Update 10 - a Release - Candidate as of this writing - to be as fast as Java 1.5. + performance issues with versions of Java 1.6 prior to update 10. + To build ABCL, you'll need the full JDK; the JRE is not enough.
+ Recent performance tests have shown Java 1.6 Update 10 to be as fast + as Java 1.5.
Added: public_html/release-notes-0.13.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.13.shtml Sun Mar 1 21:58:34 2009 @@ -0,0 +1,58 @@ + + + + + <!--#include virtual="project-name" --> + + + + + + +
+

+
+ +

Release notes for ABCL 0.13

+ +

+ Major changes and new features +

+
+
JSR-223: Java Scripting Plugin +
+
ABCL supports - when built with the javax.script package + in the CLASSPATH - the interfaces defined in JSR-223. +
+
Support for inlining FLOAT results
+
When given the right DECLARE forms, ABCL is now able to inline + calculations and intermediate values relating to FLOAT types. Before, + it used to box all FLOAT values and results, without inlining.
+
Compiler cleanups
+
Lots of code cleanup in the compiler, such as elimination of + nearly-equivalent code blocks.
+
TRACE-ing fixes
+
TRACE should no longer blow up when tracing FORMAT or inside + the compiler.
+
Support for "partial" wildcards in CL:DIRECTORY
+
Patterns such as #p"cl-*.lisp" are now supported.
+
+ +

Release notes for ABCL 0.12 and older

+ +

These release notes have not been created before. If someone takes + the effort to create them, they will be added for 0.11 and 0.12.

+ +
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id: index.shtml 11358 2008-10-18 22:10:11Z ehuelsmann $
+ + Modified: public_html/testimonials.shtml ============================================================================== --- public_html/testimonials.shtml (original) +++ public_html/testimonials.shtml Sun Mar 1 21:58:34 2009 @@ -6,14 +6,75 @@ <!--#include virtual="project-name" -->: Testimonials + +
+

+
+ +

Testimonials

-
+
Brad Garton (Columbia University Computer Music Center) +
+
+"I used ABCL (older, v. 0.0.10) as the interpreter +underlying an object for a music/media graphical programming +environment called Max/MSP. +ABCL allowed me to embed an entire LISP interpreter inside the +Max/MSP package, and it has worked extremely well. Max/MSP +is designed primarily for real-time/interactive applications, +used a lot by computer music academics, DJs/VJs, bizarro jazz +performers, audio plugin developers, etc. With the embedded +abcl object, I am able to schedule LISP functions and work +interactively with complex processes -- the abcl interpreter +has been rock-solid!
+
+The source for the object is here (scroll down to the bottom of +the page):
+
+ http://music.columbia.edu/~brad/maxlispj/
+
+And I also used it extensively in a large application built with +Max/MSP... it's an interactive 'book' where the generative music +follows what a reader is reading and creates an appropriate sound +setting for the text:
+
+ http://music.columbia.edu/~brad/BookOfDreams/
+
+The music performance model underlying the shawm-like melodies +is all coded using abcl.
+
+So to all of you who have contributed (and still contribute!) to +the development of this terrific package, a big THANK YOU!!!" + + +
Alessio Stalla +
+
I'm currently integrating ABCL in a small, unreleased open source +project. It's a sort of graphical object browser for Java (but its GUI +sucks badly for now...). It can be run locally or as a client-server +application. I'm adding scripting support so you can access some +functionality from Lisp (or in principle any other Java Scripting API +compatible script engine, though I'm focusing on ABCL). +
+
Hunter Monroe
"Maxima algebraic computation software compiles with ABCL. The test suite @@ -23,6 +84,11 @@ out the Maxima source code and following the instructions in INSTALL.lisp."
+
Ted Kosan +
+
I am in the process of integrating ABCL with MathRider in preparation for when Maxima is able to run on it. +
+
Alex Mizhari
@@ -47,22 +113,7 @@ but in general it was more-or-less good.
-
Alessio Stalla -
-
I'm currently integrating ABCL in a small, unreleased open source -project. It's a sort of graphical object browser for Java (but its GUI -sucks badly for now...). It can be run locally or as a client-server -application. I'm adding scripting support so you can access some -functionality from Lisp (or in principle any other Java Scripting API -compatible script engine, though I'm focusing on ABCL). -
- -
Ted Kosan -
-
I am in the process of integrating ABCL with MathRider in preparation for when Maxima is able to run on it. -
-
- +
From ehuelsmann at common-lisp.net Tue Mar 3 22:10:27 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 03 Mar 2009 22:10:27 +0000 Subject: [armedbear-cvs] r11695 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Mar 3 22:10:25 2009 New Revision: 11695 Log: Fix DESCRIBE output by registering documentation on functions. Patch by: Russell McManus (russel_mcmanus at yahoo.com) Tweaked by: me Modified: trunk/abcl/src/org/armedbear/lisp/adjoin.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/adjoin.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/adjoin.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/adjoin.lisp Tue Mar 3 22:10:25 2009 @@ -30,6 +30,8 @@ ;;; exception statement from your version. (defun adjoin (item list &key key (test #'eql testp) (test-not nil notp)) + "Add `item' to `list' unless it is already a member (as determined by +the test function `test'." (when (and testp notp) (error "test and test-not both supplied")) (if (let ((key-val (sys::apply-key key item))) 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 Tue Mar 3 22:10:25 2009 @@ -1183,4 +1183,7 @@ (setf env nil)) (when (null env) (setf lambda-expression (precompile-form lambda-expression nil))) - `(%defun ',name ,lambda-expression)))))) + `(progn + (%defun ',name ,lambda-expression) + ,@(when doc + `((%set-documentation ',name 'function ,doc))))))))) From astalla at common-lisp.net Thu Mar 5 23:04:14 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 05 Mar 2009 23:04:14 +0000 Subject: [armedbear-cvs] r11696 - branches/save-image Message-ID: Author: astalla Date: Thu Mar 5 23:04:11 2009 New Revision: 11696 Log: Created save-image branch for experiments in providing save-image functionality to ABCL using Java serialization. Added: branches/save-image/ From astalla at common-lisp.net Thu Mar 5 23:12:24 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 05 Mar 2009 23:12:24 +0000 Subject: [armedbear-cvs] r11697 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Mar 5 23:12:24 2009 New Revision: 11697 Log: Serialization support for some lisp objects. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Binding.java trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/HashTable.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Nil.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java trunk/abcl/src/org/armedbear/lisp/jvm.lisp 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 Thu Mar 5 23:12:24 2009 @@ -338,6 +338,16 @@ } }; + /* + public void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { + try { + load(); + } catch(ConditionThrowable t) { + throw new java.io.InvalidObjectException("Couldn't resolve autoload: " + t); + } + stream.defaultWriteObject(); + }*/ + static { autoload("acos", "MathFunctions"); autoload("acosh", "MathFunctions"); Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Binding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Binding.java Thu Mar 5 23:12:24 2009 @@ -34,7 +34,7 @@ package org.armedbear.lisp; // Package accessibility. -final class Binding +final class Binding implements java.io.Serializable { final LispObject symbol; LispObject value; Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Thu Mar 5 23:12:24 2009 @@ -1041,7 +1041,7 @@ } } - private static class Parameter + private static class Parameter implements java.io.Serializable { private final Symbol var; private final LispObject initForm; 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 Thu Mar 5 23:12:24 2009 @@ -324,4 +324,20 @@ { ++callCount; } + + protected Object writeReplace() throws java.io.ObjectStreamException { + if(getClass().getSimpleName().contains("ABCL_GENERATED_")) { + try { + return new ExternalizedCompiledFunction((byte[] ) getf(propertyList, Symbol.CLASS_BYTES, + new JavaObject(new byte[0])).javaInstance(), + lambdaName.writeToString(), + getClass().getName()); + } catch(ConditionThrowable c) { + throw new java.io.InvalidClassException(getClass().getName()); + } + } else { + return this; + } + } + } Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Thu Mar 5 23:12:24 2009 @@ -286,7 +286,7 @@ return NIL; } - protected static class HashEntry + protected static class HashEntry implements java.io.Serializable { LispObject key; LispObject value; 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 Thu Mar 5 23:12:24 2009 @@ -40,6 +40,7 @@ import java.io.InputStreamReader; import java.io.OutputStream; import java.lang.reflect.Method; +import java.security.*; public final class Interpreter extends Lisp { @@ -139,6 +140,14 @@ private Interpreter() { + Policy.setPolicy( + new Policy() { + public PermissionCollection getPermissions(CodeSource codesource) { + Permissions perms = new Permissions(); + perms.add(new AllPermission()); + return (perms); + } + }); jlisp = false; inputStream = null; outputStream = null; Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Thu Mar 5 23:12:24 2009 @@ -620,13 +620,10 @@ final LispObject methodArg = args[0]; final LispObject instanceArg = args[1]; final Object instance; - if (instanceArg instanceof AbstractString) - instance = instanceArg.getStringValue(); - else if (instanceArg instanceof JavaObject) - instance = ((JavaObject)instanceArg).getObject(); - else { - type_error(instanceArg, - list3(Symbol.OR, Symbol.STRING, Symbol.JAVA_OBJECT)); + if (instanceArg != null) { + instance = instanceArg.javaInstance(); + } else { + type_error(instanceArg, Symbol.T); // Not reached. return null; } 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 Thu Mar 5 23:12:24 2009 @@ -33,10 +33,7 @@ package org.armedbear.lisp; -import java.io.File; -import java.io.FileInputStream; -import java.io.IOException; -import java.io.InputStream; +import java.io.*; import java.lang.reflect.Constructor; import java.math.BigInteger; import java.net.URL; @@ -984,51 +981,43 @@ } if (device instanceof Pathname) { - // We're loading a fasl from j.jar. + // We're loading a fasl from a jar. URL url = Lisp.class.getResource(namestring); - if (url != null) - { - try - { + if (url != null) { + try { String s = url.toString(); - String zipFileName; - String entryName; - if (s.startsWith("jar:file:")) - { - s = s.substring(9); - int index = s.lastIndexOf('!'); - if (index >= 0) - { - zipFileName = s.substring(0, index); - entryName = s.substring(index + 1); - if (entryName.length() > 0 && entryName.charAt(0) == '/') - entryName = entryName.substring(1); - if (Utilities.isPlatformWindows) - { - // "/C:/Documents%20and%20Settings/peter/Desktop/j.jar" - if (zipFileName.length() > 0 && zipFileName.charAt(0) == '/') - zipFileName = zipFileName.substring(1); - } - zipFileName = URLDecoder.decode(zipFileName, "UTF-8"); - ZipFile zipFile = new ZipFile(zipFileName); - try - { - ZipEntry entry = zipFile.getEntry(entryName); - if (entry != null) - { - long size = entry.getSize(); - InputStream in = zipFile.getInputStream(entry); - LispObject obj = loadCompiledFunction(in, (int) size); - return obj != null ? obj : NIL; - } - } - finally - { - zipFile.close(); - } - } - } - } + InputStream input = url.openStream(); + ByteArrayOutputStream baos = new ByteArrayOutputStream(); + + byte[] bytes = new byte[4096]; + int n = 0; + while (n >= 0) { + n = input.read(bytes, 0, 4096); + if(n >= 0) { + baos.write(bytes, 0, n); + } + } + input.close(); + bytes = baos.toByteArray(); + baos.close(); + JavaClassLoader loader = new JavaClassLoader(); + Class c = + loader.loadClassFromByteArray(null, bytes, 0, bytes.length); + if (c != null) { + Class[] parameterTypes = new Class[0]; + Constructor constructor = + c.getConstructor(parameterTypes); + Object[] initargs = new Object[0]; + LispObject obj = + (LispObject) constructor.newInstance(initargs); + if (obj instanceof Function) + ((Function)obj).setClassBytes(bytes); + else { + System.out.println("obj: " + obj); + } + return obj != null ? obj : NIL; + } + } catch (VerifyError e) { return error(new LispError("Class verification failed: " + @@ -1101,7 +1090,7 @@ new Pathname(namestring))); } - private static final LispObject loadCompiledFunction(InputStream in, int size) + protected static final LispObject loadCompiledFunction(InputStream in, int size) { try { @@ -1121,17 +1110,7 @@ Debug.trace("bytesRemaining = " + bytesRemaining); //JavaClassLoader loader = new JavaClassLoader(); - Class c = - (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); - if (c != null) - { - Constructor constructor = c.getConstructor((Class[])null); - LispObject obj = - (LispObject) constructor.newInstance((Object[])null); - if (obj instanceof Function) - ((Function)obj).setClassBytes(bytes); - return obj; - } + return loadCompiledFunction(bytes); } catch (Throwable t) { @@ -1140,6 +1119,21 @@ return null; } + protected static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable { + Class c = (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); + if (c != null) { + Class sc = c.getSuperclass(); + Constructor constructor = c.getConstructor((Class[])null); + LispObject obj = (LispObject) constructor.newInstance((Object[])null); + if (obj instanceof Function) { + ((Function)obj).setClassBytes(bytes); + } + return obj; + } else { + return null; + } + } + public static final LispObject makeCompiledClosure(LispObject template, LispObject[] context) throws ConditionThrowable Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Thu Mar 5 23:12:24 2009 @@ -33,7 +33,7 @@ package org.armedbear.lisp; -public class LispObject extends Lisp +public class LispObject extends Lisp implements java.io.Serializable { public LispObject typeOf() { @@ -108,10 +108,11 @@ public Object javaInstance(Class c) throws ConditionThrowable { - if (c == LispObject.class) - return this; - return error(new LispError("The value " + writeToString() + - " is not of primitive type.")); + if (c.isAssignableFrom(this.getClass())) { + return this; + } + return error(new LispError("The value " + writeToString() + + " is not of type " + c.getName())); } public LispObject car() throws ConditionThrowable @@ -1159,4 +1160,5 @@ public void incrementCallCount() { } + } 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 Thu Mar 5 23:12:24 2009 @@ -288,7 +288,8 @@ if (url != null) { try { in = url.openStream(); - if ("jar".equals(url.getProtocol())) + if ("jar".equals(url.getProtocol()) && + url.getPath().startsWith("file:")) pathname = new Pathname(url); truename = getPath(url); } @@ -453,7 +454,7 @@ LispObject obj = in.read(false, EOF, false, thread); if (obj == EOF) break; - LispObject result = eval(obj, env, thread); + LispObject result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/Nil.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Nil.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Nil.java Thu Mar 5 23:12:24 2009 @@ -249,4 +249,9 @@ return "|COMMON-LISP|::|NIL|"; return "NIL"; } + + public Object readResolve() throws java.io.ObjectStreamException { + return NIL; + } + } 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 Thu Mar 5 23:12:24 2009 @@ -306,7 +306,7 @@ dispatchTable.functions[LispCharacter.toUpperCase(subChar)] = function; } - protected static class DispatchTable + protected static class DispatchTable implements java.io.Serializable { public LispObject[] functions = new LispObject[CHAR_MAX]; Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Thu Mar 5 23:12:24 2009 @@ -828,7 +828,7 @@ list1(Symbol.GENERIC_FUNCTION), list1(StandardClass.STANDARD_GENERIC_FUNCTION)); - private static class CacheEntry + private static class CacheEntry implements java.io.Serializable { final LispObject[] array; 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 Thu Mar 5 23:12:24 2009 @@ -69,12 +69,12 @@ private boolean open = true; // Character input. - protected PushbackReader reader; + protected transient PushbackReader reader; //provvisorio finch? non capisco chi serializza lo stream protected int offset; protected int lineNumber; // Character output. - private Writer writer; + private transient Writer writer; /** The number of characters on the current line of output * @@ -110,10 +110,10 @@ protected char lastChar = 0; // Binary input. - private InputStream in; + private transient InputStream in; // Binary output. - private OutputStream out; + private transient OutputStream out; protected Stream() { @@ -3024,4 +3024,21 @@ return second; } }; + + public OutputStream getJavaOutputStream() { + return out; + } + + public InputStream getJavaInputStream() { + return in; + } + + public Writer getJavaWriter() { + return writer; + } + + public Reader getJavaReader() { + return reader; + } + } 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 Thu Mar 5 23:12:24 2009 @@ -57,7 +57,7 @@ public final SimpleString name; private int hash = -1; - private LispObject pkg; // Either a package object or NIL. + private transient LispObject pkg; // Either a package object or NIL. private LispObject value; private LispObject function; private LispObject propertyList; @@ -888,6 +888,35 @@ function.incrementCallCount(); } + private void readObject(java.io.ObjectInputStream stream) throws java.io.IOException, ClassNotFoundException { + stream.defaultReadObject(); + Object pkg = stream.readObject(); + if(pkg == NIL) { + this.pkg = NIL; + } else { + this.pkg = Packages.findPackage(pkg.toString()); + } + } + + public Object readResolve() throws java.io.ObjectStreamException { + if(pkg instanceof Package) { + Symbol s = ((Package) pkg).intern(name.getStringValue()); + s.value = value; + s.function = function; + s.propertyList = propertyList; + s.hash = hash; + s.flags = flags; + return s; + } + return this; + } + + private void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { + stream.defaultWriteObject(); + stream.writeObject(this.pkg == NIL ? NIL : ((Package) pkg).getName()); + } + + // External symbols in CL package. public static final Symbol AND_ALLOW_OTHER_KEYS = PACKAGE_CL.addExternalSymbol("&ALLOW-OTHER-KEYS"); Modified: trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java Thu Mar 5 23:12:24 2009 @@ -36,7 +36,7 @@ import java.util.ArrayList; import java.util.List; -public final class SymbolHashTable +public final class SymbolHashTable implements java.io.Serializable { private static final float LOAD_FACTOR = 0.75f; @@ -221,7 +221,7 @@ return list; } - private static class HashEntry + private static class HashEntry implements java.io.Serializable { Symbol symbol; HashEntry next; Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Thu Mar 5 23:12:24 2009 @@ -114,7 +114,7 @@ (declare (type fixnum i)) (when (char= (char name i) #\-) (setf (char name i) #\_))) - (concatenate 'string "org/armedbear/lisp/" name))) + (concatenate 'string "org/armedbear/lisp/ABCL_GENERATED_" name))) (defun make-class-file (&key pathname lambda-name lambda-list) (aver (not (null pathname))) From astalla at common-lisp.net Thu Mar 5 23:20:49 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 05 Mar 2009 23:20:49 +0000 Subject: [armedbear-cvs] r11698 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Mar 5 23:20:43 2009 New Revision: 11698 Log: reverted wrong commit. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Binding.java trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/HashTable.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/LispObject.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Nil.java trunk/abcl/src/org/armedbear/lisp/Readtable.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java trunk/abcl/src/org/armedbear/lisp/jvm.lisp 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 Thu Mar 5 23:20:43 2009 @@ -338,16 +338,6 @@ } }; - /* - public void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { - try { - load(); - } catch(ConditionThrowable t) { - throw new java.io.InvalidObjectException("Couldn't resolve autoload: " + t); - } - stream.defaultWriteObject(); - }*/ - static { autoload("acos", "MathFunctions"); autoload("acosh", "MathFunctions"); Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Binding.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Binding.java Thu Mar 5 23:20:43 2009 @@ -34,7 +34,7 @@ package org.armedbear.lisp; // Package accessibility. -final class Binding implements java.io.Serializable +final class Binding { final LispObject symbol; LispObject value; Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Thu Mar 5 23:20:43 2009 @@ -1041,7 +1041,7 @@ } } - private static class Parameter implements java.io.Serializable + private static class Parameter { private final Symbol var; private final LispObject initForm; 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 Thu Mar 5 23:20:43 2009 @@ -324,20 +324,4 @@ { ++callCount; } - - protected Object writeReplace() throws java.io.ObjectStreamException { - if(getClass().getSimpleName().contains("ABCL_GENERATED_")) { - try { - return new ExternalizedCompiledFunction((byte[] ) getf(propertyList, Symbol.CLASS_BYTES, - new JavaObject(new byte[0])).javaInstance(), - lambdaName.writeToString(), - getClass().getName()); - } catch(ConditionThrowable c) { - throw new java.io.InvalidClassException(getClass().getName()); - } - } else { - return this; - } - } - } Modified: trunk/abcl/src/org/armedbear/lisp/HashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/HashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/HashTable.java Thu Mar 5 23:20:43 2009 @@ -286,7 +286,7 @@ return NIL; } - protected static class HashEntry implements java.io.Serializable + protected static class HashEntry { LispObject key; LispObject value; 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 Thu Mar 5 23:20:43 2009 @@ -40,7 +40,6 @@ import java.io.InputStreamReader; import java.io.OutputStream; import java.lang.reflect.Method; -import java.security.*; public final class Interpreter extends Lisp { @@ -140,14 +139,6 @@ private Interpreter() { - Policy.setPolicy( - new Policy() { - public PermissionCollection getPermissions(CodeSource codesource) { - Permissions perms = new Permissions(); - perms.add(new AllPermission()); - return (perms); - } - }); jlisp = false; inputStream = null; outputStream = null; Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Thu Mar 5 23:20:43 2009 @@ -620,10 +620,13 @@ final LispObject methodArg = args[0]; final LispObject instanceArg = args[1]; final Object instance; - if (instanceArg != null) { - instance = instanceArg.javaInstance(); - } else { - type_error(instanceArg, Symbol.T); + if (instanceArg instanceof AbstractString) + instance = instanceArg.getStringValue(); + else if (instanceArg instanceof JavaObject) + instance = ((JavaObject)instanceArg).getObject(); + else { + type_error(instanceArg, + list3(Symbol.OR, Symbol.STRING, Symbol.JAVA_OBJECT)); // Not reached. return null; } 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 Thu Mar 5 23:20:43 2009 @@ -33,7 +33,10 @@ package org.armedbear.lisp; -import java.io.*; +import java.io.File; +import java.io.FileInputStream; +import java.io.IOException; +import java.io.InputStream; import java.lang.reflect.Constructor; import java.math.BigInteger; import java.net.URL; @@ -981,43 +984,51 @@ } if (device instanceof Pathname) { - // We're loading a fasl from a jar. + // We're loading a fasl from j.jar. URL url = Lisp.class.getResource(namestring); - if (url != null) { - try { + if (url != null) + { + try + { String s = url.toString(); - InputStream input = url.openStream(); - ByteArrayOutputStream baos = new ByteArrayOutputStream(); - - byte[] bytes = new byte[4096]; - int n = 0; - while (n >= 0) { - n = input.read(bytes, 0, 4096); - if(n >= 0) { - baos.write(bytes, 0, n); - } - } - input.close(); - bytes = baos.toByteArray(); - baos.close(); - JavaClassLoader loader = new JavaClassLoader(); - Class c = - loader.loadClassFromByteArray(null, bytes, 0, bytes.length); - if (c != null) { - Class[] parameterTypes = new Class[0]; - Constructor constructor = - c.getConstructor(parameterTypes); - Object[] initargs = new Object[0]; - LispObject obj = - (LispObject) constructor.newInstance(initargs); - if (obj instanceof Function) - ((Function)obj).setClassBytes(bytes); - else { - System.out.println("obj: " + obj); - } - return obj != null ? obj : NIL; - } - } + String zipFileName; + String entryName; + if (s.startsWith("jar:file:")) + { + s = s.substring(9); + int index = s.lastIndexOf('!'); + if (index >= 0) + { + zipFileName = s.substring(0, index); + entryName = s.substring(index + 1); + if (entryName.length() > 0 && entryName.charAt(0) == '/') + entryName = entryName.substring(1); + if (Utilities.isPlatformWindows) + { + // "/C:/Documents%20and%20Settings/peter/Desktop/j.jar" + if (zipFileName.length() > 0 && zipFileName.charAt(0) == '/') + zipFileName = zipFileName.substring(1); + } + zipFileName = URLDecoder.decode(zipFileName, "UTF-8"); + ZipFile zipFile = new ZipFile(zipFileName); + try + { + ZipEntry entry = zipFile.getEntry(entryName); + if (entry != null) + { + long size = entry.getSize(); + InputStream in = zipFile.getInputStream(entry); + LispObject obj = loadCompiledFunction(in, (int) size); + return obj != null ? obj : NIL; + } + } + finally + { + zipFile.close(); + } + } + } + } catch (VerifyError e) { return error(new LispError("Class verification failed: " + @@ -1090,7 +1101,7 @@ new Pathname(namestring))); } - protected static final LispObject loadCompiledFunction(InputStream in, int size) + private static final LispObject loadCompiledFunction(InputStream in, int size) { try { @@ -1110,7 +1121,17 @@ Debug.trace("bytesRemaining = " + bytesRemaining); //JavaClassLoader loader = new JavaClassLoader(); - return loadCompiledFunction(bytes); + Class c = + (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); + if (c != null) + { + Constructor constructor = c.getConstructor((Class[])null); + LispObject obj = + (LispObject) constructor.newInstance((Object[])null); + if (obj instanceof Function) + ((Function)obj).setClassBytes(bytes); + return obj; + } } catch (Throwable t) { @@ -1119,21 +1140,6 @@ return null; } - protected static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable { - Class c = (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); - if (c != null) { - Class sc = c.getSuperclass(); - Constructor constructor = c.getConstructor((Class[])null); - LispObject obj = (LispObject) constructor.newInstance((Object[])null); - if (obj instanceof Function) { - ((Function)obj).setClassBytes(bytes); - } - return obj; - } else { - return null; - } - } - public static final LispObject makeCompiledClosure(LispObject template, LispObject[] context) throws ConditionThrowable Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Thu Mar 5 23:20:43 2009 @@ -33,7 +33,7 @@ package org.armedbear.lisp; -public class LispObject extends Lisp implements java.io.Serializable +public class LispObject extends Lisp { public LispObject typeOf() { @@ -108,11 +108,10 @@ public Object javaInstance(Class c) throws ConditionThrowable { - if (c.isAssignableFrom(this.getClass())) { - return this; - } - return error(new LispError("The value " + writeToString() + - " is not of type " + c.getName())); + if (c == LispObject.class) + return this; + return error(new LispError("The value " + writeToString() + + " is not of primitive type.")); } public LispObject car() throws ConditionThrowable @@ -1160,5 +1159,4 @@ public void incrementCallCount() { } - } 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 Thu Mar 5 23:20:43 2009 @@ -288,8 +288,7 @@ if (url != null) { try { in = url.openStream(); - if ("jar".equals(url.getProtocol()) && - url.getPath().startsWith("file:")) + if ("jar".equals(url.getProtocol())) pathname = new Pathname(url); truename = getPath(url); } @@ -454,7 +453,7 @@ LispObject obj = in.read(false, EOF, false, thread); if (obj == EOF) break; - LispObject result = eval(obj, env, thread); + LispObject result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/Nil.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Nil.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Nil.java Thu Mar 5 23:20:43 2009 @@ -249,9 +249,4 @@ return "|COMMON-LISP|::|NIL|"; return "NIL"; } - - public Object readResolve() throws java.io.ObjectStreamException { - return NIL; - } - } 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 Thu Mar 5 23:20:43 2009 @@ -306,7 +306,7 @@ dispatchTable.functions[LispCharacter.toUpperCase(subChar)] = function; } - protected static class DispatchTable implements java.io.Serializable + protected static class DispatchTable { public LispObject[] functions = new LispObject[CHAR_MAX]; Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Thu Mar 5 23:20:43 2009 @@ -828,7 +828,7 @@ list1(Symbol.GENERIC_FUNCTION), list1(StandardClass.STANDARD_GENERIC_FUNCTION)); - private static class CacheEntry implements java.io.Serializable + private static class CacheEntry { final LispObject[] array; 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 Thu Mar 5 23:20:43 2009 @@ -69,12 +69,12 @@ private boolean open = true; // Character input. - protected transient PushbackReader reader; //provvisorio finch? non capisco chi serializza lo stream + protected PushbackReader reader; protected int offset; protected int lineNumber; // Character output. - private transient Writer writer; + private Writer writer; /** The number of characters on the current line of output * @@ -110,10 +110,10 @@ protected char lastChar = 0; // Binary input. - private transient InputStream in; + private InputStream in; // Binary output. - private transient OutputStream out; + private OutputStream out; protected Stream() { @@ -3024,21 +3024,4 @@ return second; } }; - - public OutputStream getJavaOutputStream() { - return out; - } - - public InputStream getJavaInputStream() { - return in; - } - - public Writer getJavaWriter() { - return writer; - } - - public Reader getJavaReader() { - return reader; - } - } 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 Thu Mar 5 23:20:43 2009 @@ -57,7 +57,7 @@ public final SimpleString name; private int hash = -1; - private transient LispObject pkg; // Either a package object or NIL. + private LispObject pkg; // Either a package object or NIL. private LispObject value; private LispObject function; private LispObject propertyList; @@ -888,35 +888,6 @@ function.incrementCallCount(); } - private void readObject(java.io.ObjectInputStream stream) throws java.io.IOException, ClassNotFoundException { - stream.defaultReadObject(); - Object pkg = stream.readObject(); - if(pkg == NIL) { - this.pkg = NIL; - } else { - this.pkg = Packages.findPackage(pkg.toString()); - } - } - - public Object readResolve() throws java.io.ObjectStreamException { - if(pkg instanceof Package) { - Symbol s = ((Package) pkg).intern(name.getStringValue()); - s.value = value; - s.function = function; - s.propertyList = propertyList; - s.hash = hash; - s.flags = flags; - return s; - } - return this; - } - - private void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { - stream.defaultWriteObject(); - stream.writeObject(this.pkg == NIL ? NIL : ((Package) pkg).getName()); - } - - // External symbols in CL package. public static final Symbol AND_ALLOW_OTHER_KEYS = PACKAGE_CL.addExternalSymbol("&ALLOW-OTHER-KEYS"); Modified: trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SymbolHashTable.java Thu Mar 5 23:20:43 2009 @@ -36,7 +36,7 @@ import java.util.ArrayList; import java.util.List; -public final class SymbolHashTable implements java.io.Serializable +public final class SymbolHashTable { private static final float LOAD_FACTOR = 0.75f; @@ -221,7 +221,7 @@ return list; } - private static class HashEntry implements java.io.Serializable + private static class HashEntry { Symbol symbol; HashEntry next; Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Thu Mar 5 23:20:43 2009 @@ -114,7 +114,7 @@ (declare (type fixnum i)) (when (char= (char name i) #\-) (setf (char name i) #\_))) - (concatenate 'string "org/armedbear/lisp/ABCL_GENERATED_" name))) + (concatenate 'string "org/armedbear/lisp/" name))) (defun make-class-file (&key pathname lambda-name lambda-list) (aver (not (null pathname))) From ehuelsmann at common-lisp.net Fri Mar 6 20:21:04 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 06 Mar 2009 20:21:04 +0000 Subject: [armedbear-cvs] r11700 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 6 20:21:01 2009 New Revision: 11700 Log: Add OpenBSD and NetBSD platform detection support. Patch by: Julian Fondren (ayrnieu at gmail dot com) Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/ShellCommand.java trunk/abcl/src/org/armedbear/lisp/Utilities.java Modified: trunk/abcl/src/org/armedbear/lisp/Keyword.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Keyword.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Keyword.java Fri Mar 6 20:21:01 2009 @@ -101,12 +101,14 @@ LOCAL = internKeyword("LOCAL"), LONG = internKeyword("LONG"), NAME = internKeyword("NAME"), + NETBSD = internKeyword("NETBSD"), NEW_VERSION = internKeyword("NEW"), NEWEST = internKeyword("NEWEST"), NICKNAMES = internKeyword("NICKNAMES"), NONE = internKeyword("NONE"), NO_ERROR = internKeyword("NO-ERROR"), OBJECT = internKeyword("OBJECT"), + OPENBSD = internKeyword("OPENBSD"), OPERANDS = internKeyword("OPERANDS"), OPERATION = internKeyword("OPERATION"), OUTPUT = internKeyword("OUTPUT"), 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 Fri Mar 6 20:21:01 2009 @@ -2139,6 +2139,26 @@ Keyword.FREEBSD, Keyword.CDR6)); } + else if (osName.startsWith("OpenBSD")) + { + Symbol.FEATURES.setSymbolValue(list7(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.UNIX, + Keyword.OPENBSD, + Keyword.CDR6)); + } + else if (osName.startsWith("NetBSD")) + { + Symbol.FEATURES.setSymbolValue(list7(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.UNIX, + Keyword.NETBSD, + Keyword.CDR6)); + } else if (osName.startsWith("Windows")) { Symbol.FEATURES.setSymbolValue(list6(Keyword.ARMEDBEAR, Modified: trunk/abcl/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ShellCommand.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ShellCommand.java Fri Mar 6 20:21:01 2009 @@ -249,25 +249,31 @@ LispObject third) throws ConditionThrowable { - String command = first.getStringValue(); - String namestring = null; - Stream outputStream = null; - if (second != NIL) { - Pathname pathname = coerceToPathname(second); - namestring = pathname.getNamestring(); - if (namestring == null) { - return error(new FileError("Pathname has no namestring: " + pathname.writeToString(), - pathname)); + if (!(Utilities.isPlatformUnix || Utilities.isPlatformWindows)) { + return error(new LispError("run-shell-command not implemented for " + + System.getProperty("os.name"))); + } + else { + String command = first.getStringValue(); + String namestring = null; + Stream outputStream = null; + if (second != NIL) { + Pathname pathname = coerceToPathname(second); + namestring = pathname.getNamestring(); + if (namestring == null) { + return error(new FileError("Pathname has no namestring: " + pathname.writeToString(), + pathname)); + } } + if (third != NIL) + outputStream = checkStream(third); + ShellCommand shellCommand = new ShellCommand(command, namestring, + outputStream); + shellCommand.run(); + if (outputStream != null) + outputStream._finishOutput(); + return number(shellCommand.exitValue()); } - if (third != NIL) - outputStream = checkStream(third); - ShellCommand shellCommand = new ShellCommand(command, namestring, - outputStream); - shellCommand.run(); - if (outputStream != null) - outputStream._finishOutput(); - return number(shellCommand.exitValue()); } }; } Modified: trunk/abcl/src/org/armedbear/lisp/Utilities.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Utilities.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Utilities.java Fri Mar 6 20:21:01 2009 @@ -46,7 +46,8 @@ isPlatformUnix = osName.startsWith("Linux") || osName.startsWith("Mac OS X") || osName.startsWith("Solaris") || osName.startsWith("SunOS") || osName.startsWith("AIX") || - osName.startsWith("FreeBSD"); + osName.startsWith("FreeBSD") || osName.startsWith("OpenBSD") || + osName.startsWith("NetBSD"); isPlatformWindows = osName.startsWith("Windows"); } From ehuelsmann at common-lisp.net Sat Mar 7 19:53:45 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 07 Mar 2009 19:53:45 +0000 Subject: [armedbear-cvs] r11701 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Mar 7 19:53:41 2009 New Revision: 11701 Log: Remove j.lisp and emacs.lisp; Kevin Krouse indicates J doesn't use them anymore. Removed: trunk/abcl/src/org/armedbear/lisp/emacs.lisp trunk/abcl/src/org/armedbear/lisp/j.lisp From astalla at common-lisp.net Fri Mar 6 00:01:49 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 06 Mar 2009 00:01:49 +0000 Subject: [armedbear-cvs] r11699 - in branches/save-image: . dist doc examples examples/abcl examples/abcl/interface_implementation_in_lisp examples/abcl/java_exception_in_lisp examples/abcl/javacall_from_lisp examples/abcl/jsr-223 examples/abcl/lispcall_from_java_simple examples/abcl/lispcall_from_java_with_params_and_return nbproject nbproject/configs scripts src src/META-INF src/META-INF/services src/org src/org/armedbear src/org/armedbear/lisp src/org/armedbear/lisp/java src/org/armedbear/lisp/java/awt src/org/armedbear/lisp/scripting src/org/armedbear/lisp/scripting/lisp src/org/armedbear/lisp/scripting/util src/org/armedbear/lisp/util web Message-ID: Author: astalla Date: Fri Mar 6 00:01:48 2009 New Revision: 11699 Log: Copied files from trunk + modifications for Serialization. Added: branches/save-image/COPYING branches/save-image/README branches/save-image/abcl.asd branches/save-image/abcl.bat.in branches/save-image/abcl.in branches/save-image/build-abcl.lisp branches/save-image/build.properties.in branches/save-image/build.xml branches/save-image/customizations.lisp.in branches/save-image/dist/ branches/save-image/dist/abcl.jar (contents, props changed) branches/save-image/doc/ branches/save-image/examples/ branches/save-image/examples/.abclrc branches/save-image/examples/abcl/ branches/save-image/examples/abcl/README branches/save-image/examples/abcl/interface_implementation_in_lisp/ branches/save-image/examples/abcl/interface_implementation_in_lisp/Main.java branches/save-image/examples/abcl/interface_implementation_in_lisp/MyInterface.java branches/save-image/examples/abcl/interface_implementation_in_lisp/interface_implementation.lisp branches/save-image/examples/abcl/java_exception_in_lisp/ branches/save-image/examples/abcl/java_exception_in_lisp/Main.java branches/save-image/examples/abcl/java_exception_in_lisp/lispfunctions.lisp branches/save-image/examples/abcl/javacall_from_lisp/ branches/save-image/examples/abcl/javacall_from_lisp/Main.java branches/save-image/examples/abcl/javacall_from_lisp/lispfunctions.lisp branches/save-image/examples/abcl/jsr-223/ branches/save-image/examples/abcl/jsr-223/JSR223Example.java branches/save-image/examples/abcl/lispcall_from_java_simple/ branches/save-image/examples/abcl/lispcall_from_java_simple/Main.java branches/save-image/examples/abcl/lispcall_from_java_simple/MainAlternative.java branches/save-image/examples/abcl/lispcall_from_java_simple/lispfunction.lisp branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/ branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/Main.java branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/lispfunctions.lisp branches/save-image/examples/complete.lisp branches/save-image/examples/hello.java branches/save-image/examples/init.lisp branches/save-image/examples/key-pressed.lisp branches/save-image/examples/update-check-enabled.lisp branches/save-image/install-sh branches/save-image/make-jar.bat.in branches/save-image/make-jar.in branches/save-image/mkinstalldirs branches/save-image/nbproject/ branches/save-image/nbproject/build-impl.xml branches/save-image/nbproject/configs/ branches/save-image/nbproject/configs/J.properties branches/save-image/nbproject/genfiles.properties branches/save-image/nbproject/project.properties branches/save-image/nbproject/project.xml branches/save-image/netbeans-build.xml branches/save-image/scripts/ branches/save-image/src/ branches/save-image/src/META-INF/ branches/save-image/src/META-INF/services/ branches/save-image/src/META-INF/services/javax.script.ScriptEngineFactory branches/save-image/src/manifest-abcl branches/save-image/src/org/ branches/save-image/src/org/armedbear/ branches/save-image/src/org/armedbear/lisp/ branches/save-image/src/org/armedbear/lisp/AbstractArray.java branches/save-image/src/org/armedbear/lisp/AbstractBitVector.java branches/save-image/src/org/armedbear/lisp/AbstractString.java branches/save-image/src/org/armedbear/lisp/AbstractVector.java branches/save-image/src/org/armedbear/lisp/ArithmeticError.java branches/save-image/src/org/armedbear/lisp/Autoload.java branches/save-image/src/org/armedbear/lisp/AutoloadMacro.java branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java branches/save-image/src/org/armedbear/lisp/Bignum.java branches/save-image/src/org/armedbear/lisp/Binding.java branches/save-image/src/org/armedbear/lisp/BroadcastStream.java branches/save-image/src/org/armedbear/lisp/BuiltInClass.java branches/save-image/src/org/armedbear/lisp/CapitalizeFirstStream.java branches/save-image/src/org/armedbear/lisp/CapitalizeStream.java branches/save-image/src/org/armedbear/lisp/CaseFrobStream.java branches/save-image/src/org/armedbear/lisp/CellError.java branches/save-image/src/org/armedbear/lisp/CharacterFunctions.java branches/save-image/src/org/armedbear/lisp/Closure.java branches/save-image/src/org/armedbear/lisp/ClosureTemplateFunction.java branches/save-image/src/org/armedbear/lisp/CompiledClosure.java branches/save-image/src/org/armedbear/lisp/CompiledFunction.java branches/save-image/src/org/armedbear/lisp/CompilerError.java branches/save-image/src/org/armedbear/lisp/CompilerUnsupportedFeatureError.java branches/save-image/src/org/armedbear/lisp/Complex.java branches/save-image/src/org/armedbear/lisp/ComplexArray.java branches/save-image/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java branches/save-image/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java branches/save-image/src/org/armedbear/lisp/ComplexBitVector.java branches/save-image/src/org/armedbear/lisp/ComplexString.java branches/save-image/src/org/armedbear/lisp/ComplexVector.java branches/save-image/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java branches/save-image/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java branches/save-image/src/org/armedbear/lisp/ConcatenatedStream.java branches/save-image/src/org/armedbear/lisp/Condition.java branches/save-image/src/org/armedbear/lisp/ConditionThrowable.java branches/save-image/src/org/armedbear/lisp/Cons.java branches/save-image/src/org/armedbear/lisp/ControlError.java branches/save-image/src/org/armedbear/lisp/Debug.java branches/save-image/src/org/armedbear/lisp/DispatchMacroFunction.java branches/save-image/src/org/armedbear/lisp/DivisionByZero.java branches/save-image/src/org/armedbear/lisp/Do.java branches/save-image/src/org/armedbear/lisp/DoubleFloat.java branches/save-image/src/org/armedbear/lisp/DowncaseStream.java branches/save-image/src/org/armedbear/lisp/EchoStream.java branches/save-image/src/org/armedbear/lisp/EndOfFile.java branches/save-image/src/org/armedbear/lisp/Environment.java branches/save-image/src/org/armedbear/lisp/EqHashTable.java branches/save-image/src/org/armedbear/lisp/EqlHashTable.java branches/save-image/src/org/armedbear/lisp/EqualHashTable.java branches/save-image/src/org/armedbear/lisp/EqualpHashTable.java branches/save-image/src/org/armedbear/lisp/Extensions.java branches/save-image/src/org/armedbear/lisp/ExternalizedCompiledFunction.java branches/save-image/src/org/armedbear/lisp/FaslReader.java branches/save-image/src/org/armedbear/lisp/FaslReadtable.java branches/save-image/src/org/armedbear/lisp/FastStringBuffer.java branches/save-image/src/org/armedbear/lisp/FileError.java branches/save-image/src/org/armedbear/lisp/FileStream.java branches/save-image/src/org/armedbear/lisp/FillPointerOutputStream.java branches/save-image/src/org/armedbear/lisp/Fixnum.java branches/save-image/src/org/armedbear/lisp/FloatFunctions.java branches/save-image/src/org/armedbear/lisp/FloatingPointInexact.java branches/save-image/src/org/armedbear/lisp/FloatingPointInvalidOperation.java branches/save-image/src/org/armedbear/lisp/FloatingPointOverflow.java branches/save-image/src/org/armedbear/lisp/FloatingPointUnderflow.java branches/save-image/src/org/armedbear/lisp/ForwardReferencedClass.java branches/save-image/src/org/armedbear/lisp/Function.java branches/save-image/src/org/armedbear/lisp/FunctionBinding.java branches/save-image/src/org/armedbear/lisp/GenericFunction.java branches/save-image/src/org/armedbear/lisp/Go.java branches/save-image/src/org/armedbear/lisp/HashTable.java branches/save-image/src/org/armedbear/lisp/HashTableFunctions.java branches/save-image/src/org/armedbear/lisp/Interpreter.java branches/save-image/src/org/armedbear/lisp/JHandler.java branches/save-image/src/org/armedbear/lisp/JProxy.java branches/save-image/src/org/armedbear/lisp/Java.java branches/save-image/src/org/armedbear/lisp/JavaClass.java branches/save-image/src/org/armedbear/lisp/JavaClassLoader.java branches/save-image/src/org/armedbear/lisp/JavaException.java branches/save-image/src/org/armedbear/lisp/JavaObject.java branches/save-image/src/org/armedbear/lisp/Keyword.java branches/save-image/src/org/armedbear/lisp/LICENSE branches/save-image/src/org/armedbear/lisp/Layout.java branches/save-image/src/org/armedbear/lisp/Lisp.java branches/save-image/src/org/armedbear/lisp/LispCharacter.java branches/save-image/src/org/armedbear/lisp/LispClass.java branches/save-image/src/org/armedbear/lisp/LispError.java branches/save-image/src/org/armedbear/lisp/LispInteger.java branches/save-image/src/org/armedbear/lisp/LispObject.java branches/save-image/src/org/armedbear/lisp/LispObjectInputStream.java branches/save-image/src/org/armedbear/lisp/LispReader.java branches/save-image/src/org/armedbear/lisp/LispThread.java branches/save-image/src/org/armedbear/lisp/Load.java branches/save-image/src/org/armedbear/lisp/LogicalPathname.java branches/save-image/src/org/armedbear/lisp/MacroObject.java branches/save-image/src/org/armedbear/lisp/Mailbox.java branches/save-image/src/org/armedbear/lisp/Main.java branches/save-image/src/org/armedbear/lisp/MathFunctions.java branches/save-image/src/org/armedbear/lisp/Mutex.java branches/save-image/src/org/armedbear/lisp/Nil.java branches/save-image/src/org/armedbear/lisp/NilVector.java branches/save-image/src/org/armedbear/lisp/Operator.java branches/save-image/src/org/armedbear/lisp/Package.java branches/save-image/src/org/armedbear/lisp/PackageError.java branches/save-image/src/org/armedbear/lisp/PackageFunctions.java branches/save-image/src/org/armedbear/lisp/Packages.java branches/save-image/src/org/armedbear/lisp/ParseError.java branches/save-image/src/org/armedbear/lisp/Pathname.java branches/save-image/src/org/armedbear/lisp/Primitive.java branches/save-image/src/org/armedbear/lisp/Primitive0R.java branches/save-image/src/org/armedbear/lisp/Primitive1R.java branches/save-image/src/org/armedbear/lisp/Primitive2R.java branches/save-image/src/org/armedbear/lisp/Primitives.java branches/save-image/src/org/armedbear/lisp/PrintNotReadable.java branches/save-image/src/org/armedbear/lisp/Profiler.java branches/save-image/src/org/armedbear/lisp/ProgramError.java branches/save-image/src/org/armedbear/lisp/RandomState.java branches/save-image/src/org/armedbear/lisp/Ratio.java branches/save-image/src/org/armedbear/lisp/ReaderError.java branches/save-image/src/org/armedbear/lisp/ReaderMacroFunction.java branches/save-image/src/org/armedbear/lisp/Readtable.java branches/save-image/src/org/armedbear/lisp/Return.java branches/save-image/src/org/armedbear/lisp/RuntimeClass.java branches/save-image/src/org/armedbear/lisp/SeriousCondition.java branches/save-image/src/org/armedbear/lisp/ShellCommand.java branches/save-image/src/org/armedbear/lisp/SimpleArray_T.java branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java branches/save-image/src/org/armedbear/lisp/SimpleBitVector.java branches/save-image/src/org/armedbear/lisp/SimpleCondition.java branches/save-image/src/org/armedbear/lisp/SimpleError.java branches/save-image/src/org/armedbear/lisp/SimpleString.java branches/save-image/src/org/armedbear/lisp/SimpleTypeError.java branches/save-image/src/org/armedbear/lisp/SimpleVector.java branches/save-image/src/org/armedbear/lisp/SimpleWarning.java branches/save-image/src/org/armedbear/lisp/SingleFloat.java branches/save-image/src/org/armedbear/lisp/Site.java branches/save-image/src/org/armedbear/lisp/SiteName.java branches/save-image/src/org/armedbear/lisp/SlimeInputStream.java branches/save-image/src/org/armedbear/lisp/SlimeOutputStream.java branches/save-image/src/org/armedbear/lisp/SlotClass.java branches/save-image/src/org/armedbear/lisp/SlotDefinition.java branches/save-image/src/org/armedbear/lisp/SlotDefinitionClass.java branches/save-image/src/org/armedbear/lisp/SocketStream.java branches/save-image/src/org/armedbear/lisp/SpecialBinding.java branches/save-image/src/org/armedbear/lisp/SpecialOperator.java branches/save-image/src/org/armedbear/lisp/SpecialOperators.java branches/save-image/src/org/armedbear/lisp/StandardClass.java branches/save-image/src/org/armedbear/lisp/StandardGenericFunction.java branches/save-image/src/org/armedbear/lisp/StandardGenericFunctionClass.java branches/save-image/src/org/armedbear/lisp/StandardMethod.java branches/save-image/src/org/armedbear/lisp/StandardMethodClass.java branches/save-image/src/org/armedbear/lisp/StandardObject.java branches/save-image/src/org/armedbear/lisp/StandardObjectFunctions.java branches/save-image/src/org/armedbear/lisp/StandardReaderMethod.java branches/save-image/src/org/armedbear/lisp/StandardReaderMethodClass.java branches/save-image/src/org/armedbear/lisp/StorageCondition.java branches/save-image/src/org/armedbear/lisp/Stream.java branches/save-image/src/org/armedbear/lisp/StreamError.java branches/save-image/src/org/armedbear/lisp/StringFunctions.java branches/save-image/src/org/armedbear/lisp/StringInputStream.java branches/save-image/src/org/armedbear/lisp/StringOutputStream.java branches/save-image/src/org/armedbear/lisp/StructureClass.java branches/save-image/src/org/armedbear/lisp/StructureObject.java branches/save-image/src/org/armedbear/lisp/StyleWarning.java branches/save-image/src/org/armedbear/lisp/Symbol.java branches/save-image/src/org/armedbear/lisp/SymbolHashTable.java branches/save-image/src/org/armedbear/lisp/SymbolMacro.java branches/save-image/src/org/armedbear/lisp/SynonymStream.java branches/save-image/src/org/armedbear/lisp/ThreadDestroyed.java branches/save-image/src/org/armedbear/lisp/ThreadLock.java branches/save-image/src/org/armedbear/lisp/Throw.java branches/save-image/src/org/armedbear/lisp/Time.java branches/save-image/src/org/armedbear/lisp/TwoWayStream.java branches/save-image/src/org/armedbear/lisp/TypeError.java branches/save-image/src/org/armedbear/lisp/UnboundSlot.java branches/save-image/src/org/armedbear/lisp/UnboundVariable.java branches/save-image/src/org/armedbear/lisp/UndefinedFunction.java branches/save-image/src/org/armedbear/lisp/UpcaseStream.java branches/save-image/src/org/armedbear/lisp/Utilities.java branches/save-image/src/org/armedbear/lisp/Version.java branches/save-image/src/org/armedbear/lisp/Warning.java branches/save-image/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java branches/save-image/src/org/armedbear/lisp/ZeroRankArray.java branches/save-image/src/org/armedbear/lisp/adjoin.lisp branches/save-image/src/org/armedbear/lisp/adjust_array.java branches/save-image/src/org/armedbear/lisp/and.lisp branches/save-image/src/org/armedbear/lisp/apropos.lisp branches/save-image/src/org/armedbear/lisp/arglist.java branches/save-image/src/org/armedbear/lisp/arrays.lisp branches/save-image/src/org/armedbear/lisp/asdf.lisp branches/save-image/src/org/armedbear/lisp/ash.java branches/save-image/src/org/armedbear/lisp/assert.lisp branches/save-image/src/org/armedbear/lisp/assoc.lisp branches/save-image/src/org/armedbear/lisp/assq.java branches/save-image/src/org/armedbear/lisp/assql.java branches/save-image/src/org/armedbear/lisp/autoloads.lisp branches/save-image/src/org/armedbear/lisp/aver.lisp branches/save-image/src/org/armedbear/lisp/backquote.lisp branches/save-image/src/org/armedbear/lisp/bit-array-ops.lisp branches/save-image/src/org/armedbear/lisp/boole.lisp branches/save-image/src/org/armedbear/lisp/boot.lisp branches/save-image/src/org/armedbear/lisp/butlast.lisp branches/save-image/src/org/armedbear/lisp/byte-io.lisp branches/save-image/src/org/armedbear/lisp/case.lisp branches/save-image/src/org/armedbear/lisp/ceiling.java branches/save-image/src/org/armedbear/lisp/cell_error_name.java branches/save-image/src/org/armedbear/lisp/chars.lisp branches/save-image/src/org/armedbear/lisp/check-type.lisp branches/save-image/src/org/armedbear/lisp/clos.lisp branches/save-image/src/org/armedbear/lisp/coerce.lisp branches/save-image/src/org/armedbear/lisp/collect.lisp branches/save-image/src/org/armedbear/lisp/compile-file-pathname.lisp branches/save-image/src/org/armedbear/lisp/compile-file.lisp branches/save-image/src/org/armedbear/lisp/compile-system.lisp branches/save-image/src/org/armedbear/lisp/compiler-error.lisp branches/save-image/src/org/armedbear/lisp/compiler-macro.lisp branches/save-image/src/org/armedbear/lisp/compiler-pass1.lisp branches/save-image/src/org/armedbear/lisp/compiler-pass2.lisp branches/save-image/src/org/armedbear/lisp/compiler-types.lisp branches/save-image/src/org/armedbear/lisp/concatenate.lisp branches/save-image/src/org/armedbear/lisp/cond.lisp branches/save-image/src/org/armedbear/lisp/copy-seq.lisp branches/save-image/src/org/armedbear/lisp/copy-symbol.lisp branches/save-image/src/org/armedbear/lisp/copy_list.java branches/save-image/src/org/armedbear/lisp/count.lisp branches/save-image/src/org/armedbear/lisp/create_new_file.java branches/save-image/src/org/armedbear/lisp/cxr.java branches/save-image/src/org/armedbear/lisp/debug.lisp branches/save-image/src/org/armedbear/lisp/define-modify-macro.lisp branches/save-image/src/org/armedbear/lisp/define-symbol-macro.lisp branches/save-image/src/org/armedbear/lisp/defmacro.lisp branches/save-image/src/org/armedbear/lisp/defpackage.lisp branches/save-image/src/org/armedbear/lisp/defsetf.lisp branches/save-image/src/org/armedbear/lisp/defstruct.lisp branches/save-image/src/org/armedbear/lisp/deftype.lisp branches/save-image/src/org/armedbear/lisp/delete-duplicates.lisp branches/save-image/src/org/armedbear/lisp/delete.lisp branches/save-image/src/org/armedbear/lisp/delete_file.java branches/save-image/src/org/armedbear/lisp/deposit-field.lisp branches/save-image/src/org/armedbear/lisp/describe-compiler-policy.lisp branches/save-image/src/org/armedbear/lisp/describe.lisp branches/save-image/src/org/armedbear/lisp/destructuring-bind.lisp branches/save-image/src/org/armedbear/lisp/directory.lisp branches/save-image/src/org/armedbear/lisp/disassemble.lisp branches/save-image/src/org/armedbear/lisp/disassemble_class_bytes.java branches/save-image/src/org/armedbear/lisp/do-all-symbols.lisp branches/save-image/src/org/armedbear/lisp/do-external-symbols.lisp branches/save-image/src/org/armedbear/lisp/do-symbols.lisp branches/save-image/src/org/armedbear/lisp/do.lisp branches/save-image/src/org/armedbear/lisp/dolist.java branches/save-image/src/org/armedbear/lisp/dolist.lisp branches/save-image/src/org/armedbear/lisp/dotimes.java branches/save-image/src/org/armedbear/lisp/dotimes.lisp branches/save-image/src/org/armedbear/lisp/dribble.lisp branches/save-image/src/org/armedbear/lisp/dump-class.lisp branches/save-image/src/org/armedbear/lisp/dump-form.lisp branches/save-image/src/org/armedbear/lisp/early-defuns.lisp branches/save-image/src/org/armedbear/lisp/ed.lisp branches/save-image/src/org/armedbear/lisp/emacs.lisp branches/save-image/src/org/armedbear/lisp/enough-namestring.lisp branches/save-image/src/org/armedbear/lisp/ensure-directories-exist.lisp branches/save-image/src/org/armedbear/lisp/error.lisp branches/save-image/src/org/armedbear/lisp/fdefinition.lisp branches/save-image/src/org/armedbear/lisp/featurep.lisp branches/save-image/src/org/armedbear/lisp/file_author.java branches/save-image/src/org/armedbear/lisp/file_error_pathname.java branches/save-image/src/org/armedbear/lisp/file_length.java branches/save-image/src/org/armedbear/lisp/file_string_length.java branches/save-image/src/org/armedbear/lisp/file_write_date.java branches/save-image/src/org/armedbear/lisp/fill.lisp branches/save-image/src/org/armedbear/lisp/find-all-symbols.lisp branches/save-image/src/org/armedbear/lisp/find.lisp branches/save-image/src/org/armedbear/lisp/float_sign.java branches/save-image/src/org/armedbear/lisp/floor.java branches/save-image/src/org/armedbear/lisp/format.lisp branches/save-image/src/org/armedbear/lisp/ftruncate.java branches/save-image/src/org/armedbear/lisp/function_info.java branches/save-image/src/org/armedbear/lisp/gc.java branches/save-image/src/org/armedbear/lisp/gentemp.lisp branches/save-image/src/org/armedbear/lisp/get_properties.java branches/save-image/src/org/armedbear/lisp/gray-streams.lisp branches/save-image/src/org/armedbear/lisp/inline.lisp branches/save-image/src/org/armedbear/lisp/input_stream_p.java branches/save-image/src/org/armedbear/lisp/inspect.lisp branches/save-image/src/org/armedbear/lisp/interactive_stream_p.java branches/save-image/src/org/armedbear/lisp/j.lisp branches/save-image/src/org/armedbear/lisp/java/ branches/save-image/src/org/armedbear/lisp/java.lisp branches/save-image/src/org/armedbear/lisp/java/awt/ branches/save-image/src/org/armedbear/lisp/java/awt/.cvsignore branches/save-image/src/org/armedbear/lisp/java/awt/ActionListener.java branches/save-image/src/org/armedbear/lisp/java/awt/ComponentAdapter.java branches/save-image/src/org/armedbear/lisp/java/awt/ItemListener.java branches/save-image/src/org/armedbear/lisp/java/awt/KeyAdapter.java branches/save-image/src/org/armedbear/lisp/java/awt/Makefile.in branches/save-image/src/org/armedbear/lisp/java/awt/MouseAdapter.java branches/save-image/src/org/armedbear/lisp/java/awt/MouseMotionAdapter.java branches/save-image/src/org/armedbear/lisp/java/awt/WindowAdapter.java branches/save-image/src/org/armedbear/lisp/jclass_name.java branches/save-image/src/org/armedbear/lisp/jclass_of.java branches/save-image/src/org/armedbear/lisp/jmethod_return_type.java branches/save-image/src/org/armedbear/lisp/jvm.lisp branches/save-image/src/org/armedbear/lisp/known-functions.lisp branches/save-image/src/org/armedbear/lisp/known-symbols.lisp branches/save-image/src/org/armedbear/lisp/last.java branches/save-image/src/org/armedbear/lisp/late-setf.lisp branches/save-image/src/org/armedbear/lisp/lcm.lisp branches/save-image/src/org/armedbear/lisp/ldb.lisp branches/save-image/src/org/armedbear/lisp/ldiff.lisp branches/save-image/src/org/armedbear/lisp/lisp_implementation_type.java branches/save-image/src/org/armedbear/lisp/lisp_implementation_version.java branches/save-image/src/org/armedbear/lisp/list-length.lisp branches/save-image/src/org/armedbear/lisp/list.lisp branches/save-image/src/org/armedbear/lisp/listen.java branches/save-image/src/org/armedbear/lisp/load.lisp branches/save-image/src/org/armedbear/lisp/logand.java branches/save-image/src/org/armedbear/lisp/logandc1.java branches/save-image/src/org/armedbear/lisp/logandc2.java branches/save-image/src/org/armedbear/lisp/logbitp.java branches/save-image/src/org/armedbear/lisp/logcount.java branches/save-image/src/org/armedbear/lisp/logeqv.java branches/save-image/src/org/armedbear/lisp/logior.java branches/save-image/src/org/armedbear/lisp/lognand.java branches/save-image/src/org/armedbear/lisp/lognor.java branches/save-image/src/org/armedbear/lisp/lognot.java branches/save-image/src/org/armedbear/lisp/logorc1.java branches/save-image/src/org/armedbear/lisp/logorc2.java branches/save-image/src/org/armedbear/lisp/logtest.java branches/save-image/src/org/armedbear/lisp/logxor.java branches/save-image/src/org/armedbear/lisp/loop.lisp branches/save-image/src/org/armedbear/lisp/machine_type.java branches/save-image/src/org/armedbear/lisp/machine_version.java branches/save-image/src/org/armedbear/lisp/macros.lisp branches/save-image/src/org/armedbear/lisp/make-hash-table.lisp branches/save-image/src/org/armedbear/lisp/make-load-form-saving-slots.lisp branches/save-image/src/org/armedbear/lisp/make-sequence.lisp branches/save-image/src/org/armedbear/lisp/make-string-output-stream.lisp branches/save-image/src/org/armedbear/lisp/make-string.lisp branches/save-image/src/org/armedbear/lisp/make_array.java branches/save-image/src/org/armedbear/lisp/make_condition.java branches/save-image/src/org/armedbear/lisp/make_server_socket.java branches/save-image/src/org/armedbear/lisp/make_socket.java branches/save-image/src/org/armedbear/lisp/map-into.lisp branches/save-image/src/org/armedbear/lisp/map.lisp branches/save-image/src/org/armedbear/lisp/map1.lisp branches/save-image/src/org/armedbear/lisp/mask-field.lisp branches/save-image/src/org/armedbear/lisp/member-if.lisp branches/save-image/src/org/armedbear/lisp/mismatch.lisp branches/save-image/src/org/armedbear/lisp/mod.java branches/save-image/src/org/armedbear/lisp/multiple-value-bind.lisp branches/save-image/src/org/armedbear/lisp/multiple-value-list.lisp branches/save-image/src/org/armedbear/lisp/multiple-value-setq.lisp branches/save-image/src/org/armedbear/lisp/nsubstitute.lisp branches/save-image/src/org/armedbear/lisp/nth-value.lisp branches/save-image/src/org/armedbear/lisp/numbers.lisp branches/save-image/src/org/armedbear/lisp/opcodes.lisp branches/save-image/src/org/armedbear/lisp/open.lisp branches/save-image/src/org/armedbear/lisp/open_stream_p.java branches/save-image/src/org/armedbear/lisp/or.lisp branches/save-image/src/org/armedbear/lisp/output_stream_p.java branches/save-image/src/org/armedbear/lisp/package.lisp branches/save-image/src/org/armedbear/lisp/package_error_package.java branches/save-image/src/org/armedbear/lisp/parse-integer.lisp branches/save-image/src/org/armedbear/lisp/parse-lambda-list.lisp branches/save-image/src/org/armedbear/lisp/pathnames.lisp branches/save-image/src/org/armedbear/lisp/peek_char.java branches/save-image/src/org/armedbear/lisp/pprint-dispatch.lisp branches/save-image/src/org/armedbear/lisp/pprint.lisp branches/save-image/src/org/armedbear/lisp/precompiler.lisp branches/save-image/src/org/armedbear/lisp/print-object.lisp branches/save-image/src/org/armedbear/lisp/print-unreadable-object.lisp branches/save-image/src/org/armedbear/lisp/print.lisp branches/save-image/src/org/armedbear/lisp/probe_file.java branches/save-image/src/org/armedbear/lisp/proclaim.lisp branches/save-image/src/org/armedbear/lisp/profiler.lisp branches/save-image/src/org/armedbear/lisp/prog.lisp branches/save-image/src/org/armedbear/lisp/psetf.lisp branches/save-image/src/org/armedbear/lisp/query.lisp branches/save-image/src/org/armedbear/lisp/read-conditional.lisp branches/save-image/src/org/armedbear/lisp/read-from-string.lisp branches/save-image/src/org/armedbear/lisp/read-sequence.lisp branches/save-image/src/org/armedbear/lisp/reduce.lisp branches/save-image/src/org/armedbear/lisp/rem.java branches/save-image/src/org/armedbear/lisp/remf.lisp branches/save-image/src/org/armedbear/lisp/remove-duplicates.lisp branches/save-image/src/org/armedbear/lisp/remove.lisp branches/save-image/src/org/armedbear/lisp/replace.lisp branches/save-image/src/org/armedbear/lisp/require.lisp branches/save-image/src/org/armedbear/lisp/restart.lisp branches/save-image/src/org/armedbear/lisp/revappend.lisp branches/save-image/src/org/armedbear/lisp/room.java branches/save-image/src/org/armedbear/lisp/rotatef.lisp branches/save-image/src/org/armedbear/lisp/rt.lisp branches/save-image/src/org/armedbear/lisp/run-benchmarks.lisp branches/save-image/src/org/armedbear/lisp/run-shell-command.lisp branches/save-image/src/org/armedbear/lisp/runtime-class.lisp branches/save-image/src/org/armedbear/lisp/scripting/ branches/save-image/src/org/armedbear/lisp/scripting/AbclScriptEngine.java branches/save-image/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java branches/save-image/src/org/armedbear/lisp/scripting/lisp/ branches/save-image/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp branches/save-image/src/org/armedbear/lisp/scripting/lisp/config.lisp branches/save-image/src/org/armedbear/lisp/scripting/lisp/packages.lisp branches/save-image/src/org/armedbear/lisp/scripting/util/ branches/save-image/src/org/armedbear/lisp/scripting/util/ReaderInputStream.java branches/save-image/src/org/armedbear/lisp/scripting/util/WriterOutputStream.java branches/save-image/src/org/armedbear/lisp/search.lisp branches/save-image/src/org/armedbear/lisp/sequences.lisp branches/save-image/src/org/armedbear/lisp/server_socket_close.java branches/save-image/src/org/armedbear/lisp/setf.lisp branches/save-image/src/org/armedbear/lisp/sets.lisp branches/save-image/src/org/armedbear/lisp/shiftf.lisp branches/save-image/src/org/armedbear/lisp/signal.lisp branches/save-image/src/org/armedbear/lisp/simple_list_remove_duplicates.java branches/save-image/src/org/armedbear/lisp/socket.lisp branches/save-image/src/org/armedbear/lisp/socket_accept.java branches/save-image/src/org/armedbear/lisp/socket_close.java branches/save-image/src/org/armedbear/lisp/socket_stream.java branches/save-image/src/org/armedbear/lisp/software_type.java branches/save-image/src/org/armedbear/lisp/software_version.java branches/save-image/src/org/armedbear/lisp/sort.lisp branches/save-image/src/org/armedbear/lisp/source-transform.lisp branches/save-image/src/org/armedbear/lisp/step.lisp branches/save-image/src/org/armedbear/lisp/stream_element_type.java branches/save-image/src/org/armedbear/lisp/stream_external_format.java branches/save-image/src/org/armedbear/lisp/strings.lisp branches/save-image/src/org/armedbear/lisp/sublis.lisp branches/save-image/src/org/armedbear/lisp/subst.lisp branches/save-image/src/org/armedbear/lisp/substitute.lisp branches/save-image/src/org/armedbear/lisp/subtypep.lisp branches/save-image/src/org/armedbear/lisp/tailp.lisp branches/save-image/src/org/armedbear/lisp/time.lisp branches/save-image/src/org/armedbear/lisp/top-level.lisp branches/save-image/src/org/armedbear/lisp/trace.lisp branches/save-image/src/org/armedbear/lisp/tree-equal.lisp branches/save-image/src/org/armedbear/lisp/truncate.java branches/save-image/src/org/armedbear/lisp/typep.lisp branches/save-image/src/org/armedbear/lisp/unbound_slot_instance.java branches/save-image/src/org/armedbear/lisp/upgraded-complex-part-type.lisp branches/save-image/src/org/armedbear/lisp/util/ branches/save-image/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java branches/save-image/src/org/armedbear/lisp/with-accessors.lisp branches/save-image/src/org/armedbear/lisp/with-hash-table-iterator.lisp branches/save-image/src/org/armedbear/lisp/with-input-from-string.lisp branches/save-image/src/org/armedbear/lisp/with-mutex.lisp branches/save-image/src/org/armedbear/lisp/with-open-file.lisp branches/save-image/src/org/armedbear/lisp/with-output-to-string.lisp branches/save-image/src/org/armedbear/lisp/with-package-iterator.lisp branches/save-image/src/org/armedbear/lisp/with-slots.lisp branches/save-image/src/org/armedbear/lisp/with-standard-io-syntax.lisp branches/save-image/src/org/armedbear/lisp/with-thread-lock.lisp branches/save-image/src/org/armedbear/lisp/write-sequence.lisp branches/save-image/src/org/armedbear/lisp/zip.java branches/save-image/web/ branches/save-image/web/abcl.html branches/save-image/web/armedbear.css branches/save-image/web/index.html branches/save-image/web/j.html Added: branches/save-image/COPYING ============================================================================== --- (empty file) +++ branches/save-image/COPYING Fri Mar 6 00:01:48 2009 @@ -0,0 +1,351 @@ +The software in this package is distributed under the GNU General Public +License (with a special exception described below as 13th term). + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + 13. Linking this library statically or dynamically with other modules is making a combined work based on this library. Thus, the terms and conditions of the GNU General Public License cover the whole combination. + +As a special exception, the copyright holders of this software give you +permission to link this software with independent modules to produce an +executable, regardless of the license terms of these independent modules, and +to copy and distribute the resulting executable under terms of your choice, +provided that you also meet, for each linked independent module, the terms and +conditions of the license of that module. An independent module is a module +which is not derived from or based on this software. If you modify this +software, you may extend this exception to your version of the software, but +you are not obligated to do so. If you do not wish to do so, delete this +exception statement from your version. + + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice Added: branches/save-image/README ============================================================================== --- (empty file) +++ branches/save-image/README Fri Mar 6 00:01:48 2009 @@ -0,0 +1,135 @@ +GENERAL INFORMATION +=================== + +Armed Bear Common Lisp is an implementation of ANSI Common Lisp that +runs in a Java virtual machine. It compiles its code to Java byte code. + + +LICENSE +======= + +Armed Bear Common Lisp is distributed under the GNU General Public +License with classpath exception (described below). + +A copy of GNU General Public License (GPL) is included in this +distribution, in the file COPYING. + +Linking this software statically or dynamically with other modules is +making a combined work based on this software. Thus, the terms and +conditions of the GNU General Public License cover the whole +combination. + +As a special exception, the copyright holders of this software give +you permission to link this software with independent modules to +produce an executable, regardless of the license terms of these +independent modules, and to copy and distribute the resulting +executable under terms of your choice, provided that you also meet, +for each linked independent module, the terms and conditions of the +license of that module. An independent module is a module which is not +derived from or based on this software. If you modify this software, +you may extend this exception to your version of the software, but you +are not obligated to do so. If you do not wish to do so, delete this +exception statement from your version. + + +BUILDING +======== + +If you want to build ABCL, you have 3 options. The first option +applies when you come from a lisp background. The second and thirds +options are more appropriate when you come from Java development: + + I) Bootstrap ABCL using a Common Lisp implementation + Supported implementations for this process: SBCL, CMUCL, OpenMCL, + Allegro CL, LispWorks or CLISP. + +II) Use the Ant make-like build tool for Java environments + The tested lowest working version is Ant 1.7.0. + +III) Use the Netbeans 6.x IDE to open ABCL as a project. + + +In both cases you need a supported JDK version (1.5 and 1.6 have been +tested). Just the JRE isn't enough. + + + +I. Lisp-based build +------------------- + +Copy the file 'customizations.lisp.in' to customization.lisp', in the +directory containing this README file, editing to suit your situation, +paying attention to the comments in the file. + +Start up one of the supported Common Lisp implementations in the +directory containing this README file. + +Load build-abcl.lisp: + + (load "build-abcl.lisp") + +Then do: + + (build-abcl:build-abcl :clean t :full t) + +Wait for the build to finish and exit the host Lisp. + +Use abcl.bat on Windows or ./abcl on Unix to start ABCL. +Note: abcl.bat and abcl contain absolute paths, so you'll need +to edit them if you move things around after the build. + +In case of failure in the javac stage, you might try this: + + (build-abcl:build-abcl :clean t :full t :batch nil) + +This invokes javac separately for each .java file, which avoids running +into limitations on command line length (but is a lot slower). + + +II. Ant-based build +------------------- + +With Ant in your path, executing + + ant -find build.xml abcl.wrapper + +from the directory containing this README file will create an +executable wrapper ('abcl' under UNIX, 'abcl.bat' under Windows). +Use this wrapper to start the ABCL Java program. + + +III. Netbeans-based build +------------------------- + +One should be able to open the project as a project in Netbeans 6.x. + + +BUGS +==== + +A lot of (renewed) energy has been spent to make ABCL a compliant +and practically useable Common Lisp implementation. Because of this, +ABCL 0.0.11 now fails only 47 out of 21702 tests in the ANSI CL test +suite. Next to that, the fail count of the Maxima test suite has been +reduced from over 1400 in 0.0.10 to little more than 600 in 0.0.11. + +ABCL's CLOS does not handle on-the-fly redefinition of classes +correctly, and in any event is intolerably slow. There is no support +for the long form of DEFINE-METHOD-COMBINATION, and certain other +required CLOS features are also missing. Enough CLOS is there to run +ASDF and CL-PPCRE, if you're in no hurry. + +There is no MOP worth mentioning. + +Since this is a early public release, there might be build +problems as well as runtime bugs. + +Please report problems to the j-devel mailing list: + + armedbear-j-devel at lists.sourceforge.net + +Have fun! + +On behalf of all ABCL development team and contributors, +Erik Huelsmann +October 18, 2008 Added: branches/save-image/abcl.asd ============================================================================== --- (empty file) +++ branches/save-image/abcl.asd Fri Mar 6 00:01:48 2009 @@ -0,0 +1,69 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP -*- +;;; $Id: abcl.asd 11605 2009-01-30 15:40:57Z mevenson $ + +(require 'asdf) +(defpackage :abcl-asdf + (:use :cl :asdf)) +(in-package :abcl-asdf) + +;;; Wrapper for all ABCL ASDF definitions. +(defsystem :abcl :version "0.3.0") + +(defmethod perform :after ((o load-op) (c (eql (find-system 'abcl)))) + ;;; Additional test suite loads would go here. + (asdf:oos 'asdf:load-op :test-abcl :force t)) + +(defmethod perform ((o test-op) (c (eql (find-system 'abcl)))) + ;;; Additional test suite invocations would go here. + (asdf:oos 'asdf:test-op :ansi-compiled :force t)) + +;;; A collection of test suites for ABCL. +(defsystem :test-abcl + :version "0.3" + :depends-on (:ansi-compiled #+nil :abcl-tests)) + +(defmethod perform :after ((o load-op) (c (eql (find-system 'test-abcl)))) + #+nil (asdf:oos 'asdf:test-op :cl-bench :force t) + (asdf:oos 'asdf:load-op :abcl-test-lisp :force t) + (asdf:oos 'asdf:load-op :ansi-compiled :force t) + (asdf:oos 'asdf:load-op :ansi-interpreted :force t)) + +(defsystem :ansi-test :version "1.0" :components + ;;; GCL ANSI test suite. + ((:module ansi-tests :pathname "test/lisp/ansi/" :components + ((:file "package"))))) + +(defsystem :ansi-interpreted :version "1.0" :depends-on (ansi-test)) +(defmethod perform ((o test-op) (c (eql (find-system 'ansi-interpreted)))) + "Invoke tests with: (asdf:oos 'asdf:test-op :ansi-interpreted :force t)." + ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t + (funcall (intern (symbol-name 'run) :ansi.test.ansi) + :compile-tests nil)) + +(defsystem :ansi-compiled :version "1.0" :depends-on (ansi-test)) +(defmethod perform ((o test-op) (c (eql (find-system 'ansi-compiled)))) + "Invoke tests with: (asdf:oos 'asdf:test-op :abcl-compiled :force t)." + (funcall (intern (symbol-name 'run) :abcl.test.ansi) + :compile-tests t)) + +(defsystem :abcl-test-lisp :version "1.0" :components + ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components + ((:file "rt-package") (:file "rt"))) + (:module package :depends (abcl-rt) + :pathname "test/lisp/abcl/" :components + ((:file "package"))))) +(defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) + "Invoke tests with: (asdf:oos 'asdf:test-op :abcl-tests :force t)." + ;;; FIXME needs ASDF:OOS to be invoked with :FORCE t + (funcall (intern (symbol-name 'run) :abcl.test.lisp))) + +;;; Build ABCL from a Lisp. +;;; aka the "Lisp-hosted build system" +;;; Works for: abcl, sbcl, clisp, cmu, lispworks, allegro, openmcl +(defsystem :build-abcl :components + ((:module build :pathname "" :components + ((:file "build-abcl") + (:file "customizations" :depends-on ("build-abcl")))))) + + + Added: branches/save-image/abcl.bat.in ============================================================================== --- (empty file) +++ branches/save-image/abcl.bat.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1 @@ +"@JAVA@" @ABCL_JAVA_OPTIONS@ -cp "@ABCL_CLASSPATH@" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9 Added: branches/save-image/abcl.in ============================================================================== --- (empty file) +++ branches/save-image/abcl.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1,21 @@ +#!/bin/sh + +# abcl.in + +# Copyright (C) 2004 Peter Graves + +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +exec @JAVA@ @ABCL_JAVA_OPTIONS@ -Xrs -Djava.library.path=@ABCL_LIBPATH@ -cp @ABCL_CLASSPATH@ org.armedbear.lisp.Main "$@" Added: branches/save-image/build-abcl.lisp ============================================================================== --- (empty file) +++ branches/save-image/build-abcl.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,590 @@ +;;; build-abcl.lisp + +#+abcl +(require 'format) + +(defpackage build-abcl + (:use "COMMON-LISP") + (:export #:build-abcl #:make-dist) + #+abcl (:import-from #:extensions #:run-shell-command #:probe-directory) + #+allegro (:import-from #:excl #:probe-directory) + #+clisp (:import-from #:ext #:probe-directory) + ) + +(in-package #:build-abcl) + +(defun safe-namestring (pathname) + (let ((string (namestring pathname))) + (when (position #\space string) + (setf string (concatenate 'string "\"" string "\""))) + string)) + + +(defun child-pathname (pathname parent) + "Returns `pathname' relative to `parent', assuming that it +is infact a child of it while being rooted at the same root as `parent'." + (let ((path-dir (pathname-directory pathname)) + (parent-dir (pathname-directory parent))) + (do ((p1 path-dir (cdr p1)) + (p2 parent-dir (cdr p2))) + ((or (endp p2) (not (equal (car p1) (car p2)))) + (when (endp p2) + (make-pathname :directory (cons :relative p1) + :defaults pathname)))))) + + +(defun file-newer (orig artifact) + "Compares file date/time of `orig' and `artifact', returning +`NIL' if `orig' is newer than `artifact'." + (or (null (probe-file artifact)) + (> (file-write-date orig) + (file-write-date artifact)))) + + + +;; Platform detection. + +(defun platform () + #-clisp + (let ((software-type (software-type))) + (cond ((search "Linux" software-type) + :linux) + ((or (search "Mac OS X" software-type) ; abcl + (search "Darwin" software-type)) ; sbcl + :darwin) + ((search "Windows" software-type) + :windows) + (t + :unknown))) + #+clisp + (cond ((member :win32 *features*) + :windows) + ((zerop (ext:run-shell-command "uname | grep -i darwin" :output nil)) + :darwin) + ((zerop (ext:run-shell-command "uname | grep -i linux" :output nil)) + :linux) + (t + :unknown))) + +(defparameter *platform* (platform)) + +(defparameter *file-separator-char* + (if (eq *platform* :windows) #\\ #\/)) + +(defparameter *path-separator-char* + (if (eq *platform* :windows) #\; #\:)) + + +#+sbcl +(defun run-shell-command (command &key directory (output *standard-output*)) + (when directory + (setf command (concatenate 'string + "\\cd \"" + (namestring (pathname directory)) + "\" && " + command))) + (sb-ext:process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output output))) + +#+cmu +(defun run-shell-command (command &key directory (output *standard-output*)) + (when directory + (setf command (concatenate 'string + "\\cd \"" + (namestring (pathname directory)) + "\" && " + command))) + (ext::process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output output))) + +#+clisp +(defun run-shell-command (command &key directory (output *standard-output*)) + (declare (ignore output)) ;; FIXME + (let (status old-directory) + (when directory + (setf old-directory (ext:cd)) + (ext:cd directory)) + (unwind-protect + (setf status (ext:shell command)) + (when old-directory + (ext:cd old-directory))) + (cond ((numberp status) + status) + ((or (eq status t) (null status)) ;; clisp 2.47 returns NIL on success + 0) + (t + -1)))) + +#+lispworks +(defun run-shell-command (command &key directory (output *standard-output*)) + (when directory + (unless (eq *platform* :windows) + (setf command (concatenate 'string + "\\cd \"" + (namestring (pathname directory)) + "\" && " + command)))) + (system:call-system-showing-output command + :shell-type "/bin/sh" + :output-stream output)) + +#+allegro +(defun run-shell-command (command &key directory (output *standard-output*)) + (excl:run-shell-command command + :directory directory + :input nil + :output #+ide nil #-ide output)) + +#+openmcl +(defun run-shell-command (command &key directory (output *standard-output*)) + (when directory + (setf command (concatenate 'string + "\\cd \"" + (namestring (pathname directory)) + "\" && " + command))) + (multiple-value-bind (status exitcode) + (ccl:external-process-status + (ccl:run-program + "/bin/sh" + (list "-c" command) + :wait t :input nil :output output)) + (declare (ignore status)) + exitcode)) + +#+(or sbcl cmu lispworks openmcl) +(defun probe-directory (pathspec) + (let* ((truename (probe-file pathspec)) ; TRUENAME is a pathname. + (namestring (and truename (namestring truename)))) ; NAMESTRING is a string. + (and namestring + (> (length namestring) 0) + (eql (char namestring (1- (length namestring))) *file-separator-char*) + truename))) + +(defparameter *tree-root* + (make-pathname :device (pathname-device *load-truename*) + :directory (pathname-directory *load-truename*))) +(defparameter *build-root* + (merge-pathnames "build/classes/" *tree-root*)) +(defparameter *source-root* + (merge-pathnames "src/" *tree-root*)) +(defparameter *dist-root* + (merge-pathnames "dist/" *tree-root*)) + + +(defparameter *customizations-file* + (merge-pathnames "customizations.lisp" *tree-root*)) + +(defparameter *abcl-dir* + (merge-pathnames "src/org/armedbear/lisp/" *tree-root*)) + +(defparameter *jdk* nil) +(defparameter *java-compiler* nil) +(defparameter *javac-options* nil) +(defparameter *jikes-options* nil) +(defparameter *jar* nil) + +(defvar *classpath*) +(defvar *java*) +(defvar *java-compiler-options*) +(defvar *java-compiler-command-line-prefix*) + +(defun initialize-build () + (setf *jdk* nil + *java-compiler* nil + *javac-options* nil + *jikes-options* nil + *jar* nil) + (load *customizations-file*) + (setf *java* (probe-file (merge-pathnames (if (eq *platform* :windows) + "bin\\java.exe" + "bin/java") + *jdk*))) + (unless *java* + (error "Can't find Java executable.")) + (unless *java-compiler* + (setf *java-compiler* (merge-pathnames (if (eq *platform* :windows) + "bin/javac.exe" + "bin/javac") + *jdk*))) + (unless *jar* + (setf *jar* (merge-pathnames (if (eq *platform* :windows) + "bin/jar.exe" + "bin/jar") + *jdk*))) + (let ((classpath-components (list *source-root* + (if (eq *platform* :darwin) + #p"/System/Library/Frameworks/JavaVM.framework/Classes/classes.jar" + (merge-pathnames "jre/lib/rt.jar" *jdk*))))) + (setf *classpath* + (with-output-to-string (s) + (do* ((components classpath-components (cdr components)) + (component (car components) (car components))) + ((null components)) + (princ (safe-namestring component) s) + (unless (null (cdr components)) + (write-char *path-separator-char* s)))))) + (let ((prefix (concatenate 'string + (safe-namestring *java-compiler*) + " -classpath " *classpath*))) + (setf *java-compiler-options* + (if (string-equal (pathname-name (pathname *java-compiler*)) "jikes") + *jikes-options* + *javac-options*)) + (setf prefix + (if *java-compiler-options* + (concatenate 'string prefix " " *java-compiler-options* " ") + (concatenate 'string prefix " "))) + (setf *java-compiler-command-line-prefix* prefix))) + +(defun substitute-in-string (string substitutions-alist) + (dolist (entry substitutions-alist) + (loop named replace + for index = (search (car entry) string :test #'string=) + do + (unless index + (return-from replace)) + (setf string (concatenate 'string + (subseq string 0 index) + (cdr entry) + (subseq string (+ index (length (car entry)))))))) + string) + +(defun copy-with-substitutions (source-file target-file substitutions-alist) + (with-open-file (in source-file :direction :input) + (with-open-file (out target-file :direction :output :if-exists :supersede) + (loop + (let ((string (read-line in nil))) + (when (null string) + (return)) + (write-line (substitute-in-string string substitutions-alist) out)))))) + +(defun build-javac-command-line (source-file) + (concatenate 'string + *java-compiler-command-line-prefix* + " -d " + (safe-namestring *build-root*) + " " + (namestring source-file))) + +(defun java-compile-file (source-file) + (let ((cmdline (build-javac-command-line source-file))) + (zerop (run-shell-command cmdline :directory *abcl-dir*)))) + +(defun make-classes (force batch) + (let* ((source-files + (remove-if-not + #'(lambda (name) + (let ((output-name + (merge-pathnames + (make-pathname :type "class" + :defaults (child-pathname name + *source-root*)) + *build-root*))) + (or force + (file-newer name output-name)))) + (mapcan #'(lambda (default) + (directory (merge-pathnames "*.java" + default))) + (list *abcl-dir* + (merge-pathnames "util/" *abcl-dir*)))))) + (format t "~&JDK: ~A~%" *jdk*) + (format t "Java compiler: ~A~%" *java-compiler*) + (format t "Compiler options: ~A~%~%" (if *java-compiler-options* *java-compiler-options* "")) + (finish-output) + (cond ((null source-files) + (format t "Classes are up to date.~%") + (finish-output) + t) + (t + (cond (batch + (ensure-directories-exist *build-root*) + (let* ((dir (pathname-directory *abcl-dir*)) + (cmdline (with-output-to-string (s) + (princ *java-compiler-command-line-prefix* s) + (princ " -d " s) + (princ *build-root* s) + (princ #\Space s) + (dolist (source-file source-files) + (princ + (if (equal (pathname-directory source-file) dir) + (file-namestring source-file) + (namestring source-file)) + s) + (princ #\space s)))) + (status (run-shell-command cmdline :directory *abcl-dir*))) + (zerop status))) + (t + (ensure-directories-exist *build-root*) + (dolist (source-file source-files t) + (unless (java-compile-file source-file) + (format t "Build failed.~%") + (return nil))))))))) + +(defun make-jar () + (let ((*default-pathname-defaults* *tree-root*) + (jar-namestring (namestring *jar*))) + (when (position #\space jar-namestring) + (setf jar-namestring (concatenate 'string "\"" jar-namestring "\""))) + (let ((substitutions-alist (acons "@JAR@" jar-namestring nil)) + (source-file (if (eq *platform* :windows) "make-jar.bat.in" "make-jar.in")) + (target-file (if (eq *platform* :windows) "make-jar.bat" "make-jar")) + (command (if (eq *platform* :windows) "make-jar.bat" "sh make-jar"))) + (copy-with-substitutions source-file target-file substitutions-alist) + (ensure-directories-exist *dist-root*) + (let ((status (run-shell-command command :directory *tree-root*))) + (unless (zerop status) + (format t "~A returned ~S~%" command status)) + status)))) + +(defun do-compile-system (&key (zip t)) + (terpri) + (finish-output) + (let* ((java-namestring (safe-namestring *java*)) + status + (abcl-home (substitute-in-string + (namestring *abcl-dir*) + (when (eq *platform* :windows) + '(("\\" . "/") + ("/" . "\\\\"))))) + (output-path (substitute-in-string + (namestring + (merge-pathnames "build/classes/org/armedbear/lisp/" + *tree-root*)) + (when (eq *platform* :windows) + '(("\\" . "/"))))) + (cmdline (format nil + "~A -cp build/classes -Dabcl.home=\"~A\" ~ +org.armedbear.lisp.Main --noinit ~ +--eval \"(compile-system :zip ~A :quit t :output-path \\\"~A\\\")\"~%" + java-namestring + abcl-home + (not (not zip)) ;; because that ensures T or NIL + output-path))) + (ensure-directories-exist output-path) + (setf status + (run-shell-command cmdline + :directory *tree-root*)) + status)) + + +;; abcl/abcl.bat +(defun make-launch-script () + ;; Use the -Xss4M and -Xmx256M flags so that the default launch script can be + ;; used to build sbcl. + (cond ((eq *platform* :windows) + (with-open-file (s + (merge-pathnames "abcl.bat" *tree-root*) + :direction :output + :if-exists :supersede) + (format s "~A -Xss4M -Xmx256M -cp \"~A\" org.armedbear.lisp.Main %1 %2 %3 %4 %5 %6 %7 %8 %9~%" + (safe-namestring *java*) + (namestring (merge-pathnames "dist\\abcl.jar" *tree-root*))))) + (t + (let ((pathname (merge-pathnames "abcl" *tree-root*))) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (format s "#!/bin/sh~%exec ~A -Xss4M -Xmx256M -cp ~A org.armedbear.lisp.Main \"$@\"~%" + (safe-namestring *java*) + (safe-namestring (merge-pathnames "abcl.jar" *dist-root*)))) + (run-shell-command (format nil "chmod +x ~A" (safe-namestring pathname)) + :directory *tree-root*))))) + +(defun build-stamp () + (multiple-value-bind + (second minute hour date month year day daylight-p zone) + (decode-universal-time (get-universal-time)) + (declare (ignore daylight-p)) + (setf day (nth day '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))) + (setf month (nth (1- month) '("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))) + (setf zone (* zone 100)) ;; FIXME + (format nil "~A ~A ~D ~D ~2,'0D:~2,'0D:~2,'0D -~4,'0D" + day month date year hour minute second zone))) + +(defun make-build-stamp () + (with-open-file (s + (merge-pathnames (make-pathname :name "build" + :defaults *abcl-dir*)) + :direction :output + :if-exists :supersede) + (format s "~A" (build-stamp)))) + +(defun delete-files (pathnames) + (dolist (pathname pathnames) + (let ((truename (probe-file pathname))) + (when truename + (delete-file truename))))) + +(defun clean () + (dolist (f (list (list *tree-root* "abcl.jar" "abcl.bat" "make-jar.bat" + "compile-system.bat") + ;; as of 0.14 'compile-system.bat' isn't created anymore + ;; as of 0.14 'abcl.jar' is always created in dist/ + (list *abcl-dir* "*.class" "*.abcl" "*.cls" + "native.h" "libabcl.so" "build") + ;; as of 0.14, native.h and libabcl.so have been removed + (list (merge-pathnames "util/" *abcl-dir*) "*.class") + (list (merge-pathnames "build/classes/org/armedbear/lisp/" + *tree-root*) + "*.class" "*.abcl" "*.cls" + "native.h" "libabcl.so" "build") + (list (merge-pathnames + "build/classes/org/armedbear/lisp/util/" + *tree-root*) + "*.class" "*.abcl" "*.cls") + (list *dist-root* "*.jar" "*.class" "*.abcl" "*.cls") + (list (merge-pathnames "java/awt/" *abcl-dir*) + "*.class"))) + (let ((default (car f))) + (when (probe-directory default) + (delete-files (mapcan #'(lambda (name) + (directory (merge-pathnames name default))) + (cdr f))))))) + +(defun build-abcl (&key force + (batch t) + compile-system + jar + clean + full) + (let ((start (get-internal-real-time))) + + #+lispworks + (when (eq *platform* :windows) + (setf batch nil)) + + (initialize-build) + (format t "~&Platform: ~A~%" + (case *platform* + (:windows "Windows") + (:linux "Linux") + (:darwin "Mac OS X") + (t (software-type)))) + (finish-output) + ;; clean + (when clean + (clean)) + ;; classes + (unless (make-classes force batch) + (format t "Build failed.~%") + (return-from build-abcl nil)) + ;; COMPILE-SYSTEM + (when (or full compile-system) + (let* ((zip (if (or full jar) nil t)) + (status (do-compile-system :zip zip))) + (unless (zerop status) + (format t "Build failed.~%") + (return-from build-abcl nil)))) + ;; abcl.jar + (when (or full jar) + (let ((status (make-jar))) + (unless (zerop status) + (format t "Build failed.~%") + (return-from build-abcl nil)))) + ;; abcl/abcl.bat + (make-launch-script) + (make-build-stamp) + (let ((end (get-internal-real-time))) + (format t "Build completed successfully in ~A seconds.~%" + (/ (float (- end start)) internal-time-units-per-second))) + t)) + +(defun build-abcl-executable () + (let* ((*default-pathname-defaults* *abcl-dir*) + (source-files (directory "*.java")) + (cmdline (with-output-to-string (s) + (princ "gcj -g -O0 " s) + (dolist (source-file source-files) + (unless (string= (pathname-name source-file) "Native") + (princ (pathname-name source-file) s) + (princ ".java" s) + (princ #\space s))) + (princ "--main=org.armedbear.lisp.Main -o lisp" s))) + (result (run-shell-command cmdline :directory *abcl-dir*))) + (zerop result))) + +(defvar *copy-verbose* nil) + +(defun copy-file (source target) + (when *copy-verbose* + (format t "~A -> ~A~%" source target)) + (let ((buffer (make-array 4096 :element-type '(unsigned-byte 8)))) + (with-open-file (in source :direction :input :element-type '(unsigned-byte 8)) + (with-open-file (out target :direction :output :element-type '(unsigned-byte 8) + :if-exists :supersede) + (loop + (let ((end (read-sequence buffer in))) + (when (zerop end) + (return)) + (write-sequence buffer out :end end))))))) + +(defun copy-files (files source-dir target-dir) + (ensure-directories-exist target-dir) + (dolist (file files) + (copy-file (merge-pathnames file source-dir) + (merge-pathnames file target-dir)))) + +(defun make-dist-dir (version-string) + (unless (eq *platform* :linux) + (error "MAKE-DIST is only supported on Linux.")) + (let ((target-root (pathname (concatenate 'string "/var/tmp/" version-string "/")))) + (when (probe-directory target-root) + (error "Target directory ~S already exists." target-root)) + (let* ((source-dir *tree-root*) + (target-dir target-root) + (files (list "README" + "COPYING" + "build-abcl.lisp" + "customizations.lisp" + "make-jar.bat.in" + "make-jar.in"))) + (copy-files files source-dir target-dir)) + (let* ((source-dir (merge-pathnames "examples/" *tree-root*)) + (target-dir (merge-pathnames "examples/" target-root)) + (files '("hello.java"))) + (copy-files files source-dir target-dir)) + (let* ((target-dir (merge-pathnames "src/" target-root)) + (files '("manifest-abcl"))) + (copy-files files *source-root* target-dir)) + (let* ((source-dir *abcl-dir*) + (target-dir (merge-pathnames "src/org/armedbear/lisp/" target-root)) + (*default-pathname-defaults* source-dir) + (files (mapcar #'file-namestring (append (directory "*.java") + (directory "*.lisp") + (list "LICENSE" "native.c"))))) + (copy-files files source-dir target-dir)) + (let* ((source-dir (merge-pathnames "tests/" *abcl-dir*)) + (target-dir (merge-pathnames "src/org/armedbear/lisp/tests/" target-root)) + (*default-pathname-defaults* source-dir) + (files (append (mapcar #'file-namestring (directory "*.lisp")) + (list "jl-config.cl")))) + (copy-files files source-dir target-dir)) + (let* ((source-dir (merge-pathnames "java/awt/" *abcl-dir*)) + (target-dir (merge-pathnames "src/org/armedbear/lisp/java/awt/" target-root)) + (*default-pathname-defaults* source-dir) + (files (mapcar #'file-namestring (directory "*.java")))) + (copy-files files source-dir target-dir)) + target-root)) + +(defun make-dist (version-string) + (let* ((dist-dir (make-dist-dir version-string)) + (parent-dir (merge-pathnames (make-pathname :directory '(:relative :back)) + dist-dir))) + (let* ((command (format nil "tar czf ~A~A.tar.gz ~A" + (namestring parent-dir) + version-string version-string)) + (status (run-shell-command command :directory parent-dir))) + (unless (zerop status) + (format t "~A returned ~S~%" command status))) + (let* ((command (format nil "zip -q -r ~A~A.zip ~A" + (namestring parent-dir) + version-string version-string)) + (status (run-shell-command command :directory parent-dir))) + (unless (zerop status) + (format t "~A returned ~S~%" command status))))) Added: branches/save-image/build.properties.in ============================================================================== --- (empty file) +++ branches/save-image/build.properties.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1,2 @@ +# build.properties +# $Id: build.properties,v 1.23 2007-03-03 19:19:11 piso Exp $ Added: branches/save-image/build.xml ============================================================================== --- (empty file) +++ branches/save-image/build.xml Fri Mar 6 00:01:48 2009 @@ -0,0 +1,550 @@ + + + Compiling, testing, and packaging Armed Bear Common Lisp + + + + + + + + + + + + + + Main Ant targets: + abcl.compile + -- compile ABCL to ${build.classes.dir}. + abcl.jar + -- create packaged ${abcl.jar.path}. + abcl.wrapper + -- create executable wrapper for ABCL. + abcl.source.zip abcl.source.tar + -- create source distributions in ${dist.dir}. + acbl.test.java + -- Run junit tests under ${abcl.test.src.dir}. + abcl.clean + -- remove ABCL intermediate files + Corresponding targets for J have been removed. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Compiled ABCL with Java version: ${java.version} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + java.version: ${java.version} + + + + + + + + + + Implementation-Source: ${version.src} + + + + + WARNING: Use of Java version ${java.version} not recommended. + + + + + Notice: JSR-223 support won't be built since it is not + supported, neither natively by your JVM nor by + libraries in the CLASSPATH. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Built ABCL version: ${abcl.version} + + + + + + + abcl.hostname: ${abcl.hostname} + + + + + + + + + + + + + + + + + +
+ + + + +
+ + + + + + + + + Creates in-place exectuable shell wrapper in '${abcl.wrapper.file}' + + + + + + + + + + + + + + + + + + + + + Created executable ABCL wrapper in '${abcl.wrapper.file}' + N.B. This wrapper requires '${abcl.jar.path}' not be moved. + + + + + + + + + + + + + + Invoke ABCL with JPDA listener on port 6789 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Using abcl.source.eol='${abcl.source.eol}' to drive + source code line-ending transformations. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Recording test output in ${abcl.test.log.file}. + + + + + + + + Finished recording test output in ${abcl.test.log.file}. + + + + Recording test output in ${abcl.test.log.file}. + + + + + + + + Finished recording test output in ${abcl.test.log.file}. + + + + Recording test output in ${abcl.test.log.file}. + + + + + + + + Finished recording test output in ${abcl.test.log.file}. + + + + + + + Added: branches/save-image/customizations.lisp.in ============================================================================== --- (empty file) +++ branches/save-image/customizations.lisp.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1,38 @@ +;;; Copy this file to "customizations.lisp" + +;;; User customizations for the build. + +;;; This file is LOADed by INITIALIZE-BUILD (in build-abcl.lisp). + +;;; The variable *PLATFORM-IS-WINDOWS* should be true on Windows platforms. You +;;; can, of course, substitute your own test for this in the code below, or add +;;; a section for OS X, or Solaris, or whatever... + +;;; You MUST set *JDK* to the location of the JDK you want to use. Remove or +;;; comment out settings that don't apply to your situation. + +;;; You don't really need to specify anything but *JDK*. *JAVA-COMPILER* and +;;; *JAR* default to javac and jar, respectively, from the configured JDK. + +;;; Directories should be specified with a trailing slash (or, on Windows, a +;;; trailing backslash). + +(in-package "BUILD-ABCL") + +;; Standard compiler options. +(setq *javac-options* "-g") +(setq *jikes-options* "+D -g") + +;; *PLATFORM* will be either :WINDOWS, :DARWIN, :LINUX, or :UNKNOWN. +(case *platform* + (:windows + (setq *jdk* "C:\\Program Files\\Java\\jdk1.5.0_16\\") + #+nil (setq *java-compiler* "jikes") + ) + (:darwin + (setq *jdk* "/usr/") + #+nil (setq *java-compiler* "jikes") + #+nil (setq *jar* "jar")) + ((:linux :unknown) + (setq *jdk* "/home/peter/sun/jdk1.5.0_16/") + (setq *jar* "fastjar"))) Added: branches/save-image/dist/abcl.jar ============================================================================== Binary file. No diff available. Added: branches/save-image/examples/.abclrc ============================================================================== --- (empty file) +++ branches/save-image/examples/.abclrc Fri Mar 6 00:01:48 2009 @@ -0,0 +1,77 @@ +;;; -*- Mode: Lisp -*- + +;;; See also: +;;; .clinit.cl (Allegro) +;;; .cmucl-init.lisp (CMUCL) +;;; .sbclrc (SBCL) +;;; .clisprc.lisp (CLISP) +;;; .lispworks (LispWorks) + +(defparameter *ansi-tests-directory* + #-(or windows mswindows win32) + #p"/home/peter/xcl/x/ansi-tests/" + #+(or windows mswindows win32) + #p"c:\\msys\\1.0\\home\\peter\\xcl\\x\ansi-tests\\") + +(defun run-ansi-tests (&optional (compile-tests t)) + (format t "COMPILE-TESTS is ~A~%" compile-tests) + (let ((*default-pathname-defaults* *ansi-tests-directory*)) + #+(and abcl unix) + (run-shell-command "make clean" :directory *default-pathname-defaults*) + (time (load (if compile-tests "compileit.lsp" "doit.lsp"))))) + +(defun run-random-tests (size nvars count) + (let ((*default-pathname-defaults* *ansi-tests-directory*)) + (load "gclload1.lsp") + (load "random-int-form.lsp") + (let ((f (find-symbol "TEST-RANDOM-INTEGER-FORMS" "CL-TEST"))) + (when f + (let (#+abcl (*suppress-compiler-warnings* t) + (*random-state* (make-random-state t))) + (time (funcall f size nvars count))))))) + +#+(or abcl sbcl clisp) +(defun test-cl-ppcre () + #+abcl (require "JVM") + (let ((*default-pathname-defaults* #-(or windows mswindows win32) + #p"/home/peter/cl-ppcre-1.2.19/" + #+(or windows mswindows win32) + #p"c:\\cygwin\\home\\peter\\cl-ppcre-1.2.19\\")) + #+abcl + (map nil #'delete-file (directory "*.abcl")) + #+sbcl + (map nil #'delete-file (directory "*.fasl")) + (load "load.lisp") + (let ((f (find-symbol "TEST" "CL-PPCRE-TEST"))) + (when f + #+abcl (gc) + (time (funcall f)) + #+abcl (gc) + (time (funcall f)))))) + +#+abcl +(defun run-other-tests () + (test-cl-ppcre) + (let ((*default-pathname-defaults* "/home/peter/salza-0.7.2/")) + (map nil #'delete-file (directory "*.abcl")) + (load "/home/peter/test-salza.lisp") + (gc) + (test-salza) + (gc) + (test-salza))) + +#+abcl +(autoload 'do-tests "rt.lisp") + +#+allegro +(top-level:alias "ap" (arg) (apropos arg nil nil t)) +#+allegro +(top-level:alias "de" (arg) (describe (eval arg))) + +#+cmu +(setf *gc-verbose* nil) + +;; #+sbcl +;; (require '#:asdf) +;; #+sbcl +;; (require '#:sb-aclrepl) Added: branches/save-image/examples/abcl/README ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/README Fri Mar 6 00:01:48 2009 @@ -0,0 +1,33 @@ +ABCL Examples Building and Running Instructions +=============================================== + +code by Ville Voutilainen +instructions by Blake McBride +updated by Mark Evenson + +In general, to compile a Java class file (like Main.java for example +in the 'java_exception_in_lisp' subdirectory) use: + + cmd$ cd java_exception_in_lisp + cmd$ javac -cp ../../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + +where "Main" is the initial class to run in your Java program. Added: branches/save-image/examples/abcl/interface_implementation_in_lisp/Main.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/interface_implementation_in_lisp/Main.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,70 @@ +/* + * Main.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: Main.java 11384 2008-11-08 09:27:29Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +import org.armedbear.lisp.*; + +public class Main +{ + /** + * This example loads a lisp file and gets two function symbols + * from it. The functions return implementations of MyInterface. + * The example gets two separate implementations and invokes + * the functions in the interface for both implementations. + */ + public static void main(String[] argv) + { + try + { + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"interface_implementation.lisp\")"); + // the function is not in a separate package, thus the + // correct package is CL-USER. Symbol names are + // upper case. Package needs the prefix, because java + // also has a class named Package. + org.armedbear.lisp.Package defaultPackage = + Packages.findPackage("CL-USER"); + Symbol interfacesym = + defaultPackage.findAccessibleSymbol("GET-INTERFACE"); + Function interfaceFunction = + (Function) interfacesym.getSymbolFunction(); + LispObject myinterface = interfaceFunction.execute(); + MyInterface x = + (MyInterface) JavaObject.getObject(myinterface); + x.firstFunction(); + x.secondFunction(); + Symbol interfacesym2 = + defaultPackage. + findAccessibleSymbol("GET-ANOTHER-INTERFACE"); + Function interfaceFunction2 = + (Function) interfacesym2.getSymbolFunction(); + LispObject myInterface2 = interfaceFunction2.execute(); + MyInterface y = + (MyInterface) JavaObject.getObject(myInterface2); + y.firstFunction(); + y.secondFunction(); + } + catch (Throwable t) + { + System.out.println("abcl exception!"); + t.printStackTrace(); + } + } +} \ No newline at end of file Added: branches/save-image/examples/abcl/interface_implementation_in_lisp/MyInterface.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/interface_implementation_in_lisp/MyInterface.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,29 @@ +/* + * MyInterface.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: MyInterface.java 11384 2008-11-08 09:27:29Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +/** + * Example interface, with two methods. + */ +public interface MyInterface +{ + public void firstFunction(); + public void secondFunction(); +} \ No newline at end of file Added: branches/save-image/examples/abcl/interface_implementation_in_lisp/interface_implementation.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/interface_implementation_in_lisp/interface_implementation.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,79 @@ +;;; interface_implementation.lisp +;;; +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: interface_implementation.lisp 11384 2008-11-08 09:27:29Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +; first we define a class hierarchy. No slots defined, +; we don't need them in the example. +(defclass base ()) + +(defclass derived1 (base)) + +(defclass derived2 (base)) + +; then a couple of generic methods +(defgeneric invoke (param) (:documentation "Sample generic function")) + +(defgeneric invoke2 (param) (:documentation "Sample generic function")) + +; and their methods, for different classes +(defmethod invoke ((param derived1)) + (format t "in derived1 invoke~%")) + +(defmethod invoke ((param derived2)) + (format t "in derived2 invoke~%")) + +(defmethod invoke2 ((param derived1)) + (format t "in derived1 invoke2~%")) + +(defmethod invoke2 ((param derived2)) + (format t "in derived2 invoke2~%")) + +; closure for interface implementation, closes +; over a provided object and calls the invoke +; method with the object. Thus the firstFunction() +; in MyInterface will call the invoke method. +(defun make-first-function (object) + (lambda () (invoke object))) + +; closure for interface implementation, closes +; over a provided object and invokes the invoke2 +; method with the object. Thus the secondFunction() +; in MyInterface will call the invoke2 method. +(defun make-second-function (object) + (lambda () (invoke2 object))) + +; gets an interface implementation, uses an instance of +; class derived1 +(defun get-interface () + (let ((firstobject (make-instance 'derived1))) + (jinterface-implementation "MyInterface" + "firstFunction" + (make-first-function firstobject) + "secondFunction" + (make-second-function firstobject)))) + +; gets an interface implementation, uses an instance of +; class derived2 +(defun get-another-interface () + (let ((secondobject (make-instance 'derived2))) + (jinterface-implementation "MyInterface" + "firstFunction" + (make-first-function secondobject) + "secondFunction" + (make-second-function secondobject)))) + Added: branches/save-image/examples/abcl/java_exception_in_lisp/Main.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/java_exception_in_lisp/Main.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,63 @@ +/* + * Main.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: Main.java 11385 2008-11-08 19:06:53Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +import org.armedbear.lisp.*; + +public class Main +{ + /** + * This example creates an Interpreter instance, loads our + * lisp code from a file and then looks up a function defined + * in the loaded lisp file and executes the function. + * + * The function takes a single parameter and invokes a java method + * on the object provided. We provide our Main object as the parameter. + * + */ + public static void main(String[] argv) + { + try + { + Main thisObject = new Main(); + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"lispfunctions.lisp\")"); + // the function is not in a separate package, thus the + // correct package is CL-USER. Symbol names are + // upper case. Package needs the prefix, because java + // also has a class named Package. + org.armedbear.lisp.Package defaultPackage = + Packages.findPackage("CL-USER"); + Symbol voidsym = + defaultPackage.findAccessibleSymbol("VOID-FUNCTION"); + Function voidFunction = (Function) voidsym.getSymbolFunction(); + voidFunction.execute(new JavaObject(thisObject)); + } + catch (Throwable t) + { + System.out.println("abcl exception!"); + t.printStackTrace(); + } + } + public int addTwoNumbers(int a, int b) + { + throw new RuntimeException("Exception from java code"); + } +} \ No newline at end of file Added: branches/save-image/examples/abcl/java_exception_in_lisp/lispfunctions.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/java_exception_in_lisp/lispfunctions.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,38 @@ +;;; lispfunctions.lisp +;;; +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: lispfunctions.lisp 11385 2008-11-08 19:06:53Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +; we need to get the +; 1) class (Main) +; 2) classes of the parameters (int) +; 3) method reference (getting that requires the class +; of our object and the classes of the parameters + +; After that we can invoke the function with jcall, +; giving the method reference, the object and the parameters. +; The function throws an exception, so we wrap the call in +; handler-case. +(defun void-function (param) + (let* ((class (jclass "Main")) + (intclass (jclass "int")) + (method (jmethod class "addTwoNumbers" intclass intclass))) + (handler-case + (jcall method param 2 4) + (java-exception (exception) + (format t "Caught a java exception in void-function~%"))))) + Added: branches/save-image/examples/abcl/javacall_from_lisp/Main.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/javacall_from_lisp/Main.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,63 @@ +/* + * Main.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: Main.java 11384 2008-11-08 09:27:29Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +import org.armedbear.lisp.*; + +public class Main +{ + /** + * This example creates an Interpreter instance, loads our + * lisp code from a file and then looks up a function defined + * in the loaded lisp file and executes the function. + * + * The function takes a single parameter and invokes a java method + * on the object provided. We provide our Main object as the parameter. + * + */ + public static void main(String[] argv) + { + try + { + Main thisObject = new Main(); + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"lispfunctions.lisp\")"); + // the function is not in a separate package, thus the + // correct package is CL-USER. Symbol names are + // upper case. Package needs the prefix, because java + // also has a class named Package. + org.armedbear.lisp.Package defaultPackage = + Packages.findPackage("CL-USER"); + Symbol voidsym = + defaultPackage.findAccessibleSymbol("VOID-FUNCTION"); + Function voidFunction = (Function) voidsym.getSymbolFunction(); + voidFunction.execute(new JavaObject(thisObject)); + } + catch (Throwable t) + { + System.out.println("abcl exception!"); + t.printStackTrace(); + } + } + public int addTwoNumbers(int a, int b) + { + return a + b; + } +} \ No newline at end of file Added: branches/save-image/examples/abcl/javacall_from_lisp/lispfunctions.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/javacall_from_lisp/lispfunctions.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,37 @@ +;;; lispfunctions.lisp +;;; +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: lispfunctions.lisp 11384 2008-11-08 09:27:29Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +; we need to get the +; 1) class (Main) +; 2) classes of the parameters (int) +; 3) method reference (getting that requires the class +; of our object and the classes of the parameters + +; After that we can invoke the function with jcall, +; giving the method reference, the object and the parameters. +; The result is a lisp object (no need to do jobject-lisp-value), +; unless we invoke the method +; with jcall-raw. +(defun void-function (param) + (let* ((class (jclass "Main")) + (intclass (jclass "int")) + (method (jmethod class "addTwoNumbers" intclass intclass)) + (result (jcall method param 2 4))) + (format t "in void-function, result of calling addTwoNumbers(2, 4): ~a~%" result))) + Added: branches/save-image/examples/abcl/jsr-223/JSR223Example.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/jsr-223/JSR223Example.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,58 @@ +import javax.script.*; + +public class JSR223Example { + + public static void main(String[] args) { + //Script Engine instantiation + ScriptEngine lispEngine = new ScriptEngineManager().getEngineByExtension("lisp"); + + //Accessing variables + System.out.println(); + System.out.println("*package* = " + lispEngine.get("*package*")); + Object someValue = new Object(); + lispEngine.put("someVariable", someValue); + System.out.println("someVariable = " + lispEngine.get("someVariable")); + try { + //Interpretation (also from streams) + lispEngine.eval("(defun hello (arg) (print (list arg someVariable)) (terpri))"); + + //Direct function invocation + ((Invocable) lispEngine).invokeFunction("hello", "world"); + + //Implementing a Java interface in Lisp + lispEngine.eval("(defun compare-to (&rest args) 42)"); + Comparable c = ((Invocable) lispEngine).getInterface(java.lang.Comparable.class); + System.out.println("compareTo: " + c.compareTo(null)); + + //Compilation! + lispEngine.eval("(defmacro slow-compiling-macro (arg) (dotimes (i 1000000) (incf i)) `(print ,arg))"); + + long millis = System.currentTimeMillis(); + lispEngine.eval("(slow-compiling-macro 42)"); + millis = System.currentTimeMillis() - millis; + System.out.println("interpretation took " + millis); + + millis = System.currentTimeMillis(); + CompiledScript cs = ((Compilable) lispEngine).compile("(slow-compiling-macro 42)"); + millis = System.currentTimeMillis() - millis; + System.out.println("compilation took " + millis); + + millis = System.currentTimeMillis(); + cs.eval(); + millis = System.currentTimeMillis() - millis; + System.out.println("evaluation took " + millis); + + millis = System.currentTimeMillis(); + cs.eval(); + millis = System.currentTimeMillis() - millis; + System.out.println("evaluation took " + millis); + + //Ecc. ecc. + } catch (NoSuchMethodException e) { + e.printStackTrace(); + } catch (ScriptException e) { + e.printStackTrace(); + } + } + +} Added: branches/save-image/examples/abcl/lispcall_from_java_simple/Main.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/lispcall_from_java_simple/Main.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,45 @@ +/* + * Main.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: Main.java 11384 2008-11-08 09:27:29Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +import org.armedbear.lisp.*; + +public class Main +{ + /** + * This example creates an Interpreter instance, loads our + * lisp code from a file and then evaluates a function defined + * in the loaded lisp file. + */ + public static void main(String[] argv) + { + try + { + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"lispfunction.lisp\")"); + LispObject myInterface = interpreter.eval("(lispfunction)"); + } + catch (Throwable t) + { + System.out.println("abcl exception!"); + t.printStackTrace(); + } + } +} \ No newline at end of file Added: branches/save-image/examples/abcl/lispcall_from_java_simple/MainAlternative.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/lispcall_from_java_simple/MainAlternative.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,54 @@ +/* + * MainAlternative.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: MainAlternative.java 11384 2008-11-08 09:27:29Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +import org.armedbear.lisp.*; + +public class MainAlternative +{ + /** + * This example creates an Interpreter instance, loads our + * lisp code from a file and then looks up a function defined + * in the loaded lisp file and executes the function. + */ + public static void main(String[] argv) + { + try + { + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"lispfunction.lisp\")"); + // the function is not in a separate package, thus the + // correct package is CL-USER. Symbol names are + // upper case. Package needs the prefix, because java + // also has a class named Package. + org.armedbear.lisp.Package defaultPackage = + Packages.findPackage("CL-USER"); + Symbol sym = + defaultPackage.findAccessibleSymbol("LISPFUNCTION"); + Function function = (Function) sym.getSymbolFunction(); + function.execute(); + } + catch (Throwable t) + { + System.out.println("abcl exception!"); + t.printStackTrace(); + } + } +} \ No newline at end of file Added: branches/save-image/examples/abcl/lispcall_from_java_simple/lispfunction.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/lispcall_from_java_simple/lispfunction.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,21 @@ +;;; lispfunction.lisp +;;; +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: lispfunction.lisp 11384 2008-11-08 09:27:29Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(defun lispfunction () + (format t "in lispfunction~%")) Added: branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/Main.java ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/Main.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,72 @@ +/* + * Main.java + * + * Copyright (C) 2008 Ville Voutilainen + * $Id: Main.java 11384 2008-11-08 09:27:29Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +import org.armedbear.lisp.*; + +public class Main +{ + /** + * This example creates an Interpreter instance, loads our + * lisp code from a file and then looks up two functions defined + * in the loaded lisp file and executes the functions. + * + * The first function takes a single parameter and prints its value, + * so we can provide any Object, so we use a String. + * + * The second function takes two numbers, adds them together, prints + * the parameters and the result, and returns the result. + * We use two integers as parameters and just print the result + * from java side. + */ + public static void main(String[] argv) + { + try + { + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(load \"lispfunctions.lisp\")"); + // the function is not in a separate package, thus the + // correct package is CL-USER. Symbol names are + // upper case. Package needs the prefix, because java + // also has a class named Package. + org.armedbear.lisp.Package defaultPackage = + Packages.findPackage("CL-USER"); + + Symbol voidsym = + defaultPackage.findAccessibleSymbol("VOID-FUNCTION"); + Function voidFunction = (Function) voidsym.getSymbolFunction(); + voidFunction.execute(new JavaObject("String given from java")); + + Symbol intsym = + defaultPackage.findAccessibleSymbol("INT-FUNCTION"); + Function intFunction = (Function) intsym.getSymbolFunction(); + LispObject result = + intFunction.execute(new JavaObject(1), + new JavaObject(6)); + System.out.print("The result on the java side: "); + System.out.println(result.intValue()); + } + catch (Throwable t) + { + System.out.println("abcl exception!"); + t.printStackTrace(); + } + } +} \ No newline at end of file Added: branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/lispfunctions.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/abcl/lispcall_from_java_with_params_and_return/lispfunctions.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,33 @@ +;;; lispfunctions.lisp +;;; +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: lispfunctions.lisp 11384 2008-11-08 09:27:29Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +; param comes from java, so accessing it require +; calling jobject-lisp-value on it +(defun void-function (param) + (format t "in void-function, param: ~a~%" (jobject-lisp-value param))) + +; params come from java, so accessing them require +; calling jobject-lisp-value on them +(defun int-function (jparam1 jparam2) + (let* ((param1 (jobject-lisp-value jparam1)) + (param2 (jobject-lisp-value jparam2)) + (result (+ param1 param2))) + (format t "in int-function, params: ~a ~a~%result: ~a~%" + param1 param2 result) + result)) \ No newline at end of file Added: branches/save-image/examples/complete.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/complete.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,88 @@ +;;; complete.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: complete.lisp,v 1.2 2004-09-05 00:12:25 piso Exp $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(in-package "J") + +(export 'complete) + +(defvar *prefix* nil) +(defvar *completions* ()) +(defvar *completion-index* 0) + +(defun compound-prefix-match (prefix target) + (let ((tlen (length target)) + (tpos 0)) + (dotimes (i (length prefix)) + (when (>= tpos tlen) + (return-from compound-prefix-match nil)) + (let ((ch (schar prefix i))) + (if (char= ch #\-) + (unless (setf tpos (position #\- target :start tpos)) + (return-from compound-prefix-match nil)) + (unless (char-equal ch (schar target tpos)) + (return-from compound-prefix-match nil))) + (incf tpos))) + t)) + +(defun completion-set (prefix) + (let ((result ())) + (do-external-symbols (symbol "CL") + (let ((name (symbol-name symbol))) + (when (compound-prefix-match prefix name) + (push symbol result)))) + result)) + +(defun completion-prefix () + (let* ((string (line-chars (current-line))) + (end (mark-charpos (current-point)))) + (do ((start (1- end) (1- start))) + ((< start 0) (subseq string 0 end)) + (let ((ch (schar string start))) + (when (or (eql ch #\space) (eql ch #\()) + (incf start) + (return-from completion-prefix (subseq string start end))))))) + +(defun complete () + (cond ((eq *last-command* 'complete) + (unless (> (length *completions*) 1) + (return-from complete)) + (undo) + (incf *completion-index*) + (when (> *completion-index* (1- (length *completions*))) + (setf *completion-index* 0))) + (t + (setf *prefix* (completion-prefix) + *completions* nil + *completion-index* 0) + (when *prefix* + (setf *completions* (completion-set *prefix*))))) + (when *completions* + (let ((completion (string-downcase (nth *completion-index* *completions*))) + (point (current-point))) + (with-single-undo + (goto-char (make-mark (mark-line point) + (- (mark-charpos point) (length *prefix*)))) + (set-mark point) + (delete-region) + (insert completion))) + (setf *current-command* 'complete)) + (values)) + +(map-key-for-mode "Ctrl Space" "(complete)" "Lisp") +(map-key-for-mode "Ctrl Space" "(complete)" "Lisp Shell") Added: branches/save-image/examples/hello.java ============================================================================== --- (empty file) +++ branches/save-image/examples/hello.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,23 @@ +import org.armedbear.lisp.*; + +public class hello +{ + public static void main(String[] args) + { + try + { + Interpreter interpreter = Interpreter.createInstance(); + interpreter.eval("(format t \"Hello, world!~%\")"); + } + catch (Throwable t) + { + t.printStackTrace(); + } + } +} + +// cd ~/j/examples +// cp hello.java ../src +// cd ../src +// javac hello.java +// java hello Added: branches/save-image/examples/init.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/init.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,112 @@ +;;; init.lisp +;;; $Id: init.lisp,v 1.36 2007-03-04 19:08:11 piso Exp $ + +;;; ~/.j/init.lisp (if it exists) is loaded automatically when j starts up. + +(defun java-version () + (jstatic "getProperty" "java.lang.System" "java.version")) + +(defun adjust-appearance () + (when (member (subseq (java-version) 0 5) + '("1.4.0" "1.4.1" "1.4.2" "1.5.0" "1.6.0" "1.7.0") + :test #'string=) + (set-global-property "adjustAscent" -2) + (set-global-property "adjustLeading" -2) + (reset-display))) + +;; Do it now! +(adjust-appearance) + +;; Turn off the remove-trailing-whitespace preference for files in the +;; directory ~/gcl/ansi-tests. +(defun my-open-file-hook (buf) + (let ((pathname (buffer-pathname buf))) + (when (and pathname + (string= (directory-namestring pathname) + "/home/peter/gcl/ansi-tests/")) + (set-buffer-property "removeTrailingWhitespace" nil)))) + +(add-hook 'open-file-hook 'my-open-file-hook) + +;; Helper function for MY-BUFFER-ACTIVATED-HOOK. +(defun sub-p (namestring dirname) + "Returns T if NAMESTRING is in DIRNAME or one of its subdirectories" + (let ((dirname-length (length dirname))) + (and (> (length namestring) dirname-length) + (string= (subseq namestring 0 dirname-length) dirname)))) + +(defun my-buffer-activated-hook (buf) + (let ((pathname (buffer-pathname buf))) + ;; PATHNAME might be NIL (not all buffers have associated files). + (when pathname + (let ((type (pathname-type pathname))) + ;; We only care about Lisp and Java buffers. + (cond ((string= type "el") + (set-buffer-property + "tagPath" + "/home/peter/emacs-21.3/lisp:/home/peter/emacs-21.3/lisp/emacs-lisp")) + ((member type '("lisp" "lsp" "cl" "java") :test 'string=) + (let* ((namestring (namestring pathname)) + (tagpath + (cond ((sub-p namestring "/home/peter/cmucl/src/") + "/home/peter/cmucl/src/code:/home/peter/cmucl/src/compiler:/home/peter/cmucl/src/pcl") + ((sub-p namestring "/home/peter/cl-bench/") + "/home/peter/cl-bench:/home/peter/cl-bench/files:/home/peter/depot/j/src/org/armedbear/lisp") + ((sub-p namestring "/home/peter/gcl/ansi-tests/") + "/home/peter/gcl/ansi-tests:/home/peter/depot/j/src/org/armedbear/lisp") + ((sub-p namestring "/home/peter/phemlock") + "/home/peter/phemlock/src/core:/home/peter/phemlock/src/user") + ((sub-p namestring "/home/peter/sbcl") + "/home/peter/sbcl/src/code:/home/peter/sbcl/src/compiler") + (t ; default case: no change + nil)))) + ;; If we end up here with a non-NIL TAGPATH, use it to set the + ;; buffer-specific value of the TAG-PATH preference for the current + ;; buffer. + (when tagpath + (set-buffer-property "tagPath" tagpath))))))))) + +;; Install our hook function. +(add-hook 'buffer-activated-hook 'my-buffer-activated-hook) + +;; Call ADJUST-APPEARANCE after saving ~/.j/prefs. +(defun my-after-save-hook (buf) + (let ((pathname (buffer-pathname buf))) + (when (equal pathname #p"/home/peter/.j/prefs") + (adjust-appearance)))) + +(add-hook 'after-save-hook 'my-after-save-hook) + +(defun reset-incoming-filters () + (jstatic "resetIncomingFilters" "org.armedbear.j.mail.IncomingFilter")) + +(defun add-incoming-filter (mailbox pattern action parameter) + (jstatic "addIncomingFilter" "org.armedbear.j.mail.IncomingFilter" + mailbox pattern action parameter)) + +(add-hook 'mailbox-mode-hook + (lambda () + (reset-incoming-filters) + (add-incoming-filter "inbox" + "~C linux-kernel" + "move" + "mail/linux-kernel") + (add-incoming-filter "inbox" + "~C ix.netcom.com" + "move" + "mail/netcom"))) + +(defun maybe-load (pathname) + (when (probe-file pathname) + (load pathname))) + +(maybe-load "/home/peter/.j/key-pressed.lisp") +(maybe-load "/home/peter/.j/update-check-enabled.lisp") + +(maybe-load #+windows "c:/cygwin/home/peter/j/build-abcl.lisp" + #-windows "/home/peter/j/build-abcl.lisp") + +(map-key-for-mode ")" "electricCloseParen" "Lisp Shell") + +(map-key-for-mode "[" "insertParentheses" "Lisp") +(map-key-for-mode "]" "movePastCloseAndReindent" "Lisp") Added: branches/save-image/examples/key-pressed.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/key-pressed.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,169 @@ +;;; key-pressed.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: key-pressed.lisp,v 1.8 2005-11-18 01:47:25 piso Exp $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(unless (find-package "KEY-PRESSED") + (make-package "KEY-PRESSED" :nicknames '("KP") :use '("CL" "J"))) + +(in-package "KEY-PRESSED") + +;; No exports. + +(defcommand open-file) +(defcommand open-file-in-other-window) +(defcommand open-file-in-other-frame) +;; (defcommand new-buffer) +(defcommand recent-files) +(defcommand save) +(defcommand save-as) +(defcommand save-copy) +(defcommand save-all) +(defcommand kill-buffer) +(defcommand properties) +(defcommand next-buffer) +(defcommand prev-buffer) +(defcommand new-frame) +;; (defcommand execute-command "executeCommand") +;; (defcommand j-print "print") +(defcommand save-all-exit) +(defcommand quit) +(defcommand jump-to-line) +(defcommand jump-to-column) +(defcommand j-find "find") +(defcommand incremental-find) +(defcommand list-occurrences) +(defcommand find-in-files) +(defcommand list-files) +(defcommand sidebar-list-tags) +(defcommand j-replace "replace") +(defcommand replace-in-files) +(defcommand dir) +(defcommand goto-bookmark) +(defcommand help) +(defcommand describe-key) +(defcommand next-frame) +(defcommand select-word) +(defcommand kill-frame) +(defcommand toggle-sidebar) +(defcommand sidebar-list-buffers) +(defcommand split-window) +(defcommand unsplit-window) +(defcommand other-window) +(defcommand shell) + +;;; Incremental find needs special handling. +(defun invoke-incremental-find () + (location-bar-cancel-input) + (restore-focus) + (invoke-later 'incremental-find)) + +(defvar *table* (make-hash-table :test #'equalp)) + +;;; Object can be a symbol or a function. +(defun assign-key (key object) + (setf (gethash key *table*) object)) + +;;; The hook function. +(defun key-pressed (&rest args) + (let* ((key (car args)) + (value (gethash key *table*))) + (when (and value + (or (functionp value) + (and (symbolp value) (fboundp value)))) + (funcall value)))) + +;;; Key assignments. +(assign-key "Ctrl O" + #'(lambda () + (location-bar-cancel-input) + (update-location-bar) + (open-file))) +(assign-key "Ctrl Alt O" + #'(lambda () (open-file-in-other-window) (update-location-bar))) +(assign-key "Ctrl Shift O" 'open-file-in-other-frame) +;; Ctrl N is used for history in textfields. +;; (assign-key "Ctrl N" 'new-buffer) +(assign-key "Alt R" 'recent-files) +(assign-key "Ctrl S" 'save) +(assign-key "Ctrl Shift S" 'save-as) +(assign-key "Ctrl Alt S" 'save-copy) +(assign-key "F2" 'save-all) +(assign-key "Ctrl F4" 'kill-buffer) +(assign-key "Ctrl W" 'kill-buffer) +(assign-key "Alt P" 'properties) +(assign-key "Alt NumPad Right" + #'(lambda () (restore-focus) (next-buffer))) +(assign-key "Alt Right" + #'(lambda () (restore-focus) (next-buffer))) +(assign-key "Alt NumPad Left" + #'(lambda () (restore-focus) (prev-buffer))) +(assign-key "Alt Left" + #'(lambda () (restore-focus) (prev-buffer))) +(assign-key "Ctrl Shift N" 'new-frame) +(assign-key "Alt X" 'execute-command) +;; Ctrl P is used for history in textfields. +;; (assign-key "Ctrl P" 'j-print) +(assign-key "Ctrl Shift Q" 'save-all-exit) +(assign-key "Ctrl Q" 'quit) +(assign-key "Ctrl J" 'jump-to-line) +(assign-key "Ctrl Shift J" 'jump-to-column) +(assign-key "Alt F3" + #'(lambda () (location-bar-cancel-input) (restore-focus) (j-find))) +(assign-key "Ctrl F" 'invoke-incremental-find) +(assign-key "Alt L" 'list-occurrences) +(assign-key "F6" 'find-in-files) +(assign-key "Ctrl Shift F" 'find-in-files) +(assign-key "Ctrl L" 'list-files) +(assign-key "Ctrl Shift L" 'sidebar-list-tags) +(assign-key "Ctrl R" 'j-replace) +(assign-key "Ctrl Shift R" 'replace-in-files) +(assign-key "Ctrl D" 'dir) +(assign-key "Ctrl 0" 'goto-bookmark) +(assign-key "Ctrl 1" 'goto-bookmark) +(assign-key "Ctrl 2" 'goto-bookmark) +(assign-key "Ctrl 3" 'goto-bookmark) +(assign-key "Ctrl 4" 'goto-bookmark) +(assign-key "Ctrl 5" 'goto-bookmark) +(assign-key "Ctrl 6" 'goto-bookmark) +(assign-key "Ctrl 7" 'goto-bookmark) +(assign-key "Ctrl 8" 'goto-bookmark) +(assign-key "Ctrl 9" 'goto-bookmark) +(assign-key "F1" 'help) +(assign-key "Alt K" 'describe-key) +(assign-key "Alt N" 'next-frame) +(assign-key "Alt W" 'select-word) +(assign-key "Ctrl Shift W" 'kill-frame) +(assign-key "Alt =" 'toggle-sidebar) +(assign-key "Alt B" 'sidebar-list-buffers) +(assign-key "F10" 'split-window) +(assign-key "Shift F10" 'unsplit-window) +(assign-key "Alt O" 'other-window) +(assign-key "Alt F9" + #'(lambda () (restore-focus) (shell))) + +;;; Enable the hook. +(add-hook 'key-pressed-hook 'key-pressed) +(set-global-property "enableKeyPressedHook" t) + +;; NOTE: ENABLE-KEY-PRESSED-HOOK will be reset to its default value (NIL) when +;; preferences are reloaded (which happens automatically when you edit your +;; preferences file). To prevent this (and keep the key-pressed hook working +;; properly across preference file edits), add this line to ~/.j/prefs: +;; +;; enableKeyPressedHook = true +;; Added: branches/save-image/examples/update-check-enabled.lisp ============================================================================== --- (empty file) +++ branches/save-image/examples/update-check-enabled.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,40 @@ +;;; update-check-enabled.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: update-check-enabled.lisp,v 1.2 2006-03-03 14:26:59 piso Exp $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(in-package "CL-USER") + +;; In minutes. +(defparameter check-enabled-timeout 5) + +;; Don't resolve autoloads in the background thread! +(sys::resolve 'get-internal-real-time) + +(defun update-check-enabled () + (loop + (sleep 60) ; 1 minute + (let* ((last-event-time (get-last-event-internal-time)) + (current-time (get-internal-real-time)) + (timeout (* check-enabled-timeout 60 internal-time-units-per-second)) + (enable (if (> current-time (+ last-event-time timeout)) nil t))) + (unless (eq (get-global-property 'check-enabled) enable) + (set-global-property 'check-enabled enable) + (log-debug "check-enabled => ~A" (get-global-property 'check-enabled)))))) + +;; Fire it up. +(make-thread #'update-check-enabled) Added: branches/save-image/install-sh ============================================================================== --- (empty file) +++ branches/save-image/install-sh Fri Mar 6 00:01:48 2009 @@ -0,0 +1,251 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5 (mit/util/scripts/install.sh). +# +# Copyright 1991 by the Massachusetts Institute of Technology +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. It can only install one file at a time, a restriction +# shared with many OS's install programs. + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + chmodcmd="" + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 Added: branches/save-image/make-jar.bat.in ============================================================================== --- (empty file) +++ branches/save-image/make-jar.bat.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1,3 @@ + at JAR@ cfm dist\abcl.jar src\manifest-abcl -C src org\armedbear\lisp\LICENSE -C src org\armedbear\lisp\boot.lisp + at JAR@ uf dist\abcl.jar -C build\classes . + Added: branches/save-image/make-jar.in ============================================================================== --- (empty file) +++ branches/save-image/make-jar.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1,5 @@ +#!/bin/sh + + at JAR@ cfm dist/abcl.jar src/manifest-abcl -C src org/armedbear/lisp/LICENSE -C src org/armedbear/lisp/boot.lisp + at JAR@ uf dist/abcl.jar -C build/classes . + Added: branches/save-image/mkinstalldirs ============================================================================== --- (empty file) +++ branches/save-image/mkinstalldirs Fri Mar 6 00:01:48 2009 @@ -0,0 +1,40 @@ +#! /bin/sh +# mkinstalldirs --- make directory hierarchy +# Author: Noah Friedman +# Created: 1993-05-16 +# Public domain + +# $Id: mkinstalldirs,v 1.1.1.1 2002-09-24 16:06:34 piso Exp $ + +errstatus=0 + +for file +do + set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` + shift + + pathcomp= + for d + do + pathcomp="$pathcomp$d" + case "$pathcomp" in + -* ) pathcomp=./$pathcomp ;; + esac + + if test ! -d "$pathcomp"; then + echo "mkdir $pathcomp" + + mkdir "$pathcomp" || lasterr=$? + + if test ! -d "$pathcomp"; then + errstatus=$lasterr + fi + fi + + pathcomp="$pathcomp/" + done +done + +exit $errstatus + +# mkinstalldirs ends here Added: branches/save-image/nbproject/build-impl.xml ============================================================================== --- (empty file) +++ branches/save-image/nbproject/build-impl.xml Fri Mar 6 00:01:48 2009 @@ -0,0 +1,642 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must set src.dir + Must set test.src.dir + Must set build.dir + Must set dist.dir + Must set build.classes.dir + Must set dist.javadoc.dir + Must set build.test.classes.dir + Must set build.test.results.dir + Must set build.classes.excludes + Must set dist.jar + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must set javac.includes + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must select some files in the IDE or set javac.includes + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + To run this application from the command line without Ant, try: + + + + + + + java -cp "${run.classpath.with.dist.jar}" ${main.class} + + + + + + + + + + + + + + + + + + + + + + + To run this application from the command line without Ant, try: + + java -jar "${dist.jar.resolved}" + + + + + + + + + + + + + + + + + + + Must select one file in the IDE or set run.class + + + + + + + + + + + + + + + + + + + + Must select one file in the IDE or set debug.class + + + + + Must set fix.includes + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must select some files in the IDE or set javac.includes + + + + + + + + + + + + + + + + + + + + Some tests failed; see details above. + + + + + + + + + Must select some files in the IDE or set test.includes + + + + Some tests failed; see details above. + + + + + Must select one file in the IDE or set test.class + + + + + + + + + + + + + + + + + + + + + + + + + + + Must select one file in the IDE or set applet.url + + + + + + + + + Must select one file in the IDE or set applet.url + + + + + + + + + + + + + + + + + + + Added: branches/save-image/nbproject/configs/J.properties ============================================================================== --- (empty file) +++ branches/save-image/nbproject/configs/J.properties Fri Mar 6 00:01:48 2009 @@ -0,0 +1 @@ +main.class=Main Added: branches/save-image/nbproject/genfiles.properties ============================================================================== --- (empty file) +++ branches/save-image/nbproject/genfiles.properties Fri Mar 6 00:01:48 2009 @@ -0,0 +1,11 @@ +build.xml.data.CRC32=71623fcd +build.xml.script.CRC32=33676845 +build.xml.stylesheet.CRC32=be360661 +# 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=b94c76f8 +nbproject/build-impl.xml.stylesheet.CRC32=e55b27f5 +nbproject/profiler-build-impl.xml.data.CRC32=71623fcd +nbproject/profiler-build-impl.xml.script.CRC32=abda56ed +nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf Added: branches/save-image/nbproject/project.properties ============================================================================== --- (empty file) +++ branches/save-image/nbproject/project.properties Fri Mar 6 00:01:48 2009 @@ -0,0 +1,69 @@ +application.title=abcl +application.vendor= +build.classes.dir=${build.dir}/classes +build.classes.excludes=**/*.java,**/*.form +# This directory is removed when the project is cleaned: +build.dir=build +build.generated.dir=${build.dir}/generated +# Only compile against the classpath explicitly listed here: +build.sysclasspath=ignore +build.test.classes.dir=${build.dir}/test/classes +build.test.results.dir=${build.dir}/test/results +debug.classpath=\ + ${run.classpath} +debug.test.classpath=\ + ${run.test.classpath} +# This directory is removed when the project is cleaned: +dist.dir=dist +dist.jar=${dist.dir}/abcl.jar +dist.javadoc.dir=${dist.dir}/javadoc +excludes= +file.reference.abcl-src=src +includes=org/armedbear/lisp/**/*.java,org/armedbear/lisp/**/*.lisp +jar.compress=true +javac.classpath= +# Space-separated list of extra javac options +javac.compilerargs= +javac.deprecation=false +javac.source=1.5 +javac.target=1.5 +javac.test.classpath=\ + ${javac.classpath}:\ + ${build.classes.dir}:\ + ${libs.junit.classpath}:\ + ${libs.junit_4.classpath} +javadoc.additionalparam= +javadoc.author=false +javadoc.encoding=${source.encoding} +javadoc.noindex=false +javadoc.nonavbar=false +javadoc.notree=false +javadoc.private=false +javadoc.splitindex=true +javadoc.use=true +javadoc.version=false +javadoc.windowtitle= +jnlp.codebase.type=local +jnlp.codebase.url=file:/Users/evenson/work/abcl/dist/ +jnlp.enabled=false +jnlp.offline-allowed=false +jnlp.signed=false +main.class=org.armedbear.lisp.Main +manifest.file=manifest.mf +meta.inf.dir=${src.dir}/META-INF +platform.active=default_platform +run.classpath=\ + ${javac.classpath}:\ + ${build.classes.dir} +# Space-separated list of JVM arguments used when running the project +# (you may also define separate properties like run-sys-prop.name=value instead of -Dname=value +# or test-sys-prop.name=value to set system properties for unit tests): +run.jvmargs= +run.test.classpath=\ + ${javac.test.classpath}:\ + ${build.test.classes.dir} +source.encoding=UTF-8 +src.dir=${file.reference.abcl-src} +src.doc.dir=doc +src.themes.dir=themes +test.src.dir=test/src Added: branches/save-image/nbproject/project.xml ============================================================================== --- (empty file) +++ branches/save-image/nbproject/project.xml Fri Mar 6 00:01:48 2009 @@ -0,0 +1,16 @@ + + + org.netbeans.modules.java.j2seproject + + + abcl + 1.6.5 + + + + + + + + + Added: branches/save-image/netbeans-build.xml ============================================================================== --- (empty file) +++ branches/save-image/netbeans-build.xml Fri Mar 6 00:01:48 2009 @@ -0,0 +1,26 @@ + + + + + + + + build.classes.dir: ${build.classes.dir} + + + + + + + + + + + + + + Added: branches/save-image/src/META-INF/services/javax.script.ScriptEngineFactory ============================================================================== --- (empty file) +++ branches/save-image/src/META-INF/services/javax.script.ScriptEngineFactory Fri Mar 6 00:01:48 2009 @@ -0,0 +1 @@ +org.armedbear.lisp.scripting.AbclScriptEngineFactory \ No newline at end of file Added: branches/save-image/src/manifest-abcl ============================================================================== --- (empty file) +++ branches/save-image/src/manifest-abcl Fri Mar 6 00:01:48 2009 @@ -0,0 +1 @@ +Main-Class: org.armedbear.lisp.Main Added: branches/save-image/src/org/armedbear/lisp/AbstractArray.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/AbstractArray.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,340 @@ +/* + * AbstractArray.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: AbstractArray.java 11575 2009-01-22 20:00:49Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class AbstractArray extends LispObject +{ + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.ARRAY) + return T; + if (type == BuiltInClass.ARRAY) + return T; + return super.typep(type); + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (obj instanceof AbstractArray) { + AbstractArray a = (AbstractArray) obj; + if (getRank() != a.getRank()) + return false; + for (int i = getRank(); i-- > 0;) { + if (getDimension(i) != a.getDimension(i)) + return false; + } + for (int i = getTotalSize(); i--> 0;) { + if (!AREF(i).equalp(a.AREF(i))) + return false; + } + return true; + } + return false; + } + + public boolean isDisplaced() + { + return false; + } + + public LispObject arrayDisplacement() throws ConditionThrowable + { + return LispThread.currentThread().setValues(NIL, Fixnum.ZERO); + } + + public boolean hasFillPointer() + { + return false; + } + + public int getFillPointer() throws ConditionThrowable + { + noFillPointer(); + return -1; // Not reached. + } + + public void setFillPointer(LispObject fillPointer) throws ConditionThrowable + { + setFillPointer(fillPointer.intValue()); + } + + public void setFillPointer(int fillPointer) throws ConditionThrowable + { + noFillPointer(); + } + + public boolean isAdjustable() + { + return true; + } + + public abstract int getRank(); + + public abstract LispObject getDimensions(); + + public abstract int getDimension(int n) throws ConditionThrowable; + + public abstract LispObject getElementType(); + + public abstract int getTotalSize(); + + @Override + public abstract void aset(int index, LispObject newValue) + throws ConditionThrowable; + + // FIXME Detect overflow! + protected static final int computeTotalSize(int[] dimensions) + { + int size = 1; + for (int i = dimensions.length; i-- > 0;) + size *= dimensions[i]; + return size; + } + + public int getRowMajorIndex(LispObject[] subscripts) + throws ConditionThrowable + { + int[] subs = new int[subscripts.length]; + for (int i = 0; i < subscripts.length; i++) { + LispObject subscript = subscripts[i]; + if (subscript instanceof Fixnum) + subs[i] = ((Fixnum)subscript).value; + else + type_error(subscript, Symbol.FIXNUM); + } + return getRowMajorIndex(subs); + } + + public int getRowMajorIndex(int[] subscripts) throws ConditionThrowable + { + final int rank = getRank(); + if (rank != subscripts.length) { + // ### i18n + final String errorMsg = + "Wrong number of subscripts (%d) for array of rank %d."; + error(new ProgramError(String.format(errorMsg, subscripts.length, rank))); + } + int sum = 0; + int size = 1; + for (int i = rank; i-- > 0;) { + final int dim = getDimension(i); + final int lastSize = size; + size *= dim; + final int n = subscripts[i]; + if (n < 0 || n >= dim) { + // ### i18n + final String errorMsg = + "Invalid index %d for array %s."; + error(new ProgramError(String.format(errorMsg, n, writeToString()))); + } + sum += n * lastSize; + } + return sum; + } + + public LispObject get(int[] subscripts) throws ConditionThrowable + { + return AREF(getRowMajorIndex(subscripts)); + } + + public void set(int[] subscripts, LispObject newValue) + throws ConditionThrowable + { + aset(getRowMajorIndex(subscripts), newValue); + } + + public abstract void fill(LispObject obj) throws ConditionThrowable; + + public String writeToString(int[] dimv) throws ConditionThrowable + { + StringBuilder sb = new StringBuilder(); + LispThread thread = LispThread.currentThread(); + LispObject printReadably = Symbol.PRINT_READABLY.symbolValue(thread); + if (printReadably != NIL || Symbol.PRINT_ARRAY.symbolValue(thread) != NIL) { + int maxLevel = Integer.MAX_VALUE; + if (printReadably != NIL) { + for (int i = 0; i < dimv.length - 1; i++) { + if (dimv[i] == 0) { + for (int j = i + 1; j < dimv.length; j++) { + if (dimv[j] != 0) { + error(new PrintNotReadable(list2(Keyword.OBJECT, + this))); + return null; // Not reached. + } + } + } + } + } else { + LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + } + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = Fixnum.getValue(currentPrintLevel); + if (currentLevel >= maxLevel) + return "#"; + sb.append('#'); + sb.append(dimv.length); + sb.append('A'); + appendContents(dimv, 0, sb, thread); + return sb.toString(); + } + sb.append('('); + if (this instanceof SimpleArray_T) + sb.append("SIMPLE-"); + sb.append("ARRAY " + getElementType().writeToString() + " ("); + for (int i = 0; i < dimv.length; i++) { + sb.append(dimv[i]); + if (i < dimv.length - 1) + sb.append(' '); + } + sb.append("))"); + return unreadableString(sb.toString()); + } + + // Helper for writeToString(). + private void appendContents(int[] dimensions, int index, StringBuilder sb, + LispThread thread) + throws ConditionThrowable + { + if (dimensions.length == 0) { + if (Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL) { + StringOutputStream stream = new StringOutputStream(); + thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(), + AREF(index), stream); + sb.append(stream.getString().getStringValue()); + } else + sb.append(AREF(index).writeToString()); + } else { + final LispObject printReadably = + Symbol.PRINT_READABLY.symbolValue(thread); + int maxLength = Integer.MAX_VALUE; + int maxLevel = Integer.MAX_VALUE; + if (printReadably == NIL) { + final LispObject printLength = + Symbol.PRINT_LENGTH.symbolValue(thread); + if (printLength instanceof Fixnum) + maxLength = ((Fixnum)printLength).value; + final LispObject printLevel = + Symbol.PRINT_LEVEL.symbolValue(thread); + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + } + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = Fixnum.getValue(currentPrintLevel); + if (currentLevel < maxLevel) { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(_CURRENT_PRINT_LEVEL_, currentPrintLevel.incr()); + try { + sb.append('('); + int[] dims = new int[dimensions.length - 1]; + for (int i = 1; i < dimensions.length; i++) + dims[i-1] = dimensions[i]; + int count = 1; + for (int i = 0; i < dims.length; i++) + count *= dims[i]; + final int length = dimensions[0]; + final int limit = Math.min(length, maxLength); + for (int i = 0; i < limit; i++) { + appendContents(dims, index, sb, thread); + if (i < limit - 1 || limit < length) + sb.append(' '); + index += count; + } + if (limit < length) + sb.append("..."); + sb.append(')'); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } else + sb.append('#'); + } + } + + // For EQUALP hash tables. + @Override + public int psxhash() + { + try { + long result = 128387; // Chosen at random. + final int rank = getRank(); + int limit = rank < 4 ? rank : 4; + for (int i = 0; i < limit; i++) + result = mix(result, getDimension(i)); + final int length = getTotalSize(); + limit = length < 4 ? length : 4; + for (int i = 0; i < length; i++) + result = mix(result, AREF(i).psxhash()); + return (int) (result & 0x7fffffff); + } + catch (Throwable t) { + // Shouldn't happen. + Debug.trace(t); + return 0; + } + } + + /** Returns a newly allocated array or the current array with + * adjusted dimensions. + * + * @param dims + * @param initialElement @c null if none + * @param initialContents @c null if none + * @return @c this or a new array + * @throws org.armedbear.lisp.ConditionThrowable + */ + public abstract AbstractArray adjustArray(int[] dims, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable; + + /** + * + * @param dims + * @param displacedTo + * @param displacement + * @return + * @throws org.armedbear.lisp.ConditionThrowable + */ + public abstract AbstractArray adjustArray(int[] dims, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable; +} Added: branches/save-image/src/org/armedbear/lisp/AbstractBitVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/AbstractBitVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,232 @@ +/* + * AbstractBitVector.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: AbstractBitVector.java 11575 2009-01-22 20:00:49Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class AbstractBitVector extends AbstractVector +{ + protected static final int LONG_MASK = 0x3f; + + protected int capacity; + + // For non-displaced bit-vectors. + protected long[] bits; + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.BIT_VECTOR) + return T; + if (type == BuiltInClass.BIT_VECTOR) + return T; + return super.typep(type); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.BIT_VECTOR; + } + + @Override + public final int capacity() + { + return capacity; + } + + @Override + public final LispObject getElementType() + { + return Symbol.BIT; + } + + @Override + public boolean equal(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof AbstractBitVector) { + AbstractBitVector v = (AbstractBitVector) obj; + if (length() != v.length()) + return false; + for (int i = length(); i-- > 0;) { + if (getBit(i) != v.getBit(i)) + return false; + } + return true; + } + return false; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof AbstractBitVector) { + AbstractBitVector v = (AbstractBitVector) obj; + if (length() != v.length()) + return false; + for (int i = length(); i-- > 0;) { + if (getBit(i) != v.getBit(i)) + return false; + } + return true; + } + if (obj instanceof AbstractString) + return false; + if (obj instanceof AbstractVector) + return ((AbstractVector)obj).equalp(this); + return false; + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + try { + switch (((Fixnum)obj).value) { + case 0: + if (bits != null) { + for (int i = bits.length; i-- > 0;) + bits[i] = 0; + } else { + for (int i = capacity; i-- > 0;) + clearBit(i); + } + return; + case 1: + if (bits != null) { + for (int i = bits.length; i-- > 0;) + bits[i] = -1L; + } else { + for (int i = capacity; i-- > 0;) + setBit(i); + } + return; + } + } + catch (ClassCastException e) { + // Fall through... + } + error(new TypeError(obj, Symbol.BIT)); + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + SimpleBitVector v = new SimpleBitVector(end - start); + int i = start, j = 0; + try { + while (i < end) { + if (getBit(i++) == 0) + v.clearBit(j++); + else + v.setBit(j++); + } + return v; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public int hashCode() + { + int hashCode = 1; + try { + // Consider first 64 bits only. + final int limit = Math.min(length(), 64); + for (int i = 0; i < limit; i++) + hashCode = hashCode * 31 + getBit(i); + } + catch (ConditionThrowable t) { + // Shouldn't happen. + Debug.trace(t); + } + return hashCode; + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final int length = length(); + if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL || + Symbol.PRINT_ARRAY.symbolValue(thread) != NIL) + { + StringBuilder sb = new StringBuilder(length + 2); + sb.append("#*"); + for (int i = 0; i < length; i++) + sb.append(getBit(i) == 1 ? '1' : '0'); + return sb.toString(); + } else { + final String str = "(%sBIT-VECTOR %d)"; + final String pre = (this instanceof SimpleBitVector) ? "SIMPLE-" : ""; + return unreadableString(String.format(str, pre, length)); + } + } + + // Ignores fill pointer. + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try { + return AREF(((Fixnum)index).value); + } + catch (ClassCastException e) { + return error(new TypeError(index, Symbol.FIXNUM)); + } + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + int length = length(); + SimpleBitVector result = new SimpleBitVector(length); + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) { + if (getBit(j) == 1) + result.setBit(i); + else + result.clearBit(i); + } + return result; + } + + protected abstract int getBit(int index) throws ConditionThrowable; + + protected abstract void setBit(int index) throws ConditionThrowable; + + protected abstract void clearBit(int index) throws ConditionThrowable; +} Added: branches/save-image/src/org/armedbear/lisp/AbstractString.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/AbstractString.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,121 @@ +/* + * AbstractString.java + * + * Copyright (C) 2004 Peter Graves + * $Id: AbstractString.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class AbstractString extends AbstractVector +{ + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type instanceof Symbol) { + if (type == Symbol.STRING) + return T; + if (type == Symbol.BASE_STRING) + return T; + } + if (type == BuiltInClass.STRING) + return T; + if (type == BuiltInClass.BASE_STRING) + return T; + return super.typep(type); + } + + @Override + public final LispObject STRINGP() + { + return T; + } + + @Override + public final boolean stringp() + { + return true; + } + + @Override + public LispObject getElementType() + { + return Symbol.CHARACTER; + } + + @Override + public final boolean isSimpleVector() + { + return false; + } + + @Override + public final LispObject STRING() + { + return this; + } + + public abstract void fill(char c) throws ConditionThrowable; + + public abstract char charAt(int index) throws ConditionThrowable; + + public abstract void setCharAt(int index, char c) throws ConditionThrowable; + + public final String writeToString(int beginIndex, int endIndex) + throws ConditionThrowable + { + if (beginIndex < 0) + beginIndex = 0; + final int limit; + limit = length(); + if (endIndex > limit) + endIndex = limit; + final LispThread thread = LispThread.currentThread(); + if (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL || + Symbol.PRINT_READABLY.symbolValue(thread) != NIL) + { + FastStringBuffer sb = new FastStringBuffer('"'); + for (int i = beginIndex; i < endIndex; i++) { + char c = charAt(i); + if (c == '\"' || c == '\\') + sb.append('\\'); + sb.append(c); + } + sb.append('"'); + return sb.toString(); + } else + return getStringValue().substring(beginIndex, endIndex); + } + + @Override + public String writeToString() throws ConditionThrowable + { + return writeToString(0, length()); + } +} Added: branches/save-image/src/org/armedbear/lisp/AbstractVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/AbstractVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,323 @@ +/* + * AbstractVector.java + * + * Copyright (C) 2003-2006 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class AbstractVector extends AbstractArray +{ + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.VECTOR) + return T; + if (type == BuiltInClass.VECTOR) + return T; + if (type == Symbol.SEQUENCE) + return T; + if (type == BuiltInClass.SEQUENCE) + return T; + return super.typep(type); + } + + @Override + public final LispObject VECTORP() + { + return T; + } + + @Override + public final boolean vectorp() + { + return true; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (obj instanceof AbstractVector) + { + if (length() != obj.length()) + return false; + AbstractVector v = (AbstractVector) obj; + for (int i = length(); i-- > 0;) + if (!AREF(i).equalp(v.AREF(i))) + return false; + return true; + } + return false; + } + + @Override + public final int getRank() + { + return 1; + } + + @Override + public final LispObject getDimensions() + { + return new Cons(new Fixnum(capacity())); + } + + @Override + public final int getDimension(int n) throws ConditionThrowable + { + if (n != 0) + { + error(new TypeError("bad dimension for vector")); + // Not reached. + return 0; + } + return capacity(); + } + + @Override + public final int getTotalSize() + { + return capacity(); + } + + public abstract int capacity(); + + public abstract LispObject subseq(int start, int end) throws ConditionThrowable; + + public LispObject deleteEq(LispObject item) throws ConditionThrowable + { + final int limit = length(); + int i = 0; + int j = 0; + while (i < limit) + { + LispObject obj = AREF(i++); + if (obj != item) + aset(j++, obj); + } + final int newLength = j; + if (newLength < capacity()) + shrink(newLength); + return this; + } + + public LispObject deleteEql(LispObject item) throws ConditionThrowable + { + final int limit = length(); + int i = 0; + int j = 0; + while (i < limit) + { + LispObject obj = AREF(i++); + if (!obj.eql(item)) + aset(j++, obj); + } + final int newLength = j; + if (newLength < capacity()) + shrink(newLength); + return this; + } + + public abstract void shrink(int n) throws ConditionThrowable; + + public int checkIndex(int index) throws ConditionThrowable + { + if (index < 0 || index >= capacity()) + badIndex(index, capacity()); + return index; + } + + protected void badIndex(int index, int limit) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("Invalid array index "); + sb.append(index); + sb.append(" for "); + sb.append(writeToString()); + if (limit > 0) + { + sb.append(" (should be >= 0 and < "); + sb.append(limit); + sb.append(")."); + } + error(new TypeError(sb.toString(), + new Fixnum(index), + list3(Symbol.INTEGER, + Fixnum.ZERO, + new Fixnum(limit - 1)))); + + } + + public void setFillPointer(int n) throws ConditionThrowable + { + noFillPointer(); + } + + public void setFillPointer(LispObject obj) throws ConditionThrowable + { + noFillPointer(); + } + + public boolean isSimpleVector() + { + return false; + } + + @Override + public abstract LispObject reverse() throws ConditionThrowable; + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = length() - 1; + while (i < j) + { + LispObject temp = AREF(i); + aset(i, AREF(j)); + aset(j, temp); + ++i; + --j; + } + return this; + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL) + { + FastStringBuffer sb = new FastStringBuffer("#("); + final int limit = length(); + for (int i = 0; i < limit; i++) + { + if (i > 0) + sb.append(' '); + sb.append(AREF(i).writeToString()); + } + sb.append(')'); + return sb.toString(); + } + else if (Symbol.PRINT_ARRAY.symbolValue(thread) != NIL) + { + int maxLevel = Integer.MAX_VALUE; + final LispObject printLevel = + Symbol.PRINT_LEVEL.symbolValue(thread); + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = Fixnum.getValue(currentPrintLevel); + if (currentLevel < maxLevel) + { + StringBuffer sb = new StringBuffer("#("); + int maxLength = Integer.MAX_VALUE; + final LispObject printLength = + Symbol.PRINT_LENGTH.symbolValue(thread); + if (printLength instanceof Fixnum) + maxLength = ((Fixnum)printLength).value; + final int length = length(); + final int limit = Math.min(length, maxLength); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(_CURRENT_PRINT_LEVEL_, currentPrintLevel.incr()); + try + { + for (int i = 0; i < limit; i++) + { + if (i > 0) + sb.append(' '); + sb.append(AREF(i).writeToString()); + } + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + if (limit < length) + sb.append(limit > 0 ? " ..." : "..."); + sb.append(')'); + return sb.toString(); + } + else + return "#"; + } + else + { + StringBuffer sb = new StringBuffer(); + sb.append(isSimpleVector() ? "SIMPLE-VECTOR " : "VECTOR "); + sb.append(capacity()); + return unreadableString(sb.toString()); + } + } + + // For EQUALP hash tables. + @Override + public int psxhash() + { + try + { + final int length = length(); + final int limit = length < 4 ? length : 4; + long result = 48920713; // Chosen at random. + for (int i = 0; i < limit; i++) + result = mix(result, AREF(i).psxhash()); + return (int) (result & 0x7fffffff); + } + catch (Throwable t) + { + // Shouldn't happen. + Debug.trace(t); + return 0; + } + } + + public abstract AbstractArray adjustArray(int size, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable; + public abstract AbstractArray adjustArray(int size, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable; + + + public AbstractArray adjustArray(int[] dims, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable { + return adjustArray(dims[0], initialElement, initialContents); + } + + public AbstractArray adjustArray(int[] dims, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable { + return adjustArray(dims[0], displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/ArithmeticError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ArithmeticError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,153 @@ +/* + * ArithmeticError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ArithmeticError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class ArithmeticError extends LispError +{ + protected ArithmeticError(LispClass cls) throws ConditionThrowable + { + super(cls); + } + + public ArithmeticError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.ARITHMETIC_ERROR); + initialize(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + LispObject operation = NIL; + LispObject operands = NIL; + LispObject first, second; + while (initArgs != NIL) { + first = initArgs.car(); + initArgs = initArgs.cdr(); + second = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.OPERATION) + operation = second; + else if (first == Keyword.OPERANDS) + operands = second; + } + setOperation(operation); + setOperands(operands); + } + + public ArithmeticError(String message) throws ConditionThrowable + { + super(StandardClass.ARITHMETIC_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + setOperation(NIL); + setOperands(NIL); + } + + @Override + public LispObject typeOf() + { + return Symbol.ARITHMETIC_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.ARITHMETIC_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.ARITHMETIC_ERROR) + return T; + if (type == StandardClass.ARITHMETIC_ERROR) + return T; + return super.typep(type); + } + + private final LispObject getOperation() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.OPERATION); + } + + private final void setOperation(LispObject operation) + throws ConditionThrowable + { + setInstanceSlotValue(Symbol.OPERATION, operation); + } + + private final LispObject getOperands() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.OPERANDS); + } + + private final void setOperands(LispObject operands) + throws ConditionThrowable + { + setInstanceSlotValue(Symbol.OPERANDS, operands); + } + + // ### arithmetic-error-operation + private static final Primitive ARITHMETIC_ERROR_OPERATION = + new Primitive("arithmetic-error-operation", "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((ArithmeticError)arg).getOperation(); + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.ARITHMETIC_ERROR)); + } + } + }; + // ### arithmetic-error-operands + private static final Primitive ARITHMETIC_ERROR_OPERANDS = + new Primitive("arithmetic-error-operands", "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((ArithmeticError)arg).getOperands(); + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.ARITHMETIC_ERROR)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Autoload.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Autoload.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,699 @@ +/* + * Autoload.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: Autoload.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Autoload extends Function +{ + protected final String fileName; + protected final String className; + + private final Symbol symbol; + + protected Autoload(Symbol symbol) + { + super(); + fileName = null; + className = null; + this.symbol = symbol; + symbol.setBuiltInFunction(false); + } + + protected Autoload(Symbol symbol, String fileName, String className) + { + super(); + this.fileName = fileName; + this.className = className; + this.symbol = symbol; + symbol.setBuiltInFunction(false); + } + + protected final Symbol getSymbol() + { + return symbol; + } + + public static void autoload(String symbolName, String className) + { + autoload(PACKAGE_CL, symbolName, className); + } + + public static void autoload(Package pkg, String symbolName, + String className) + { + autoload(pkg, symbolName, className, false); + } + + public static void autoload(Package pkg, String symbolName, + String className, boolean exported) + { + Symbol symbol = intern(symbolName.toUpperCase(), pkg); + if (pkg != PACKAGE_CL && exported) { + try { + pkg.export(symbol); + } + catch (ConditionThrowable t) { + Debug.assertTrue(false); + } + } + if (symbol.getSymbolFunction() == null) + symbol.setSymbolFunction(new Autoload(symbol, null, + "org.armedbear.lisp.".concat(className))); + } + + public static void autoload(Symbol symbol, String className) + { + if (symbol.getSymbolFunction() == null) + symbol.setSymbolFunction(new Autoload(symbol, null, + "org.armedbear.lisp.".concat(className))); + } + + public void load() throws ConditionThrowable + { + if (className != null) { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue()); + thread.bindSpecial(_LOAD_DEPTH_, new Fixnum(++loadDepth)); + try { + if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL) { + final String prefix = Load.getLoadVerbosePrefix(loadDepth); + Stream out = getStandardOutput(); + out._writeString(prefix); + out._writeString(" Autoloading "); + out._writeString(className); + out._writeLine(" ..."); + out._finishOutput(); + long start = System.currentTimeMillis(); + Class.forName(className); + long elapsed = System.currentTimeMillis() - start; + out._writeString(prefix); + out._writeString(" Autoloaded "); + out._writeString(className); + out._writeString(" ("); + out._writeString(String.valueOf(((float)elapsed)/1000)); + out._writeLine(" seconds)"); + out._finishOutput(); + } else + Class.forName(className); + } + catch (ClassNotFoundException e) { + e.printStackTrace(); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } else + Load.loadSystemFile(getFileName(), true); + if (debug) { + if (symbol != null) { + if (symbol.getSymbolFunction() instanceof Autoload) { + Debug.trace("Unable to autoload " + symbol.writeToString()); + System.exit(-1); + } + } + } + } + + protected final String getFileName() + { + if (fileName != null) + return fileName; + return symbol.getName().toLowerCase(); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + load(); + return symbol.execute(); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + load(); + return symbol.execute(arg); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second, third); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second, third, fourth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second, third, fourth, fifth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second, third, fourth, fifth, sixth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second, third, fourth, fifth, sixth, + seventh); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + load(); + return symbol.execute(first, second, third, fourth, fifth, sixth, + seventh, eighth); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + load(); + return symbol.execute(args); + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = new StringBuffer("#= 0) + sb.append(className.substring(index + 1)); + else + sb.append(className); + sb.append(".class"); + } else + sb.append(getFileName()); + sb.append("\">"); + return sb.toString(); + } + + // ### autoload + private static final Primitive AUTOLOAD = + new Primitive("autoload", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject first) throws ConditionThrowable + { + if (first instanceof Symbol) { + Symbol symbol = (Symbol) first; + symbol.setSymbolFunction(new Autoload(symbol)); + return T; + } + if (first instanceof Cons) { + for (LispObject list = first; list != NIL; list = list.cdr()) { + Symbol symbol = checkSymbol(list.car()); + symbol.setSymbolFunction(new Autoload(symbol)); + } + return T; + } + return error(new TypeError(first)); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final String fileName = second.getStringValue(); + if (first instanceof Symbol) { + Symbol symbol = (Symbol) first; + symbol.setSymbolFunction(new Autoload(symbol, fileName, null)); + return T; + } + if (first instanceof Cons) { + for (LispObject list = first; list != NIL; list = list.cdr()) { + Symbol symbol = checkSymbol(list.car()); + symbol.setSymbolFunction(new Autoload(symbol, fileName, null)); + } + return T; + } + return error(new TypeError(first)); + } + }; + + // ### resolve + // Force autoload to be resolved. + private static final Primitive RESOLVE = + new Primitive("resolve", PACKAGE_EXT, true, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Symbol symbol = checkSymbol(arg); + LispObject fun = symbol.getSymbolFunction(); + if (fun instanceof Autoload) { + Autoload autoload = (Autoload) fun; + autoload.load(); + return symbol.getSymbolFunction(); + } + return fun; + } + }; + + // ### autoloadp + private static final Primitive AUTOLOADP = + new Primitive("autoloadp", PACKAGE_EXT, true, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Symbol) { + if (arg.getSymbolFunction() instanceof Autoload) + return T; + } + return NIL; + } + }; + + /* + public void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { + try { + load(); + } catch(ConditionThrowable t) { + throw new java.io.InvalidObjectException("Couldn't resolve autoload: " + t); + } + stream.defaultWriteObject(); + }*/ + + static { + autoload("acos", "MathFunctions"); + autoload("acosh", "MathFunctions"); + autoload("arithmetic-error-operands", "ArithmeticError"); + autoload("arithmetic-error-operation", "ArithmeticError"); + autoload("ash", "ash"); + autoload("asin", "MathFunctions"); + autoload("asinh", "MathFunctions"); + autoload("atan", "MathFunctions"); + autoload("atanh", "MathFunctions"); + autoload("broadcast-stream-streams", "BroadcastStream"); + autoload("ceiling", "ceiling"); + autoload("cell-error-name", "cell_error_name"); + autoload("char", "StringFunctions"); + autoload("char-equal", "CharacterFunctions"); + autoload("char-greaterp", "CharacterFunctions"); + autoload("char-lessp", "CharacterFunctions"); + autoload("char-not-greaterp", "CharacterFunctions"); + autoload("char-not-lessp", "CharacterFunctions"); + autoload("char<", "CharacterFunctions"); + autoload("char<=", "CharacterFunctions"); + autoload("char=", "CharacterFunctions"); + autoload("cis", "MathFunctions"); + autoload("clrhash", "HashTableFunctions"); + autoload("clrhash", "HashTableFunctions"); + autoload("concatenated-stream-streams", "ConcatenatedStream"); + autoload("cos", "MathFunctions"); + autoload("cosh", "MathFunctions"); + autoload("delete-file", "delete_file"); + autoload("delete-package", "PackageFunctions"); + autoload("echo-stream-input-stream", "EchoStream"); + autoload("echo-stream-output-stream", "EchoStream"); + autoload("exp", "MathFunctions"); + autoload("expt", "MathFunctions"); + autoload("file-author", "file_author"); + autoload("file-error-pathname", "file_error_pathname"); + autoload("file-length", "file_length"); + autoload("file-string-length", "file_string_length"); + autoload("file-write-date", "file_write_date"); + autoload("float", "FloatFunctions"); + autoload("float-digits", "FloatFunctions"); + autoload("float-radix", "FloatFunctions"); + autoload("float-sign", "float_sign"); + autoload("floatp", "FloatFunctions"); + autoload("floor", "floor"); + autoload("ftruncate", "ftruncate"); + autoload("get-internal-real-time", "Time"); + autoload("get-internal-run-time", "Time"); + autoload("get-output-stream-string", "StringOutputStream"); + autoload("get-properties", "get_properties"); + autoload("get-universal-time", "Time"); + autoload("gethash", "HashTableFunctions"); + autoload("gethash", "HashTableFunctions"); + autoload("hash-table-count", "HashTableFunctions"); + autoload("hash-table-count", "HashTableFunctions"); + autoload("hash-table-p", "HashTableFunctions"); + autoload("hash-table-p", "HashTableFunctions"); + autoload("hash-table-rehash-size", "HashTableFunctions"); + autoload("hash-table-rehash-size", "HashTableFunctions"); + autoload("hash-table-rehash-threshold", "HashTableFunctions"); + autoload("hash-table-rehash-threshold", "HashTableFunctions"); + autoload("hash-table-size", "HashTableFunctions"); + autoload("hash-table-size", "HashTableFunctions"); + autoload("hash-table-test", "HashTableFunctions"); + autoload("hash-table-test", "HashTableFunctions"); + autoload("%import", "PackageFunctions"); + autoload("input-stream-p", "input_stream_p"); + autoload("integer-decode-float", "FloatFunctions"); + autoload("interactive-stream-p", "interactive_stream_p"); + autoload("last", "last"); + autoload("lisp-implementation-type", "lisp_implementation_type"); + autoload("lisp-implementation-version", "lisp_implementation_version"); + autoload("list-all-packages", "PackageFunctions"); + autoload("listen", "listen"); + autoload("log", "MathFunctions"); + autoload("logand", "logand"); + autoload("logandc1", "logandc1"); + autoload("logandc2", "logandc2"); + autoload("logbitp", "logbitp"); + autoload("logcount", "logcount"); + autoload("logeqv", "logeqv"); + autoload("logior", "logior"); + autoload("lognand", "lognand"); + autoload("lognor", "lognor"); + autoload("lognot", "lognot"); + autoload("logorc1", "logorc1"); + autoload("logorc2", "logorc2"); + autoload("logtest", "logtest"); + autoload("logxor", "logxor"); + autoload("long-site-name", "SiteName"); + autoload("machine-instance", "SiteName"); + autoload("machine-type", "machine_type"); + autoload("machine-version", "machine_version"); + autoload("make-broadcast-stream", "BroadcastStream"); + autoload("make-concatenated-stream", "ConcatenatedStream"); + autoload("make-echo-stream", "EchoStream"); + autoload("make-string-input-stream", "StringInputStream"); + autoload("make-synonym-stream", "SynonymStream"); + autoload("maphash", "HashTableFunctions"); + autoload("mod", "mod"); + autoload("open-stream-p", "open_stream_p"); + autoload("output-stream-p", "output_stream_p"); + autoload("package-error-package", "package_error_package"); + autoload("package-error-package", "package_error_package"); + autoload("package-name", "PackageFunctions"); + autoload("package-nicknames", "PackageFunctions"); + autoload("package-shadowing-symbols", "PackageFunctions"); + autoload("package-use-list", "PackageFunctions"); + autoload("package-used-by-list", "PackageFunctions"); + autoload("packagep", "PackageFunctions"); + autoload("peek-char", "peek_char"); + autoload("print-not-readable-object", "PrintNotReadable"); + autoload("probe-file", "probe_file"); + autoload("rational", "FloatFunctions"); + autoload("rem", "rem"); + autoload("remhash", "HashTableFunctions"); + autoload("remhash", "HashTableFunctions"); + autoload("rename-package", "PackageFunctions"); + autoload("room", "room"); + autoload("scale-float", "FloatFunctions"); + autoload("schar", "StringFunctions"); + autoload("shadow", "PackageFunctions"); + autoload("shadowing-import", "PackageFunctions"); + autoload("short-site-name", "SiteName"); + autoload("simple-condition-format-arguments", "SimpleCondition"); + autoload("simple-condition-format-control", "SimpleCondition"); + autoload("simple-string-p", "StringFunctions"); + autoload("sin", "MathFunctions"); + autoload("sinh", "MathFunctions"); + autoload("software-type", "software_type"); + autoload("software-version", "software_version"); + autoload("sqrt", "MathFunctions"); + autoload("stream-element-type", "stream_element_type"); + autoload("stream-error-stream", "StreamError"); + autoload("stream-external-format", "stream_external_format"); + autoload("stringp", "StringFunctions"); + autoload("sxhash", "HashTableFunctions"); + autoload("sxhash", "HashTableFunctions"); + autoload("synonym-stream-symbol", "SynonymStream"); + autoload("tan", "MathFunctions"); + autoload("tanh", "MathFunctions"); + autoload("truename", "probe_file"); + autoload("truncate", "truncate"); + autoload("type-error-datum", "TypeError"); + autoload("type-error-expected-type", "TypeError"); + autoload("unbound-slot-instance", "unbound_slot_instance"); + autoload("unexport", "PackageFunctions"); + autoload("unuse-package", "PackageFunctions"); + autoload(PACKAGE_EXT, "arglist", "arglist", true); + autoload(PACKAGE_EXT, "assq", "assq", true); + autoload(PACKAGE_EXT, "assql", "assql", true); + autoload(PACKAGE_EXT, "file-directory-p", "probe_file", true); + autoload(PACKAGE_EXT, "gc", "gc", true); + autoload(PACKAGE_EXT, "get-floating-point-modes", "FloatFunctions", true); + autoload(PACKAGE_EXT, "get-mutex", "Mutex", true); + autoload(PACKAGE_EXT, "mailbox-empty-p", "Mailbox", true); + autoload(PACKAGE_EXT, "mailbox-peek", "Mailbox", true); + autoload(PACKAGE_EXT, "mailbox-read", "Mailbox", true); + autoload(PACKAGE_EXT, "mailbox-send", "Mailbox", true); + autoload(PACKAGE_EXT, "make-mailbox", "Mailbox", true); + autoload(PACKAGE_EXT, "make-mutex", "Mutex", true); + autoload(PACKAGE_EXT, "make-slime-input-stream", "SlimeInputStream", true); + autoload(PACKAGE_EXT, "make-slime-output-stream", "SlimeOutputStream", true); + autoload(PACKAGE_EXT, "make-thread-lock", "ThreadLock", true); + autoload(PACKAGE_EXT, "probe-directory", "probe_file", true); + autoload(PACKAGE_EXT, "release-mutex", "Mutex", true); + autoload(PACKAGE_EXT, "set-floating-point-modes", "FloatFunctions", true); + autoload(PACKAGE_EXT, "simple-string-fill", "StringFunctions"); + autoload(PACKAGE_EXT, "simple-string-search", "StringFunctions"); + autoload(PACKAGE_EXT, "string-input-stream-current", "StringInputStream", true); + autoload(PACKAGE_EXT, "string-find", "StringFunctions"); + autoload(PACKAGE_EXT, "string-position", "StringFunctions"); + autoload(PACKAGE_EXT, "thread-lock", "ThreadLock", true); + autoload(PACKAGE_EXT, "thread-unlock", "ThreadLock", true); + autoload(PACKAGE_JAVA, "%jnew-proxy", "JProxy"); + autoload(PACKAGE_JAVA, "%find-java-class", "JavaClass"); + autoload(PACKAGE_JAVA, "%jmake-invocation-handler", "JProxy"); + autoload(PACKAGE_JAVA, "%jmake-proxy", "JProxy"); + autoload(PACKAGE_JAVA, "%jnew-runtime-class", "RuntimeClass"); + autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass"); + autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler"); + autoload(PACKAGE_JAVA, "%load-java-class-from-byte-array", "RuntimeClass"); + autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false); + autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true); + autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); + autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true); + autoload(PACKAGE_MOP, "set-funcallable-instance-function", "StandardGenericFunction", true); + autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true); + autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true); + autoload(PACKAGE_SYS, "%%string=", "StringFunctions"); + autoload(PACKAGE_SYS, "%adjust-array", "adjust_array"); + autoload(PACKAGE_SYS, "%defpackage", "PackageFunctions"); + autoload(PACKAGE_SYS, "%finalize-generic-function", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%generic-function-lambda-list", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%generic-function-name", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%make-array", "make_array"); + autoload(PACKAGE_SYS, "%make-condition", "make_condition", true); + autoload(PACKAGE_SYS, "%make-hash-table", "HashTableFunctions"); + autoload(PACKAGE_SYS, "%make-hash-table", "HashTableFunctions"); + autoload(PACKAGE_SYS, "%make-logical-pathname", "LogicalPathname", true); + autoload(PACKAGE_SYS, "%make-server-socket", "make_server_socket"); + autoload(PACKAGE_SYS, "%make-socket", "make_socket"); + autoload(PACKAGE_SYS, "%make-string", "StringFunctions"); + autoload(PACKAGE_SYS, "%make-string-output-stream", "StringOutputStream"); + autoload(PACKAGE_SYS, "%method-fast-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%method-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%method-generic-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%method-specializers", "StandardMethod", true); + autoload(PACKAGE_SYS, "%nstring-capitalize", "StringFunctions"); + autoload(PACKAGE_SYS, "%nstring-downcase", "StringFunctions"); + autoload(PACKAGE_SYS, "%nstring-upcase", "StringFunctions"); + autoload(PACKAGE_SYS, "%run-shell-command", "ShellCommand"); + autoload(PACKAGE_SYS, "%server-socket-close", "server_socket_close"); + autoload(PACKAGE_SYS, "%set-arglist", "arglist"); + autoload(PACKAGE_SYS, "%set-class-direct-slots", "SlotClass", true); + autoload(PACKAGE_SYS, "%set-function-info", "function_info"); + autoload(PACKAGE_SYS, "%set-generic-function-lambda-list", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%set-method-fast-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%set-method-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%set-method-generic-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%set-method-specializers", "StandardMethod", true); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc1", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc2", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-eqv", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-ior", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-nand", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-nor", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-not", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-orc1", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-orc2", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%simple-bit-vector-bit-xor", "SimpleBitVector"); + autoload(PACKAGE_SYS, "%slot-definition-allocation", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-allocation-class", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-initargs", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-initform", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-initfunction", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-location", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-name", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-readers", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%slot-definition-writers", "SlotDefinition", true); + autoload(PACKAGE_SYS, "%socket-accept", "socket_accept"); + autoload(PACKAGE_SYS, "%socket-close", "socket_close"); + autoload(PACKAGE_SYS, "%socket-stream", "socket_stream"); + autoload(PACKAGE_SYS, "%string-capitalize", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-downcase", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-equal", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-greaterp", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-lessp", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-not-equal", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-not-greaterp", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-not-lessp", "StringFunctions"); + autoload(PACKAGE_SYS, "%string-upcase", "StringFunctions"); + autoload(PACKAGE_SYS, "%string/=", "StringFunctions"); + autoload(PACKAGE_SYS, "%string<", "StringFunctions"); + autoload(PACKAGE_SYS, "%string<=", "StringFunctions"); + autoload(PACKAGE_SYS, "%string=", "StringFunctions"); + autoload(PACKAGE_SYS, "%string>", "StringFunctions"); + autoload(PACKAGE_SYS, "%string>=", "StringFunctions"); + autoload(PACKAGE_SYS, "%time", "Time"); + autoload(PACKAGE_SYS, "cache-emf", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "cache-slot-location", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "canonicalize-logical-host", "LogicalPathname", true); + autoload(PACKAGE_SYS, "class-direct-slots", "SlotClass"); + autoload(PACKAGE_SYS, "coerce-to-double-float", "FloatFunctions"); + autoload(PACKAGE_SYS, "coerce-to-single-float", "FloatFunctions"); + autoload(PACKAGE_SYS, "compute-class-direct-slots", "SlotClass", true); + autoload(PACKAGE_SYS, "create-new-file", "create_new_file"); + autoload(PACKAGE_SYS, "default-time-zone", "Time"); + autoload(PACKAGE_SYS, "disassemble-class-bytes", "disassemble_class_bytes", true); + autoload(PACKAGE_SYS, "double-float-high-bits", "FloatFunctions", true); + autoload(PACKAGE_SYS, "double-float-low-bits", "FloatFunctions", true); + autoload(PACKAGE_SYS, "float-infinity-p", "FloatFunctions", true); + autoload(PACKAGE_SYS, "float-nan-p", "FloatFunctions", true); + autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true); + autoload(PACKAGE_SYS, "function-info", "function_info"); + autoload(PACKAGE_SYS, "generic-function-argument-precedence-order","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "generic-function-initial-methods","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "generic-function-method-class","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "generic-function-method-combination","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "generic-function-methods","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "get-cached-emf", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "get-function-info-value", "function_info"); + autoload(PACKAGE_SYS, "gf-required-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); + autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); + autoload(PACKAGE_SYS, "layout-class", "Layout", true); + autoload(PACKAGE_SYS, "layout-length", "Layout", true); + autoload(PACKAGE_SYS, "layout-slot-index", "Layout", true); + autoload(PACKAGE_SYS, "layout-slot-location", "Layout", true); + autoload(PACKAGE_SYS, "make-case-frob-stream", "CaseFrobStream"); + autoload(PACKAGE_SYS, "make-double-float", "FloatFunctions", true); + autoload(PACKAGE_SYS, "make-file-stream", "FileStream"); + autoload(PACKAGE_SYS, "make-fill-pointer-output-stream", "FillPointerOutputStream"); + autoload(PACKAGE_SYS, "make-forward-referenced-class", "ForwardReferencedClass", true); + autoload(PACKAGE_SYS, "make-layout", "Layout", true); + autoload(PACKAGE_SYS, "make-single-float", "FloatFunctions", true); + autoload(PACKAGE_SYS, "make-slot-definition", "SlotDefinition", true); + autoload(PACKAGE_SYS, "make-structure-class", "StructureClass"); + autoload(PACKAGE_SYS, "make-symbol-macro", "SymbolMacro"); + autoload(PACKAGE_SYS, "method-documentation", "StandardMethod", true); + autoload(PACKAGE_SYS, "method-lambda-list", "StandardMethod", true); + autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions"); + autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); + autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); + autoload(PACKAGE_SYS, "set-function-info-value", "function_info"); + autoload(PACKAGE_SYS, "set-generic-function-argument-precedence-order","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-classes-to-emf-table","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-documentation","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-initial-methods","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-method-class","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-method-combination","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-generic-function-methods","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "set-method-documentation", "StandardMethod", true); + autoload(PACKAGE_SYS, "set-method-lambda-list", "StandardMethod", true); + autoload(PACKAGE_SYS, "set-method-qualifiers", "StandardMethod", true); + autoload(PACKAGE_SYS, "set-slot-definition-allocation", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-allocation-class", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-initargs", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-initform", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-initfunction", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-location", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-name", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-readers", "SlotDefinition", true); + autoload(PACKAGE_SYS, "set-slot-definition-writers", "SlotDefinition", true); + autoload(PACKAGE_SYS, "simple-list-remove-duplicates", "simple_list_remove_duplicates"); + autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true); + autoload(PACKAGE_SYS, "std-allocate-instance", "StandardObjectFunctions", true); + autoload(PACKAGE_SYS, "zip", "zip", true); + + autoload(Symbol.COPY_LIST, "copy_list"); + + autoload(Symbol.SET_CHAR, "StringFunctions"); + autoload(Symbol.SET_SCHAR, "StringFunctions"); + + autoload(Symbol.SET_CLASS_SLOTS, "SlotClass"); + autoload(Symbol._CLASS_SLOTS, "SlotClass"); + + autoload(Symbol.JAVA_EXCEPTION_CAUSE, "JavaException"); + autoload(Symbol.JCLASS_NAME, "jclass_name"); + autoload(Symbol.JCLASS_OF, "jclass_of"); + autoload(Symbol.JMETHOD_RETURN_TYPE, "jmethod_return_type"); + } +} Added: branches/save-image/src/org/armedbear/lisp/AutoloadMacro.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/AutoloadMacro.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,116 @@ +/* + * AutoloadMacro.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: AutoloadMacro.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class AutoloadMacro extends Autoload +{ + private AutoloadMacro(Symbol symbol) + { + super(symbol); + } + + private AutoloadMacro(Symbol symbol, String fileName) + { + super(symbol, fileName, null); + } + + private static void installAutoloadMacro(Symbol symbol, String fileName) + throws ConditionThrowable + { + AutoloadMacro am = new AutoloadMacro(symbol, fileName); + if (symbol.getSymbolFunction() instanceof SpecialOperator) + put(symbol, Symbol.MACROEXPAND_MACRO, am); + else + symbol.setSymbolFunction(am); + } + + @Override + public void load() throws ConditionThrowable + { + Load.loadSystemFile(getFileName(), true); + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = new StringBuffer("#"); + return sb.toString(); + } + + // ### autoload-macro + private static final Primitive AUTOLOAD_MACRO = + new Primitive("autoload-macro", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject first) throws ConditionThrowable + { + if (first instanceof Symbol) { + Symbol symbol = (Symbol) first; + installAutoloadMacro(symbol, null); + return T; + } + if (first instanceof Cons) { + for (LispObject list = first; list != NIL; list = list.cdr()) { + Symbol symbol = checkSymbol(list.car()); + installAutoloadMacro(symbol, null); + } + return T; + } + return error(new TypeError(first)); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final String fileName = second.getStringValue(); + if (first instanceof Symbol) { + Symbol symbol = (Symbol) first; + installAutoloadMacro(symbol, fileName); + return T; + } + if (first instanceof Cons) { + for (LispObject list = first; list != NIL; list = list.cdr()) { + Symbol symbol = checkSymbol(list.car()); + installAutoloadMacro(symbol, fileName); + } + return T; + } + return error(new TypeError(first)); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte16.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,301 @@ +/* + * BasicVector_UnsignedByte16.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: BasicVector_UnsignedByte16.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// A basic vector is a specialized vector that is not displaced to another +// array, has no fill pointer, and is not expressly adjustable. +public final class BasicVector_UnsignedByte16 extends AbstractVector +{ + private int capacity; + private int[] elements; + + public BasicVector_UnsignedByte16(int capacity) + { + elements = new int[capacity]; + this.capacity = capacity; + } + + private BasicVector_UnsignedByte16(LispObject[] array) + throws ConditionThrowable + { + capacity = array.length; + elements = new int[capacity]; + for (int i = array.length; i-- > 0;) + elements[i] = Fixnum.getValue(array[i]); + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, UNSIGNED_BYTE_16, + new Cons(new Fixnum(capacity))); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.VECTOR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(type); + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_16; + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + @Override + public boolean hasFillPointer() + { + return false; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + try { + return new Fixnum(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + // Ignores fill pointer. + @Override + public int aref(int index) throws ConditionThrowable + { + try { + return elements[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + // Not reached. + return 0; + } + } + + // Ignores fill pointer. + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try { + return new Fixnum(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + return NIL; // Not reached. + } + } + + // Ignores fill pointer. + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try { + return new Fixnum(elements[((Fixnum)index).value]); + } + catch (ClassCastException e) { + return error(new TypeError(index, Symbol.FIXNUM)); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(Fixnum.getValue(index), elements.length); + return NIL; // Not reached. + } + } + + @Override + public void aset(int index, int n) throws ConditionThrowable + { + try { + elements[index] = n; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + } + } + + @Override + public void aset(int index, LispObject obj) throws ConditionThrowable + { + try { + elements[index] = ((Fixnum)obj).value; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + } + catch (ClassCastException e) { + error(new TypeError(obj, UNSIGNED_BYTE_16)); + } + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + BasicVector_UnsignedByte16 v = new BasicVector_UnsignedByte16(end - start); + int i = start, j = 0; + try { + while (i < end) + v.elements[j++] = elements[i++]; + return v; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + int n = Fixnum.getValue(obj); + for (int i = capacity; i-- > 0;) + elements[i] = n; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (n < capacity) { + int[] newArray = new int[n]; + System.arraycopy(elements, 0, newArray, 0, n); + elements = newArray; + capacity = n; + return; + } + if (n == capacity) + return; + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + BasicVector_UnsignedByte16 result = new BasicVector_UnsignedByte16(capacity); + int i, j; + for (i = 0, j = capacity - 1; i < capacity; i++, j--) + result.elements[i] = elements[j]; + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = capacity - 1; + while (i < j) { + int temp = elements[i]; + elements[i] = elements[j]; + elements[j] = temp; + ++i; + --j; + } + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) { + LispObject[] newElements = new LispObject[newCapacity]; + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + newElements[i] = list.car(); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + newElements[i] = initialContents.elt(i); + } else + error(new TypeError(initialContents, Symbol.SEQUENCE)); + return new BasicVector_UnsignedByte16(newElements); + } + if (capacity != newCapacity) { + LispObject[] newElements = new LispObject[newCapacity]; + System.arraycopy(elements, 0, newElements, 0, + Math.min(capacity, newCapacity)); + if (initialElement != null) + for (int i = capacity; i < newCapacity; i++) + newElements[i] = initialElement; + return new BasicVector_UnsignedByte16(newElements); + } + // No change. + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + { + return new ComplexVector(newCapacity, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte32.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,320 @@ +/* + * BasicVector_UnsignedByte32.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: BasicVector_UnsignedByte32.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// A basic vector is a specialized vector that is not displaced to another +// array, has no fill pointer, and is not expressly adjustable. +public final class BasicVector_UnsignedByte32 extends AbstractVector +{ + private int capacity; + + private long[] elements; + + public BasicVector_UnsignedByte32(int capacity) + { + elements = new long[capacity]; + this.capacity = capacity; + } + + public BasicVector_UnsignedByte32(LispObject[] array) + throws ConditionThrowable + { + capacity = array.length; + elements = new long[capacity]; + for (int i = array.length; i-- > 0;) + elements[i] = array[i].longValue(); + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, UNSIGNED_BYTE_32, + new Cons(new Fixnum(capacity))); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.VECTOR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(type); + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_32; + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + @Override + public boolean hasFillPointer() + { + return false; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + try + { + return number(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public int aref(int index) throws ConditionThrowable + { + try + { + return (int) elements[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, elements.length); + return -1; // Not reached. + } + } + + @Override + public long aref_long(int index) throws ConditionThrowable + { + try + { + return elements[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, elements.length); + return -1; // Not reached. + } + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try + { + return number(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, elements.length); + return NIL; // Not reached. + } + } + + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try + { + return number(elements[((Fixnum)index).value]); + } + catch (ClassCastException e) + { + return type_error(index, Symbol.FIXNUM); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(Fixnum.getValue(index), elements.length); + return NIL; // Not reached. + } + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + try + { + elements[index] = newValue.longValue(); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + } + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + BasicVector_UnsignedByte32 v = new BasicVector_UnsignedByte32(end - start); + int i = start, j = 0; + try + { + while (i < end) + v.elements[j++] = elements[i++]; + return v; + } + catch (ArrayIndexOutOfBoundsException e) + { + // FIXME + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + for (int i = capacity; i-- > 0;) + elements[i] = obj.longValue(); + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (n < capacity) + { + long[] newArray = new long[n]; + System.arraycopy(elements, 0, newArray, 0, n); + elements = newArray; + capacity = n; + return; + } + if (n == capacity) + return; + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + BasicVector_UnsignedByte32 result = new BasicVector_UnsignedByte32(capacity); + int i, j; + for (i = 0, j = capacity - 1; i < capacity; i++, j--) + result.elements[i] = elements[j]; + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = capacity - 1; + while (i < j) + { + long temp = elements[i]; + elements[i] = elements[j]; + elements[j] = temp; + ++i; + --j; + } + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + { + LispObject[] newElements = new LispObject[newCapacity]; + if (initialContents.listp()) + { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) + { + newElements[i] = list.car(); + list = list.cdr(); + } + } + else if (initialContents.vectorp()) + { + for (int i = 0; i < newCapacity; i++) + newElements[i] = initialContents.elt(i); + } + else + type_error(initialContents, Symbol.SEQUENCE); + return new BasicVector_UnsignedByte32(newElements); + } + if (capacity != newCapacity) + { + LispObject[] newElements = new LispObject[newCapacity]; + System.arraycopy(elements, 0, newElements, 0, + Math.min(capacity, newCapacity)); + if (initialElement != null) + for (int i = capacity; i < newCapacity; i++) + newElements[i] = initialElement; + return new BasicVector_UnsignedByte32(newElements); + } + // No change. + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + { + return new ComplexVector(newCapacity, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/BasicVector_UnsignedByte8.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,318 @@ +/* + * BasicVector_UnsignedByte8.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: BasicVector_UnsignedByte8.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// A basic vector is a specialized vector that is not displaced to another +// array, has no fill pointer, and is not expressly adjustable. +public final class BasicVector_UnsignedByte8 extends AbstractVector +{ + private int capacity; + private byte[] elements; + + public BasicVector_UnsignedByte8(int capacity) + { + elements = new byte[capacity]; + this.capacity = capacity; + } + + public BasicVector_UnsignedByte8(LispObject[] array) + throws ConditionThrowable + { + capacity = array.length; + elements = new byte[capacity]; + for (int i = array.length; i-- > 0;) + elements[i] = coerceLispObjectToJavaByte(array[i]); + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, UNSIGNED_BYTE_8, new Cons(new Fixnum(capacity))); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.VECTOR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(type); + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_8; + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + @Override + public boolean hasFillPointer() + { + return false; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + try + { + return coerceJavaByteToLispObject(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public int aref(int index) throws ConditionThrowable + { + try + { + return (((int)elements[index]) & 0xff); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, elements.length); + // Not reached. + return 0; + } + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try + { + return coerceJavaByteToLispObject(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, elements.length); + return NIL; // Not reached. + } + } + + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try + { + return coerceJavaByteToLispObject(elements[((Fixnum)index).value]); + } + catch (ClassCastException e) + { + return error(new TypeError(index, Symbol.FIXNUM)); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(Fixnum.getValue(index), elements.length); + return NIL; // Not reached. + } + } + + @Override + public void aset(int index, int n) throws ConditionThrowable + { + try + { + elements[index] = (byte) n; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + } + } + + @Override + public void aset(int index, LispObject value) throws ConditionThrowable + { + try + { + elements[index] = coerceLispObjectToJavaByte(value); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + } + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + BasicVector_UnsignedByte8 v = new BasicVector_UnsignedByte8(end - start); + int i = start, j = 0; + try + { + while (i < end) + v.elements[j++] = elements[i++]; + return v; + } + catch (ArrayIndexOutOfBoundsException e) + { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + byte b = coerceLispObjectToJavaByte(obj); + for (int i = capacity; i-- > 0;) + elements[i] = b; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (n < capacity) + { + byte[] newArray = new byte[n]; + System.arraycopy(elements, 0, newArray, 0, n); + elements = newArray; + capacity = n; + return; + } + if (n == capacity) + return; + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + BasicVector_UnsignedByte8 result = new BasicVector_UnsignedByte8(capacity); + int i, j; + for (i = 0, j = capacity - 1; i < capacity; i++, j--) + result.elements[i] = elements[j]; + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = capacity - 1; + while (i < j) + { + byte temp = elements[i]; + elements[i] = elements[j]; + elements[j] = temp; + ++i; + --j; + } + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + { + LispObject[] newElements = new LispObject[newCapacity]; + if (initialContents.listp()) + { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) + { + newElements[i] = list.car(); + list = list.cdr(); + } + } + else if (initialContents.vectorp()) + { + for (int i = 0; i < newCapacity; i++) + newElements[i] = initialContents.elt(i); + } + else + type_error(initialContents, Symbol.SEQUENCE); + return new BasicVector_UnsignedByte8(newElements); + } + if (capacity != newCapacity) + { + LispObject[] newElements = new LispObject[newCapacity]; + System.arraycopy(elements, 0, newElements, 0, + Math.min(capacity, newCapacity)); + if (initialElement != null) + for (int i = capacity; i < newCapacity; i++) + newElements[i] = initialElement; + return new BasicVector_UnsignedByte8(newElements); + } + // No change. + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + { + return new ComplexVector(newCapacity, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/Bignum.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Bignum.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,790 @@ +/* + * Bignum.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Bignum.java 11647 2009-02-08 21:23:48Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class Bignum extends LispInteger +{ + public final BigInteger value; + + public static Bignum getInstance(long l) { + return new Bignum(l); + } + + public Bignum(long l) + { + value = BigInteger.valueOf(l); + } + + public Bignum(BigInteger n) + { + value = n; + } + + public Bignum(String s, int radix) + { + value = new BigInteger(s, radix); + } + + @Override + public Object javaInstance() + { + return value; + } + + @Override + public Object javaInstance(Class c) { + String cn = c.getName(); + if (cn.equals("java.lang.Byte") || cn.equals("byte")) + return Byte.valueOf((byte)value.intValue()); + if (cn.equals("java.lang.Short") || cn.equals("short")) + return Short.valueOf((short)value.intValue()); + if (cn.equals("java.lang.Integer") || cn.equals("int")) + return Integer.valueOf(value.intValue()); + if (cn.equals("java.lang.Long") || cn.equals("long")) + return Long.valueOf((long)value.longValue()); + return javaInstance(); + } + + + @Override + public LispObject typeOf() + { + if (value.signum() > 0) + return list2(Symbol.INTEGER, + new Bignum((long)Integer.MAX_VALUE + 1)); + return Symbol.BIGNUM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.BIGNUM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type instanceof Symbol) + { + if (type == Symbol.BIGNUM) + return T; + if (type == Symbol.INTEGER) + return T; + if (type == Symbol.RATIONAL) + return T; + if (type == Symbol.REAL) + return T; + if (type == Symbol.NUMBER) + return T; + if (type == Symbol.SIGNED_BYTE) + return T; + if (type == Symbol.UNSIGNED_BYTE) + return value.signum() >= 0 ? T : NIL; + } + else if (type instanceof LispClass) + { + if (type == BuiltInClass.BIGNUM) + return T; + if (type == BuiltInClass.INTEGER) + return T; + if (type == BuiltInClass.RATIONAL) + return T; + if (type == BuiltInClass.REAL) + return T; + if (type == BuiltInClass.NUMBER) + return T; + } + else if (type instanceof Cons) + { + if (type.equal(UNSIGNED_BYTE_8)) + return NIL; + if (type.equal(UNSIGNED_BYTE_32)) + { + if (minusp()) + return NIL; + return isLessThan(UNSIGNED_BYTE_32_MAX_VALUE) ? T : NIL; + } + } + return super.typep(type); + } + + @Override + public LispObject NUMBERP() + { + return T; + } + + @Override + public boolean numberp() + { + return true; + } + + @Override + public LispObject INTEGERP() + { + return T; + } + + @Override + public boolean integerp() + { + return true; + } + + @Override + public boolean rationalp() + { + return true; + } + + @Override + public boolean realp() + { + return true; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof Bignum) + { + if (value.equals(((Bignum)obj).value)) + return true; + } + return false; + } + + @Override + public boolean equal(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof Bignum) + { + if (value.equals(((Bignum)obj).value)) + return true; + } + return false; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Bignum) + return value.equals(((Bignum)obj).value); + if (obj instanceof SingleFloat) + return floatValue() == ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return doubleValue() == ((DoubleFloat)obj).value; + return false; + } + + @Override + public LispObject ABS() + { + if (value.signum() >= 0) + return this; + return new Bignum(value.negate()); + } + + @Override + public LispObject NUMERATOR() + { + return this; + } + + @Override + public LispObject DENOMINATOR() + { + return Fixnum.ONE; + } + + @Override + public boolean evenp() throws ConditionThrowable + { + return !value.testBit(0); + } + + @Override + public boolean oddp() throws ConditionThrowable + { + return value.testBit(0); + } + + @Override + public boolean plusp() + { + return value.signum() > 0; + } + + @Override + public boolean minusp() + { + return value.signum() < 0; + } + + @Override + public boolean zerop() + { + return false; + } + + @Override + public int intValue() + { + return value.intValue(); + } + + @Override + public long longValue() + { + return value.longValue(); + } + + @Override + public float floatValue() throws ConditionThrowable + { + float f = value.floatValue(); + if (Float.isInfinite(f)) + error(new TypeError("The value " + writeToString() + + " is too large to be converted to a single float.")); + return f; + } + + @Override + public double doubleValue() throws ConditionThrowable + { + double d = value.doubleValue(); + if (Double.isInfinite(d)) + error(new TypeError("The value " + writeToString() + + " is too large to be converted to a double float.")); + return d; + } + + public static BigInteger getValue(LispObject obj) throws ConditionThrowable + { + try + { + return ((Bignum)obj).value; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.BIGNUM); + // Not reached. + return null; + } + } + + @Override + public final LispObject incr() + { + return number(value.add(BigInteger.ONE)); + } + + @Override + public final LispObject decr() + { + return number(value.subtract(BigInteger.ONE)); + } + + @Override + public LispObject add(int n) throws ConditionThrowable + { + return number(value.add(BigInteger.valueOf(n))); + } + + @Override + public LispObject add(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return number(value.add(Fixnum.getBigInteger(obj))); + if (obj instanceof Bignum) + return number(value.add(((Bignum)obj).value)); + if (obj instanceof Ratio) + { + BigInteger numerator = ((Ratio)obj).numerator(); + BigInteger denominator = ((Ratio)obj).denominator(); + return number(value.multiply(denominator).add(numerator), + denominator); + } + if (obj instanceof SingleFloat) + return new SingleFloat(floatValue() + ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(doubleValue() + ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return Complex.getInstance(add(c.getRealPart()), c.getImaginaryPart()); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return number(value.subtract(Fixnum.getBigInteger(obj))); + if (obj instanceof Bignum) + return number(value.subtract(((Bignum)obj).value)); + if (obj instanceof Ratio) + { + BigInteger numerator = ((Ratio)obj).numerator(); + BigInteger denominator = ((Ratio)obj).denominator(); + return number(value.multiply(denominator).subtract(numerator), + denominator); + } + if (obj instanceof SingleFloat) + return new SingleFloat(floatValue() - ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(doubleValue() - ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return Complex.getInstance(subtract(c.getRealPart()), + Fixnum.ZERO.subtract(c.getImaginaryPart())); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject multiplyBy(int n) throws ConditionThrowable + { + if (n == 0) + return Fixnum.ZERO; + if (n == 1) + return this; + return new Bignum(value.multiply(BigInteger.valueOf(n))); + } + + @Override + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + { + int n = ((Fixnum)obj).value; + if (n == 0) + return Fixnum.ZERO; + if (n == 1) + return this; + return new Bignum(value.multiply(BigInteger.valueOf(n))); + } + if (obj instanceof Bignum) + return new Bignum(value.multiply(((Bignum)obj).value)); + if (obj instanceof Ratio) + { + BigInteger n = ((Ratio)obj).numerator(); + return number(n.multiply(value), ((Ratio)obj).denominator()); + } + if (obj instanceof SingleFloat) + return new SingleFloat(floatValue() * ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(doubleValue() * ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return Complex.getInstance(multiplyBy(c.getRealPart()), + multiplyBy(c.getImaginaryPart())); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return number(value, Fixnum.getBigInteger(obj)); + if (obj instanceof Bignum) + return number(value, ((Bignum)obj).value); + if (obj instanceof Ratio) + { + BigInteger d = ((Ratio)obj).denominator(); + return number(d.multiply(value), ((Ratio)obj).numerator()); + } + if (obj instanceof SingleFloat) + return new SingleFloat(floatValue() / ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(doubleValue() / ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + LispObject realPart = c.getRealPart(); + LispObject imagPart = c.getImaginaryPart(); + LispObject denominator = + realPart.multiplyBy(realPart).add(imagPart.multiplyBy(imagPart)); + return Complex.getInstance(multiplyBy(realPart).divideBy(denominator), + Fixnum.ZERO.subtract(multiplyBy(imagPart).divideBy(denominator))); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Bignum) + return value.equals(((Bignum)obj).value); + if (obj instanceof SingleFloat) + return isEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isEqualTo(((DoubleFloat)obj).rational()); + if (obj.numberp()) + return false; + type_error(obj, Symbol.NUMBER); + // Not reached. + return false; + } + + @Override + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Bignum) + return !value.equals(((Bignum)obj).value); + if (obj instanceof SingleFloat) + return isNotEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isNotEqualTo(((DoubleFloat)obj).rational()); + if (obj.numberp()) + return true; + type_error(obj, Symbol.NUMBER); + // Not reached. + return false; + } + + @Override + public boolean isLessThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value.compareTo(Fixnum.getBigInteger(obj)) < 0; + if (obj instanceof Bignum) + return value.compareTo(((Bignum)obj).value) < 0; + if (obj instanceof Ratio) + { + BigInteger n = value.multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) < 0; + } + if (obj instanceof SingleFloat) + return isLessThan(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isLessThan(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value.compareTo(Fixnum.getBigInteger(obj)) > 0; + if (obj instanceof Bignum) + return value.compareTo(((Bignum)obj).value) > 0; + if (obj instanceof Ratio) + { + BigInteger n = value.multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) > 0; + } + if (obj instanceof SingleFloat) + return isGreaterThan(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isGreaterThan(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isLessThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value.compareTo(Fixnum.getBigInteger(obj)) <= 0; + if (obj instanceof Bignum) + return value.compareTo(((Bignum)obj).value) <= 0; + if (obj instanceof Ratio) + { + BigInteger n = value.multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) <= 0; + } + if (obj instanceof SingleFloat) + return isLessThanOrEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isLessThanOrEqualTo(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value.compareTo(Fixnum.getBigInteger(obj)) >= 0; + if (obj instanceof Bignum) + return value.compareTo(((Bignum)obj).value) >= 0; + if (obj instanceof Ratio) + { + BigInteger n = value.multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) >= 0; + } + if (obj instanceof SingleFloat) + return isGreaterThanOrEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isGreaterThanOrEqualTo(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public LispObject truncate(LispObject obj) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject value1, value2; + try + { + if (obj instanceof Fixnum) + { + BigInteger divisor = ((Fixnum)obj).getBigInteger(); + BigInteger[] results = value.divideAndRemainder(divisor); + BigInteger quotient = results[0]; + BigInteger remainder = results[1]; + value1 = number(quotient); + value2 = (remainder.signum() == 0) ? Fixnum.ZERO : number(remainder); + } + else if (obj instanceof Bignum) + { + BigInteger divisor = ((Bignum)obj).value; + BigInteger[] results = value.divideAndRemainder(divisor); + BigInteger quotient = results[0]; + BigInteger remainder = results[1]; + value1 = number(quotient); + value2 = (remainder.signum() == 0) ? Fixnum.ZERO : number(remainder); + } + else if (obj instanceof Ratio) + { + Ratio divisor = (Ratio) obj; + LispObject quotient = + multiplyBy(divisor.DENOMINATOR()).truncate(divisor.NUMERATOR()); + LispObject remainder = + subtract(quotient.multiplyBy(divisor)); + value1 = quotient; + value2 = remainder; + } + else if (obj instanceof SingleFloat) + { + // "When rationals and floats are combined by a numerical + // function, the rational is first converted to a float of the + // same format." 12.1.4.1 + return new SingleFloat(floatValue()).truncate(obj); + } + else if (obj instanceof DoubleFloat) + { + // "When rationals and floats are combined by a numerical + // function, the rational is first converted to a float of the + // same format." 12.1.4.1 + return new DoubleFloat(doubleValue()).truncate(obj); + } + else + return type_error(obj, Symbol.REAL); + } + catch (ArithmeticException e) + { + if (obj.zerop()) + return error(new DivisionByZero()); + else + return error(new ArithmeticError(e.getMessage())); + } + return thread.setValues(value1, value2); + } + + @Override + public LispObject ash(LispObject obj) throws ConditionThrowable + { + BigInteger n = value; + if (obj instanceof Fixnum) + { + int count = ((Fixnum)obj).value; + if (count == 0) + return this; + // BigInteger.shiftLeft() succumbs to a stack overflow if count + // is Integer.MIN_VALUE, so... + if (count == Integer.MIN_VALUE) + return n.signum() >= 0 ? Fixnum.ZERO : Fixnum.MINUS_ONE; + return number(n.shiftLeft(count)); + } + if (obj instanceof Bignum) + { + BigInteger count = ((Bignum)obj).value; + if (count.signum() > 0) + return error(new LispError("Can't represent result of left shift.")); + if (count.signum() < 0) + return n.signum() >= 0 ? Fixnum.ZERO : Fixnum.MINUS_ONE; + Debug.bug(); // Shouldn't happen. + } + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LOGNOT() + { + return number(value.not()); + } + + @Override + public LispObject LOGAND(int n) throws ConditionThrowable + { + if (n >= 0) + return new Fixnum(value.intValue() & n); + else + return number(value.and(BigInteger.valueOf(n))); + } + + @Override + public LispObject LOGAND(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + { + int n = ((Fixnum)obj).value; + if (n >= 0) + return new Fixnum(value.intValue() & n); + else + return number(value.and(BigInteger.valueOf(n))); + } + else if (obj instanceof Bignum) + { + final BigInteger n = ((Bignum)obj).value; + return number(value.and(n)); + } + else + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LOGIOR(int n) throws ConditionThrowable + { + return number(value.or(BigInteger.valueOf(n))); + } + + @Override + public LispObject LOGIOR(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + { + final BigInteger n = ((Fixnum)obj).getBigInteger(); + return number(value.or(n)); + } + else if (obj instanceof Bignum) + { + final BigInteger n = ((Bignum)obj).value; + return number(value.or(n)); + } + else + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LOGXOR(int n) throws ConditionThrowable + { + return number(value.xor(BigInteger.valueOf(n))); + } + + @Override + public LispObject LOGXOR(LispObject obj) throws ConditionThrowable + { + final BigInteger n; + if (obj instanceof Fixnum) + n = ((Fixnum)obj).getBigInteger(); + else if (obj instanceof Bignum) + n = ((Bignum)obj).value; + else + return type_error(obj, Symbol.INTEGER); + return number(value.xor(n)); + } + + @Override + public LispObject LDB(int size, int position) + { + BigInteger n = value.shiftRight(position); + BigInteger mask = BigInteger.ONE.shiftLeft(size).subtract(BigInteger.ONE); + return number(n.and(mask)); + } + + @Override + public int hashCode() + { + return value.hashCode(); + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); + String s = value.toString(base).toUpperCase(); + if (Symbol.PRINT_RADIX.symbolValue(thread) != NIL) + { + StringBuffer sb = new StringBuffer(); + switch (base) + { + case 2: + sb.append("#b"); + sb.append(s); + break; + case 8: + sb.append("#o"); + sb.append(s); + break; + case 10: + sb.append(s); + sb.append('.'); + break; + case 16: + sb.append("#x"); + sb.append(s); + break; + default: + sb.append('#'); + sb.append(String.valueOf(base)); + sb.append('r'); + sb.append(s); + break; + } + s = sb.toString(); + } + return s; + } +} Added: branches/save-image/src/org/armedbear/lisp/Binding.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Binding.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +/* + * Binding.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Binding.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// Package accessibility. +final class Binding implements java.io.Serializable +{ + final LispObject symbol; + LispObject value; + boolean specialp; + final Binding next; + + Binding(LispObject symbol, LispObject value, Binding next) + { + this.symbol = symbol; + this.value = value; + this.next = next; + } +} Added: branches/save-image/src/org/armedbear/lisp/BroadcastStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/BroadcastStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,273 @@ +/* + * BroadcastStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: BroadcastStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class BroadcastStream extends Stream +{ + private final Stream[] streams; + + private BroadcastStream(Stream[] streams) throws ConditionThrowable + { + this.streams = streams; + isOutputStream = true; + if (streams.length == 0) { + elementType = T; + isBinaryStream = true; + isCharacterStream = true; + } else { + elementType = streams[streams.length-1].getElementType(); + if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) + isCharacterStream = true; + else + isBinaryStream = true; + } + } + + public Stream[] getStreams() + { + return streams; + } + + @Override + public LispObject typeOf() + { + return Symbol.BROADCAST_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.BROADCAST_STREAM; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.BROADCAST_STREAM) + return T; + if (typeSpecifier == BuiltInClass.BROADCAST_STREAM) + return T; + return super.typep(typeSpecifier); + } + + @Override + public LispObject listen() throws ConditionThrowable + { + notSupported(); + // Not reached. + return NIL; + } + + @Override + public LispObject fileLength() throws ConditionThrowable + { + if (streams.length > 0) + return streams[streams.length - 1].fileLength(); + else + return Fixnum.ZERO; + } + + @Override + public LispObject fileStringLength(LispObject arg) throws ConditionThrowable + { + if (streams.length > 0) + return streams[streams.length - 1].fileStringLength(arg); + else + return Fixnum.ONE; + } + + // Returns -1 at end of file. + @Override + protected int _readChar() throws ConditionThrowable + { + notSupported(); + // Not reached. + return -1; + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + notSupported(); + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + notSupported(); + // Not reached. + return false; + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + for (int i = 0; i < streams.length; i++) + streams[i]._writeChar(c); + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + for (int i = 0; i < streams.length; i++) + streams[i]._writeChars(chars, start, end); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + for (int i = 0; i < streams.length; i++) + streams[i]._writeString(s); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + for (int i = 0; i < streams.length; i++) + streams[i]._writeLine(s); + } + + // Reads an 8-bit byte. + @Override + public int _readByte() throws ConditionThrowable + { + notSupported(); + // Not reached. + return -1; + } + + // Writes an 8-bit byte. + @Override + public void _writeByte(int n) throws ConditionThrowable + { + for (int i = 0; i < streams.length; i++) + streams[i]._writeByte(n); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + for (int i = 0; i < streams.length; i++) + streams[i]._finishOutput(); + } + + @Override + public void _clearInput() throws ConditionThrowable + { + notSupported(); + } + + @Override + protected long _getFilePosition() throws ConditionThrowable + { + if (streams.length == 0) + return 0; + else + return streams[streams.length-1]._getFilePosition(); + } + + @Override + protected boolean _setFilePosition(LispObject arg) throws ConditionThrowable + { + return false; + } + + @Override + public void _close() throws ConditionThrowable + { + setOpen(false); + } + + private void notSupported() throws ConditionThrowable + { + error(new TypeError("Operation is not supported for streams of type BROADCAST-STREAM.")); + } + + @Override + public String writeToString() + { + return unreadableString("BROADCAST-STREAM"); + } + + // ### make-broadcast-stream &rest streams => broadcast-stream + private static final Primitive MAKE_BROADCAST_STREAM = + new Primitive("make-broadcast-stream", "&rest streams") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new BroadcastStream(new Stream[0]); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + Stream[] streams = new Stream[args.length]; + for (int i = 0; i < args.length; i++) { + if (args[i] instanceof Stream) { + if (((Stream)args[i]).isOutputStream()) { + streams[i] = (Stream) args[i]; + continue; + } else + return error(new TypeError(args[i], list2(Symbol.SATISFIES, + Symbol.OUTPUT_STREAM_P))); + } else + return error(new TypeError(args[i], Symbol.STREAM)); + } + // All is well. + return new BroadcastStream(streams); + } + }; + + // ### broadcast-stream-streams broadcast-stream => streams + private static final Primitive BROADCAST_STREAM_STREAMS = + new Primitive("broadcast-stream-streams", "broadcast-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + BroadcastStream stream = (BroadcastStream) arg; + Stream[] streams = stream.streams; + LispObject result = NIL; + for (int i = streams.length; i-- > 0;) + result = new Cons(streams[i], result); + return result; + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.BROADCAST_STREAM)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/BuiltInClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,291 @@ +/* + * BuiltInClass.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: BuiltInClass.java 11587 2009-01-24 20:38:24Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class BuiltInClass extends LispClass +{ + private BuiltInClass(Symbol symbol) + { + super(symbol); + } + + @Override + public LispObject typeOf() + { + return Symbol.BUILT_IN_CLASS; + } + + @Override + public LispObject classOf() + { + return StandardClass.BUILT_IN_CLASS; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.BUILT_IN_CLASS) + return T; + if (type == StandardClass.BUILT_IN_CLASS) + return T; + return super.typep(type); + } + + @Override + public LispObject getDescription() throws ConditionThrowable + { + return new SimpleString(writeToString()); + } + + @Override + public String writeToString() throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("#'); + return sb.toString(); + } + + private static BuiltInClass addClass(Symbol symbol) + { + BuiltInClass c = new BuiltInClass(symbol); + addClass(symbol, c); + return c; + } + + public static final BuiltInClass CLASS_T = addClass(T); + + public static final BuiltInClass ARRAY = addClass(Symbol.ARRAY); + public static final BuiltInClass BIGNUM = addClass(Symbol.BIGNUM); + public static final BuiltInClass BASE_STRING = addClass(Symbol.BASE_STRING); + public static final BuiltInClass BIT_VECTOR = addClass(Symbol.BIT_VECTOR); + public static final BuiltInClass BROADCAST_STREAM = addClass(Symbol.BROADCAST_STREAM); + public static final BuiltInClass CASE_FROB_STREAM = addClass(Symbol.CASE_FROB_STREAM); + public static final BuiltInClass CHARACTER = addClass(Symbol.CHARACTER); + public static final BuiltInClass COMPLEX = addClass(Symbol.COMPLEX); + public static final BuiltInClass CONCATENATED_STREAM = addClass(Symbol.CONCATENATED_STREAM); + public static final BuiltInClass CONS = addClass(Symbol.CONS); + public static final BuiltInClass DOUBLE_FLOAT = addClass(Symbol.DOUBLE_FLOAT); + public static final BuiltInClass ECHO_STREAM = addClass(Symbol.ECHO_STREAM); + public static final BuiltInClass ENVIRONMENT = addClass(Symbol.ENVIRONMENT); + public static final BuiltInClass FILE_STREAM = addClass(Symbol.FILE_STREAM); + public static final BuiltInClass FIXNUM = addClass(Symbol.FIXNUM); + public static final BuiltInClass FLOAT = addClass(Symbol.FLOAT); + public static final BuiltInClass FUNCTION = addClass(Symbol.FUNCTION); + public static final BuiltInClass HASH_TABLE = addClass(Symbol.HASH_TABLE); + public static final BuiltInClass INTEGER = addClass(Symbol.INTEGER); + public static final BuiltInClass JAVA_OBJECT = addClass(Symbol.JAVA_OBJECT); + public static final BuiltInClass LIST = addClass(Symbol.LIST); + public static final BuiltInClass LOGICAL_PATHNAME = addClass(Symbol.LOGICAL_PATHNAME); + public static final BuiltInClass MAILBOX = addClass(Symbol.MAILBOX); + public static final BuiltInClass METHOD_COMBINATION = addClass(Symbol.METHOD_COMBINATION); + public static final BuiltInClass MUTEX = addClass(Symbol.MUTEX); + public static final BuiltInClass NIL_VECTOR = addClass(Symbol.NIL_VECTOR); + public static final BuiltInClass NULL = addClass(Symbol.NULL); + public static final BuiltInClass NUMBER = addClass(Symbol.NUMBER); + public static final BuiltInClass PACKAGE = addClass(Symbol.PACKAGE); + public static final BuiltInClass PATHNAME = addClass(Symbol.PATHNAME); + public static final BuiltInClass RANDOM_STATE = addClass(Symbol.RANDOM_STATE); + public static final BuiltInClass RATIO = addClass(Symbol.RATIO); + public static final BuiltInClass RATIONAL = addClass(Symbol.RATIONAL); + public static final BuiltInClass READTABLE = addClass(Symbol.READTABLE); + public static final BuiltInClass REAL = addClass(Symbol.REAL); + public static final BuiltInClass RESTART = addClass(Symbol.RESTART); + public static final BuiltInClass SEQUENCE = addClass(Symbol.SEQUENCE); + public static final BuiltInClass SIMPLE_ARRAY = addClass(Symbol.SIMPLE_ARRAY); + public static final BuiltInClass SIMPLE_BASE_STRING = addClass(Symbol.SIMPLE_BASE_STRING); + public static final BuiltInClass SIMPLE_BIT_VECTOR = addClass(Symbol.SIMPLE_BIT_VECTOR); + public static final BuiltInClass SIMPLE_STRING = addClass(Symbol.SIMPLE_STRING); + public static final BuiltInClass SIMPLE_VECTOR = addClass(Symbol.SIMPLE_VECTOR); + public static final BuiltInClass SINGLE_FLOAT = addClass(Symbol.SINGLE_FLOAT); + public static final BuiltInClass SLIME_INPUT_STREAM = addClass(Symbol.SLIME_INPUT_STREAM); + public static final BuiltInClass SLIME_OUTPUT_STREAM = addClass(Symbol.SLIME_OUTPUT_STREAM); + public static final BuiltInClass SOCKET_STREAM = addClass(Symbol.SOCKET_STREAM); + public static final BuiltInClass STREAM = addClass(Symbol.STREAM); + public static final BuiltInClass STRING = addClass(Symbol.STRING); + public static final BuiltInClass STRING_INPUT_STREAM = addClass(Symbol.STRING_INPUT_STREAM); + public static final BuiltInClass STRING_OUTPUT_STREAM = addClass(Symbol.STRING_OUTPUT_STREAM); + public static final BuiltInClass STRING_STREAM = addClass(Symbol.STRING_STREAM); + public static final BuiltInClass SYMBOL = addClass(Symbol.SYMBOL); + public static final BuiltInClass SYNONYM_STREAM = addClass(Symbol.SYNONYM_STREAM); + public static final BuiltInClass THREAD = addClass(Symbol.THREAD); + public static final BuiltInClass TWO_WAY_STREAM = addClass(Symbol.TWO_WAY_STREAM); + public static final BuiltInClass VECTOR = addClass(Symbol.VECTOR); + + public static final StructureClass STRUCTURE_OBJECT = + new StructureClass(Symbol.STRUCTURE_OBJECT, list1(CLASS_T)); + static + { + addClass(Symbol.STRUCTURE_OBJECT, STRUCTURE_OBJECT); + } + + static + { + ARRAY.setDirectSuperclass(CLASS_T); + ARRAY.setCPL(ARRAY, CLASS_T); + BASE_STRING.setDirectSuperclass(STRING); + BASE_STRING.setCPL(BASE_STRING, STRING, VECTOR, ARRAY, SEQUENCE, CLASS_T); + BIGNUM.setDirectSuperclass(INTEGER); + BIGNUM.setCPL(BIGNUM, INTEGER, RATIONAL, REAL, NUMBER, CLASS_T); + BIT_VECTOR.setDirectSuperclass(VECTOR); + BIT_VECTOR.setCPL(BIT_VECTOR, VECTOR, ARRAY, SEQUENCE, CLASS_T); + BROADCAST_STREAM.setDirectSuperclass(STREAM); + BROADCAST_STREAM.setCPL(BROADCAST_STREAM, STREAM, CLASS_T); + CASE_FROB_STREAM.setDirectSuperclass(STREAM); + CASE_FROB_STREAM.setCPL(CASE_FROB_STREAM, STREAM, CLASS_T); + CHARACTER.setDirectSuperclass(CLASS_T); + CHARACTER.setCPL(CHARACTER, CLASS_T); + CLASS_T.setCPL(CLASS_T); + COMPLEX.setDirectSuperclass(NUMBER); + COMPLEX.setCPL(COMPLEX, NUMBER, CLASS_T); + CONCATENATED_STREAM.setDirectSuperclass(STREAM); + CONCATENATED_STREAM.setCPL(CONCATENATED_STREAM, STREAM, CLASS_T); + CONS.setDirectSuperclass(LIST); + CONS.setCPL(CONS, LIST, SEQUENCE, CLASS_T); + DOUBLE_FLOAT.setDirectSuperclass(FLOAT); + DOUBLE_FLOAT.setCPL(DOUBLE_FLOAT, FLOAT, REAL, NUMBER, CLASS_T); + ECHO_STREAM.setDirectSuperclass(STREAM); + ECHO_STREAM.setCPL(ECHO_STREAM, STREAM, CLASS_T); + ENVIRONMENT.setDirectSuperclass(CLASS_T); + ENVIRONMENT.setCPL(ENVIRONMENT, CLASS_T); + FIXNUM.setDirectSuperclass(INTEGER); + FIXNUM.setCPL(FIXNUM, INTEGER, RATIONAL, REAL, NUMBER, CLASS_T); + FILE_STREAM.setDirectSuperclass(STREAM); + FILE_STREAM.setCPL(FILE_STREAM, STREAM, CLASS_T); + FLOAT.setDirectSuperclass(REAL); + FLOAT.setCPL(FLOAT, REAL, NUMBER, CLASS_T); + FUNCTION.setDirectSuperclass(CLASS_T); + FUNCTION.setCPL(FUNCTION, CLASS_T); + HASH_TABLE.setDirectSuperclass(CLASS_T); + HASH_TABLE.setCPL(HASH_TABLE, CLASS_T); + INTEGER.setDirectSuperclass(RATIONAL); + INTEGER.setCPL(INTEGER, RATIONAL, REAL, NUMBER, CLASS_T); + JAVA_OBJECT.setDirectSuperclass(CLASS_T); + JAVA_OBJECT.setCPL(JAVA_OBJECT, CLASS_T); + LIST.setDirectSuperclass(SEQUENCE); + LIST.setCPL(LIST, SEQUENCE, CLASS_T); + LOGICAL_PATHNAME.setDirectSuperclass(PATHNAME); + LOGICAL_PATHNAME.setCPL(LOGICAL_PATHNAME, PATHNAME, CLASS_T); + MAILBOX.setDirectSuperclass(CLASS_T); + MAILBOX.setCPL(MAILBOX, CLASS_T); + METHOD_COMBINATION.setDirectSuperclass(CLASS_T); + METHOD_COMBINATION.setCPL(METHOD_COMBINATION, CLASS_T); + MUTEX.setDirectSuperclass(CLASS_T); + MUTEX.setCPL(MUTEX, CLASS_T); + NIL_VECTOR.setDirectSuperclass(STRING); + NIL_VECTOR.setCPL(NIL_VECTOR, STRING, VECTOR, ARRAY, SEQUENCE, CLASS_T); + NULL.setDirectSuperclass(LIST); + NULL.setCPL(NULL, SYMBOL, LIST, SEQUENCE, CLASS_T); + NUMBER.setDirectSuperclass(CLASS_T); + NUMBER.setCPL(NUMBER, CLASS_T); + PACKAGE.setDirectSuperclass(CLASS_T); + PACKAGE.setCPL(PACKAGE, CLASS_T); + PATHNAME.setDirectSuperclass(CLASS_T); + PATHNAME.setCPL(PATHNAME, CLASS_T); + RANDOM_STATE.setDirectSuperclass(CLASS_T); + RANDOM_STATE.setCPL(RANDOM_STATE, CLASS_T); + RATIO.setDirectSuperclass(RATIONAL); + RATIO.setCPL(RATIO, RATIONAL, REAL, NUMBER, CLASS_T); + RATIONAL.setDirectSuperclass(REAL); + RATIONAL.setCPL(RATIONAL, REAL, NUMBER, CLASS_T); + READTABLE.setDirectSuperclass(CLASS_T); + READTABLE.setCPL(READTABLE, CLASS_T); + REAL.setDirectSuperclass(NUMBER); + REAL.setCPL(REAL, NUMBER, CLASS_T); + RESTART.setDirectSuperclass(CLASS_T); + RESTART.setCPL(RESTART, CLASS_T); + SEQUENCE.setDirectSuperclass(CLASS_T); + SEQUENCE.setCPL(SEQUENCE, CLASS_T); + SIMPLE_ARRAY.setDirectSuperclass(ARRAY); + SIMPLE_ARRAY.setCPL(SIMPLE_ARRAY, ARRAY, CLASS_T); + SIMPLE_BASE_STRING.setDirectSuperclasses(list2(BASE_STRING, SIMPLE_STRING)); + SIMPLE_BASE_STRING.setCPL(SIMPLE_BASE_STRING, BASE_STRING, SIMPLE_STRING, + STRING, VECTOR, SIMPLE_ARRAY, ARRAY, SEQUENCE, + CLASS_T); + SIMPLE_BIT_VECTOR.setDirectSuperclasses(list2(BIT_VECTOR, SIMPLE_ARRAY)); + SIMPLE_BIT_VECTOR.setCPL(SIMPLE_BIT_VECTOR, BIT_VECTOR, VECTOR, + SIMPLE_ARRAY, ARRAY, SEQUENCE, CLASS_T); + SIMPLE_STRING.setDirectSuperclasses(list3(BASE_STRING, STRING, SIMPLE_ARRAY)); + SIMPLE_STRING.setCPL(SIMPLE_STRING, BASE_STRING, STRING, VECTOR, + SIMPLE_ARRAY, ARRAY, SEQUENCE, CLASS_T); + SIMPLE_VECTOR.setDirectSuperclasses(list2(VECTOR, SIMPLE_ARRAY)); + SIMPLE_VECTOR.setCPL(SIMPLE_VECTOR, VECTOR, SIMPLE_ARRAY, ARRAY, SEQUENCE, + CLASS_T); + SINGLE_FLOAT.setDirectSuperclass(FLOAT); + SINGLE_FLOAT.setCPL(SINGLE_FLOAT, FLOAT, REAL, NUMBER, CLASS_T); + SLIME_INPUT_STREAM.setDirectSuperclass(STRING_STREAM); + SLIME_INPUT_STREAM.setCPL(SLIME_INPUT_STREAM, STRING_STREAM, STREAM, + CLASS_T); + SLIME_OUTPUT_STREAM.setDirectSuperclass(STRING_STREAM); + SLIME_OUTPUT_STREAM.setCPL(SLIME_OUTPUT_STREAM, STRING_STREAM, STREAM, + CLASS_T); + SOCKET_STREAM.setDirectSuperclass(TWO_WAY_STREAM); + SOCKET_STREAM.setCPL(SOCKET_STREAM, TWO_WAY_STREAM, STREAM, CLASS_T); + STREAM.setDirectSuperclass(CLASS_T); + STREAM.setCPL(STREAM, CLASS_T); + STRING.setDirectSuperclass(VECTOR); + STRING.setCPL(STRING, VECTOR, ARRAY, SEQUENCE, CLASS_T); + STRING_INPUT_STREAM.setDirectSuperclass(STRING_STREAM); + STRING_INPUT_STREAM.setCPL(STRING_INPUT_STREAM, STRING_STREAM, STREAM, + CLASS_T); + STRING_OUTPUT_STREAM.setDirectSuperclass(STRING_STREAM); + STRING_OUTPUT_STREAM.setCPL(STRING_OUTPUT_STREAM, STRING_STREAM, STREAM, + CLASS_T); + STRING_STREAM.setDirectSuperclass(STREAM); + STRING_STREAM.setCPL(STRING_STREAM, STREAM, CLASS_T); + STRUCTURE_OBJECT.setCPL(STRUCTURE_OBJECT, CLASS_T); + SYMBOL.setDirectSuperclass(CLASS_T); + SYMBOL.setCPL(SYMBOL, CLASS_T); + SYNONYM_STREAM.setDirectSuperclass(STREAM); + SYNONYM_STREAM.setCPL(SYNONYM_STREAM, STREAM, CLASS_T); + THREAD.setDirectSuperclass(CLASS_T); + THREAD.setCPL(THREAD, CLASS_T); + TWO_WAY_STREAM.setDirectSuperclass(STREAM); + TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, STREAM, CLASS_T); + VECTOR.setDirectSuperclasses(list2(ARRAY, SEQUENCE)); + VECTOR.setCPL(VECTOR, ARRAY, SEQUENCE, CLASS_T); + } + + static + { + try + { + StandardClass.initializeStandardClasses(); + } + catch (Throwable t) + { + Debug.trace(t); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/CapitalizeFirstStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CapitalizeFirstStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,72 @@ +/* + * CapitalizeFirstStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: CapitalizeFirstStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class CapitalizeFirstStream extends CaseFrobStream +{ + boolean virgin = true; + + public CapitalizeFirstStream(Stream target) throws ConditionThrowable + { + super(target); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + if (virgin) { + if (Character.isLetterOrDigit(c)) { + c = LispCharacter.toUpperCase(c); + virgin = false; + } + } else + c = LispCharacter.toLowerCase(c); + target._writeChar(c); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + final int length = s.length(); + for (int i = 0; i < length; i++) + _writeChar(s.charAt(i)); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + _writeString(s); + _writeChar('\n'); + } +} Added: branches/save-image/src/org/armedbear/lisp/CapitalizeStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CapitalizeStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,82 @@ +/* + * CapitalizeStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: CapitalizeStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class CapitalizeStream extends CaseFrobStream +{ + private boolean inWord; + + public CapitalizeStream(Stream target) throws ConditionThrowable + { + super(target); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + if (inWord) { + if (Character.isUpperCase(c)) { + c = LispCharacter.toLowerCase(c); + } else if (!Character.isLowerCase(c) && !Character.isDigit(c)) { + inWord = false; + } + } else { + // Not in a word. + if (Character.isUpperCase(c)) { + inWord = true; + } else if (Character.isLowerCase(c)) { + c = LispCharacter.toUpperCase(c); + inWord = true; + } else if (Character.isDigit(c)) { + inWord = true; + } + } + target._writeChar(c); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + final int limit = s.length(); + for (int i = 0; i < limit; i++) + _writeChar(s.charAt(i)); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + target._writeString(s); + target._writeChar('\n'); + } +} Added: branches/save-image/src/org/armedbear/lisp/CaseFrobStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CaseFrobStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,240 @@ +/* + * CaseFrobStream.java + * + * Copyright (C) 2004 Peter Graves + * $Id: CaseFrobStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class CaseFrobStream extends Stream +{ + protected final Stream target; + + protected CaseFrobStream(Stream target) + throws ConditionThrowable + { + Debug.assertTrue(target.isCharacterOutputStream()); + this.target = target; + } + + @Override + public LispObject getElementType() throws ConditionThrowable + { + return target.getElementType(); + } + + @Override + public LispObject typeOf() + { + return Symbol.CASE_FROB_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.CASE_FROB_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.CASE_FROB_STREAM) + return T; + if (type == BuiltInClass.CASE_FROB_STREAM) + return T; + return super.typep(type); + } + + @Override + public boolean isInputStream() + { + return false; + } + + @Override + public boolean isOutputStream() + { + return true; + } + + @Override + public boolean isCharacterInputStream() throws ConditionThrowable + { + return false; + } + + @Override + public boolean isBinaryInputStream() throws ConditionThrowable + { + return false; + } + + @Override + public boolean isCharacterOutputStream() throws ConditionThrowable + { + return true; + } + + @Override + public boolean isBinaryOutputStream() throws ConditionThrowable + { + return false; + } + + @Override + public int getCharPos() + { + return target.getCharPos(); + } + + @Override + public void setCharPos(int n) + { + target.setCharPos(n); + } + + // Returns -1 at end of file. + @Override + protected int _readChar() throws ConditionThrowable + { + notSupported(); + // Not reached. + return -1; + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + notSupported(); + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + notSupported(); + // Not reached. + return false; + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + _writeString(new String(chars, start, end)); + } + + // Reads an 8-bit byte. + @Override + public int _readByte() throws ConditionThrowable + { + notSupported(); + // Not reached. + return -1; + } + + // Writes an 8-bit byte. + @Override + public void _writeByte(int n) throws ConditionThrowable + { + notSupported(); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + target._finishOutput(); + } + + @Override + public void _clearInput() throws ConditionThrowable + { + notSupported(); + } + + @Override + public LispObject close(LispObject abort) throws ConditionThrowable + { + setOpen(false); + return T; + } + + @Override + public LispObject listen() throws ConditionThrowable + { + notSupported(); + // Not reached. + return NIL; + } + + @Override + public LispObject terpri() throws ConditionThrowable + { + return target.terpri(); + } + + @Override + public LispObject freshLine() throws ConditionThrowable + { + return target.freshLine(); + } + + @Override + public String writeToString() + { + return unreadableString("CASE-FROB-STREAM"); + } + + private void notSupported() throws ConditionThrowable + { + error(new TypeError("Operation is not supported for streams of type CASE-FROB-STREAM.")); + } + + // ### make-case-frob-stream target => case-frob-stream + private static final Primitive MAKE_CASE_FROB_STREAM = + new Primitive("make-case-frob-stream", PACKAGE_SYS, false, "target kind") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Stream target = checkCharacterOutputStream(first); + if (second == Keyword.UPCASE) + return new UpcaseStream(target); + if (second == Keyword.DOWNCASE) + return new DowncaseStream(target); + if (second == Keyword.CAPITALIZE) + return new CapitalizeStream(target); + if (second == Keyword.CAPITALIZE_FIRST) + return new CapitalizeFirstStream(target); + return error(new TypeError( + "Kind must be :UPCASE, :DOWNCASE, :CAPITALIZE or :CAPITALIZE-FIRST.")); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/CellError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CellError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,108 @@ +/* + * CellError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: CellError.java 11539 2009-01-04 14:27:54Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class CellError extends LispError +{ + protected CellError(LispClass cls) throws ConditionThrowable + { + super(cls); + } + + public CellError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.CELL_ERROR); + initialize(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + LispObject name = NIL; + while (initArgs != NIL) { + LispObject first = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.NAME) { + name = initArgs.car(); + break; + } + initArgs = initArgs.cdr(); + } + setCellName(name); + } + + public final LispObject getCellName() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.NAME); + } + + protected final void setCellName(LispObject name) throws ConditionThrowable + { + setInstanceSlotValue(Symbol.NAME, name); + } + + @Override + public LispObject typeOf() + { + return Symbol.CELL_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.CELL_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.CELL_ERROR) + return T; + if (type == StandardClass.CELL_ERROR) + return T; + return super.typep(type); + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (Symbol.PRINT_ESCAPE.symbolValue() == NIL) + return super.writeToString(); + StringBuffer sb = new StringBuffer(typeOf().writeToString()); + sb.append(' '); + sb.append(getCellName().writeToString()); + return unreadableString(sb.toString()); + } +} Added: branches/save-image/src/org/armedbear/lisp/CharacterFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CharacterFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,427 @@ +/* + * CharacterFunctions.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: CharacterFunctions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class CharacterFunctions extends Lisp +{ + // ### char= + private static final Primitive CHAR_EQUALS = + new Primitive("char=", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + return ((LispCharacter)first).value == ((LispCharacter)second).value ? T : NIL; + } + catch (ClassCastException e) { + LispObject datum; + if (first instanceof LispCharacter) + datum = second; + else + datum = first; + return type_error(datum, Symbol.CHARACTER); + } + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + final char c0 = LispCharacter.getValue(array[0]); + for (int i = 1; i < length; i++) { + if (c0 != LispCharacter.getValue(array[i])) + return NIL; + } + return T; + } + }; + + // ### char-equal + private static final Primitive CHAR_EQUAL = + new Primitive("char-equal", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final char c1, c2; + try { + c1 = ((LispCharacter)first).value; + } + catch (ClassCastException e) { + return type_error(first, Symbol.CHARACTER); + } + try { + c2 = ((LispCharacter)second).value; + } + catch (ClassCastException e) { + return type_error(second, Symbol.CHARACTER); + } + if (c1 == c2) + return T; + if (LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2)) + return T; + if (LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) + return T; + return NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + final char c0 = LispCharacter.getValue(array[0]); + for (int i = 1; i < length; i++) { + char c = LispCharacter.getValue(array[i]); + if (c0 == c) + continue; + if (LispCharacter.toUpperCase(c0) == LispCharacter.toUpperCase(c)) + continue; + if (LispCharacter.toLowerCase(c0) == LispCharacter.toLowerCase(c)) + continue; + return NIL; + } + return T; + } + }; + + // ### char-greaterp + private static final Primitive CHAR_GREATERP = + new Primitive("char-greaterp", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char c1 = LispCharacter.toUpperCase(LispCharacter.getValue(first)); + char c2 = LispCharacter.toUpperCase(LispCharacter.getValue(second)); + return c1 > c2 ? T : NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + char[] chars = new char[length]; + for (int i = 0; i < length; i++) + chars[i] = LispCharacter.toUpperCase(LispCharacter.getValue(array[i])); + for (int i = 1; i < length; i++) { + if (chars[i-1] <= chars[i]) + return NIL; + } + return T; + } + }; + + // ### char-not-greaterp + private static final Primitive CHAR_NOT_GREATERP = + new Primitive("char-not-greaterp", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char c1 = LispCharacter.toUpperCase(LispCharacter.getValue(first)); + char c2 = LispCharacter.toUpperCase(LispCharacter.getValue(second)); + return c1 <= c2 ? T : NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + char[] chars = new char[length]; + for (int i = 0; i < length; i++) + chars[i] = LispCharacter.toUpperCase(LispCharacter.getValue(array[i])); + for (int i = 1; i < length; i++) { + if (chars[i] < chars[i-1]) + return NIL; + } + return T; + } + }; + + // ### char< + private static final Primitive CHAR_LESS_THAN = + new Primitive("char<", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + return ((LispCharacter)first).value < ((LispCharacter)second).value ? T : NIL; + } + catch (ClassCastException e) { + LispObject datum; + if (first instanceof LispCharacter) + datum = second; + else + datum = first; + return type_error(datum, Symbol.CHARACTER); + } + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final int length = args.length; + char[] chars = new char[length]; + for (int i = 0; i < length; i++) { + try { + chars[i] = ((LispCharacter)args[i]).value; + } + catch (ClassCastException e) { + return type_error(args[i], Symbol.CHARACTER); + } + } + for (int i = 1; i < length; i++) { + if (chars[i-1] >= chars[i]) + return NIL; + } + return T; + } + }; + + // ### char<= + private static final Primitive CHAR_LE = + new Primitive("char<=", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + return ((LispCharacter)first).value <= ((LispCharacter)second).value ? T : NIL; + } + catch (ClassCastException e) { + LispObject datum; + if (first instanceof LispCharacter) + datum = second; + else + datum = first; + return type_error(datum, Symbol.CHARACTER); + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try { + if (((LispCharacter)first).value > ((LispCharacter)second).value) + return NIL; + if (((LispCharacter)second).value > ((LispCharacter)third).value) + return NIL; + return T; + } + catch (ClassCastException e) { + LispObject datum; + if (!(first instanceof LispCharacter)) + datum = first; + else if (!(second instanceof LispCharacter)) + datum = second; + else + datum = third; + return type_error(datum, Symbol.CHARACTER); + } + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final int length = args.length; + char[] chars = new char[length]; + for (int i = 0; i < length; i++) { + try { + chars[i] = ((LispCharacter)args[i]).value; + } + catch (ClassCastException e) { + return type_error(args[i], Symbol.CHARACTER); + } + } + for (int i = 1; i < length; i++) { + if (chars[i-1] > chars[i]) + return NIL; + } + return T; + } + }; + + // ### char-lessp + private static final Primitive CHAR_LESSP = + new Primitive("char-lessp", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char c1 = LispCharacter.toUpperCase(LispCharacter.getValue(first)); + char c2 = LispCharacter.toUpperCase(LispCharacter.getValue(second)); + return c1 < c2 ? T : NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + char[] chars = new char[length]; + for (int i = 0; i < length; i++) + chars[i] = LispCharacter.toUpperCase(LispCharacter.getValue(array[i])); + for (int i = 1; i < length; i++) { + if (chars[i-1] >= chars[i]) + return NIL; + } + return T; + } + }; + + // ### char-not-lessp + private static final Primitive CHAR_NOT_LESSP = + new Primitive("char-not-lessp", "&rest characters") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return T; + return type_error(arg, Symbol.CHARACTER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char c1 = LispCharacter.toUpperCase(LispCharacter.getValue(first)); + char c2 = LispCharacter.toUpperCase(LispCharacter.getValue(second)); + return c1 >= c2 ? T : NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + char[] chars = new char[length]; + for (int i = 0; i < length; i++) + chars[i] = LispCharacter.toUpperCase(LispCharacter.getValue(array[i])); + for (int i = 1; i < length; i++) { + if (chars[i] > chars[i-1]) + return NIL; + } + return T; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Closure.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Closure.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1148 @@ +/* + * Closure.java + * + * Copyright (C) 2002-2008 Peter Graves + * Copyright (C) 2008 Ville Voutilainen + * $Id: Closure.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.ArrayList; + +public class Closure extends Function +{ + // Parameter types. + private static final int REQUIRED = 0; + private static final int OPTIONAL = 1; + private static final int KEYWORD = 2; + private static final int REST = 3; + private static final int AUX = 4; + + // States. + private static final int STATE_REQUIRED = 0; + private static final int STATE_OPTIONAL = 1; + private static final int STATE_KEYWORD = 2; + private static final int STATE_REST = 3; + private static final int STATE_AUX = 4; + + private static final Parameter[] emptyParameterArray; + static + { + emptyParameterArray = new Parameter[0]; + } + private Parameter[] requiredParameters = emptyParameterArray; + private Parameter[] optionalParameters = emptyParameterArray; + private Parameter[] keywordParameters = emptyParameterArray; + private Parameter[] auxVars = emptyParameterArray; + private final LispObject body; + private final Environment environment; + private final boolean andKey; + private final boolean allowOtherKeys; + private Symbol restVar; + private Symbol envVar; + private int arity; + + private int minArgs; + private int maxArgs; + + private static final Symbol[] emptySymbolArray; + static + { + emptySymbolArray = new Symbol[0]; + } + private Symbol[] variables = emptySymbolArray; + private Symbol[] specials = emptySymbolArray; + + private boolean bindInitForms; + + public Closure(LispObject lambdaExpression, Environment env) + throws ConditionThrowable + { + this(null, lambdaExpression, env); + } + + public Closure(final LispObject name, final LispObject lambdaExpression, + final Environment env) + throws ConditionThrowable + { + super(name, lambdaExpression.cadr()); + final LispObject lambdaList = lambdaExpression.cadr(); + setLambdaList(lambdaList); + if (!(lambdaList == NIL || lambdaList instanceof Cons)) + error(new LispError("The lambda list " + lambdaList.writeToString() + + " is invalid.")); + boolean _andKey = false; + boolean _allowOtherKeys = false; + if (lambdaList instanceof Cons) + { + final int length = lambdaList.length(); + ArrayList required = null; + ArrayList optional = null; + ArrayList keywords = null; + ArrayList aux = null; + int state = STATE_REQUIRED; + LispObject remaining = lambdaList; + while (remaining != NIL) + { + LispObject obj = remaining.car(); + if (obj instanceof Symbol) + { + if (state == STATE_AUX) + { + if (aux == null) + aux = new ArrayList(); + aux.add(new Parameter((Symbol)obj, NIL, AUX)); + } + else if (obj == Symbol.AND_OPTIONAL) + { + state = STATE_OPTIONAL; + arity = -1; + } + else if (obj == Symbol.AND_REST || obj == Symbol.AND_BODY) + { + state = STATE_REST; + arity = -1; + maxArgs = -1; + remaining = remaining.cdr(); + if (remaining == NIL) + { + error(new LispError( + "&REST/&BODY must be followed by a variable.")); + } + Debug.assertTrue(restVar == null); + try + { + restVar = (Symbol) remaining.car(); + } + catch (ClassCastException e) + { + error(new LispError( + "&REST/&BODY must be followed by a variable.")); + } + } + else if (obj == Symbol.AND_ENVIRONMENT) + { + remaining = remaining.cdr(); + envVar = (Symbol) remaining.car(); + arity = -1; // FIXME + } + else if (obj == Symbol.AND_KEY) + { + state = STATE_KEYWORD; + _andKey = true; + arity = -1; + } + else if (obj == Symbol.AND_ALLOW_OTHER_KEYS) + { + _allowOtherKeys = true; + maxArgs = -1; + } + else if (obj == Symbol.AND_AUX) + { + // All remaining specifiers are aux variable specifiers. + state = STATE_AUX; + arity = -1; // FIXME + } + else + { + if (state == STATE_OPTIONAL) + { + if (optional == null) + optional = new ArrayList(); + optional.add(new Parameter((Symbol)obj, NIL, OPTIONAL)); + if (maxArgs >= 0) + ++maxArgs; + } + else if (state == STATE_KEYWORD) + { + if (keywords == null) + keywords = new ArrayList(); + keywords.add(new Parameter((Symbol)obj, NIL, KEYWORD)); + if (maxArgs >= 0) + maxArgs += 2; + } + else + { + Debug.assertTrue(state == STATE_REQUIRED); + if (required == null) + required = new ArrayList(); + required.add(new Parameter((Symbol)obj)); + if (maxArgs >= 0) + ++maxArgs; + } + } + } + else if (obj instanceof Cons) + { + if (state == STATE_AUX) + { + Symbol sym = checkSymbol(obj.car()); + LispObject initForm = obj.cadr(); + Debug.assertTrue(initForm != null); + if (aux == null) + aux = new ArrayList(); + aux.add(new Parameter(sym, initForm, AUX)); + } + else if (state == STATE_OPTIONAL) + { + Symbol sym = checkSymbol(obj.car()); + LispObject initForm = obj.cadr(); + LispObject svar = obj.cdr().cdr().car(); + if (optional == null) + optional = new ArrayList(); + optional.add(new Parameter(sym, initForm, svar, OPTIONAL)); + if (maxArgs >= 0) + ++maxArgs; + } + else if (state == STATE_KEYWORD) + { + Symbol keyword; + Symbol var; + LispObject initForm = NIL; + LispObject svar = NIL; + LispObject first = obj.car(); + if (first instanceof Cons) + { + keyword = checkSymbol(first.car()); + var = checkSymbol(first.cadr()); + } + else + { + var = checkSymbol(first); + keyword = + PACKAGE_KEYWORD.intern(var.name); + } + obj = obj.cdr(); + if (obj != NIL) + { + initForm = obj.car(); + obj = obj.cdr(); + if (obj != NIL) + svar = obj.car(); + } + if (keywords == null) + keywords = new ArrayList(); + keywords.add(new Parameter(keyword, var, initForm, svar)); + if (maxArgs >= 0) + maxArgs += 2; + } + else + invalidParameter(obj); + } + else + invalidParameter(obj); + remaining = remaining.cdr(); + } + if (arity == 0) + arity = length; + if (required != null) + { + requiredParameters = new Parameter[required.size()]; + required.toArray(requiredParameters); + } + if (optional != null) + { + optionalParameters = new Parameter[optional.size()]; + optional.toArray(optionalParameters); + } + if (keywords != null) + { + keywordParameters = new Parameter[keywords.size()]; + keywords.toArray(keywordParameters); + } + if (aux != null) + { + auxVars = new Parameter[aux.size()]; + aux.toArray(auxVars); + } + } + else + { + // Lambda list is empty. + Debug.assertTrue(lambdaList == NIL); + arity = 0; + maxArgs = 0; + } + this.body = lambdaExpression.cddr(); + this.environment = env; + this.andKey = _andKey; + this.allowOtherKeys = _allowOtherKeys; + minArgs = requiredParameters.length; + if (arity >= 0) + Debug.assertTrue(arity == minArgs); + variables = processVariables(); + specials = processDeclarations(); + } + + private final void processParameters(ArrayList vars, + final Parameter[] parameters) + { + for (Parameter parameter : parameters) + { + vars.add(parameter.var); + if (parameter.svar != NIL) + vars.add((Symbol)parameter.svar); + if (!bindInitForms) + if (!parameter.initForm.constantp()) + bindInitForms = true; + } + } + + // Also sets bindInitForms. + private final Symbol[] processVariables() + { + ArrayList vars = new ArrayList(); + for (Parameter parameter : requiredParameters) + vars.add(parameter.var); + processParameters(vars, optionalParameters); + if (restVar != null) + { + vars.add(restVar); + } + processParameters(vars, keywordParameters); + Symbol[] array = new Symbol[vars.size()]; + vars.toArray(array); + return array; + } + + private final Symbol[] processDeclarations() throws ConditionThrowable + { + ArrayList arrayList = null; + LispObject forms = body; + while (forms != NIL) + { + LispObject obj = forms.car(); + if (obj instanceof Cons && obj.car() == Symbol.DECLARE) + { + LispObject decls = obj.cdr(); + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) + { + LispObject vars = decl.cdr(); + while (vars != NIL) + { + Symbol var = checkSymbol(vars.car()); + if (arrayList == null) + arrayList = new ArrayList(); + arrayList.add(var); + vars = vars.cdr(); + } + } + decls = decls.cdr(); + } + forms = forms.cdr(); + } + else + break; + } + if (arrayList == null) + return emptySymbolArray; + Symbol[] array = new Symbol[arrayList.size()]; + arrayList.toArray(array); + return array; + } + + private static final void invalidParameter(LispObject obj) + throws ConditionThrowable + { + error(new LispError(obj.writeToString() + + " may not be used as a variable in a lambda list.")); + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.COMPILED_FUNCTION) + return NIL; + return super.typep(typeSpecifier); + } + + public final LispObject getVariableList() + { + LispObject result = NIL; + for (int i = variables.length; i-- > 0;) + result = new Cons(variables[i], result); + return result; + } + + // Returns body as a list. + public final LispObject getBody() + { + return body; + } + + public final Environment getEnvironment() + { + return environment; + } + + @Override + public LispObject execute() throws ConditionThrowable + { + if (arity == 0) + { + return progn(body, environment, + LispThread.currentThread()); + } + else + return execute(new LispObject[0]); + } + + private final LispObject bindParametersAndExecute( + Environment ext, + LispThread thread, + SpecialBinding lastSpecialBinding) + throws ConditionThrowable + { + if (arity != minArgs) + { + bindParameterDefaults(optionalParameters, ext, thread); + if (restVar != null) + bindArg(specials, restVar, NIL, ext, thread); + bindParameterDefaults(keywordParameters, ext, thread); + } + bindAuxVars(ext, thread); + try + { + return progn(body, ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + private final void bindRequiredParameters(Environment ext, + LispThread thread, + LispObject... objects) + throws ConditionThrowable + { + // &whole and &environment before anything + if (envVar != null) + bindArg(specials, envVar, environment, ext, thread); + for (int i = 0; i < objects.length; ++i) + { + bindArg(specials, requiredParameters[i].var, objects[i], ext, thread); + } + } + + public final LispObject invokeArrayExecute(LispObject... objects) + throws ConditionThrowable + { + return execute(objects); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (minArgs == 1) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, arg); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(arg); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (minArgs == 2) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (minArgs == 3) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second, third); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second, third); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + if (minArgs == 4) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second, third, fourth); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second, third, fourth); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + if (minArgs == 5) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second, third, fourth, + fifth); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second, third, fourth, fifth); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + if (minArgs == 6) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second, third, fourth, + fifth, sixth); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second, third, fourth, fifth, + sixth); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + if (minArgs == 7) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second, third, fourth, + fifth, sixth, seventh); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second, third, fourth, fifth, + sixth, seventh); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + if (minArgs == 8) + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + bindRequiredParameters(ext, thread, first, second, third, fourth, + fifth, sixth, seventh, eighth); + return bindParametersAndExecute(ext, thread, + lastSpecialBinding); + } + else + { + return invokeArrayExecute(first, second, third, fourth, fifth, + sixth, seventh, eighth); + } + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + if (optionalParameters.length == 0 && keywordParameters.length == 0) + args = fastProcessArgs(args); + else + args = processArgs(args, thread); + Debug.assertTrue(args.length == variables.length); + if (envVar != null) + { + bindArg(specials, envVar, environment, ext, thread); + } + for (int i = 0; i < variables.length; i++) + { + Symbol sym = variables[i]; + bindArg(specials, sym, args[i], ext, thread); + } + bindAuxVars(ext, thread); + special: + for (Symbol special : specials) { + for (Symbol var : variables) + if (special == var) + continue special; + for (Parameter parameter : auxVars) + if (special == parameter.var) + continue special; + ext.declareSpecial(special); + } + try + { + return progn(body, ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + protected final LispObject[] processArgs(LispObject[] args, LispThread thread) + throws ConditionThrowable + { + if (optionalParameters.length == 0 && keywordParameters.length == 0) + return fastProcessArgs(args); + final int argsLength = args.length; + if (arity >= 0) + { + // Fixed arity. + if (argsLength != arity) + error(new WrongNumberOfArgumentsException(this)); + return args; + } + // Not fixed arity. + if (argsLength < minArgs) + error(new WrongNumberOfArgumentsException(this)); + final LispObject[] array = new LispObject[variables.length]; + int index = 0; + // The bindings established here (if any) are lost when this function + // returns. They are used only in the evaluation of initforms for + // optional and keyword arguments. + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + Environment ext = new Environment(environment); + // Section 3.4.4: "...the &environment parameter is bound along with + // &whole before any other variables in the lambda list..." + if (bindInitForms) + if (envVar != null) + bindArg(specials, envVar, environment, ext, thread); + // Required parameters. + for (int i = 0; i < minArgs; i++) + { + if (bindInitForms) + bindArg(specials, requiredParameters[i].var, args[i], ext, thread); + array[index++] = args[i]; + } + int i = minArgs; + int argsUsed = minArgs; + // Optional parameters. + for (Parameter parameter : optionalParameters) + { + if (i < argsLength) + { + if (bindInitForms) + bindArg(specials, parameter.var, args[i], ext, thread); + array[index++] = args[i]; + ++argsUsed; + if (parameter.svar != NIL) + { + if (bindInitForms) + bindArg(specials, (Symbol)parameter.svar, T, ext, thread); + array[index++] = T; + } + } + else + { + // We've run out of arguments. + LispObject value; + if (parameter.initVal != null) + value = parameter.initVal; + else + value = eval(parameter.initForm, ext, thread); + if (bindInitForms) + bindArg(specials, parameter.var, value, ext, thread); + array[index++] = value; + if (parameter.svar != NIL) + { + if (bindInitForms) + bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); + array[index++] = NIL; + } + } + ++i; + } + // &rest parameter. + if (restVar != null) + { + LispObject rest = NIL; + for (int j = argsLength; j-- > argsUsed;) + rest = new Cons(args[j], rest); + if (bindInitForms) + bindArg(specials, restVar, rest, ext, thread); + array[index++] = rest; + } + // Keyword parameters. + if (keywordParameters.length > 0) + { + int argsLeft = argsLength - argsUsed; + if (argsLeft == 0) + { + // No keyword arguments were supplied. + // Bind all keyword parameters to their defaults. + for (int k = 0; k < keywordParameters.length; k++) + { + Parameter parameter = keywordParameters[k]; + LispObject value; + if (parameter.initVal != null) + value = parameter.initVal; + else + value = eval(parameter.initForm, ext, thread); + if (bindInitForms) + bindArg(specials, parameter.var, value, ext, thread); + array[index++] = value; + if (parameter.svar != NIL) + { + if (bindInitForms) + bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); + array[index++] = NIL; + } + } + } + else + { + if ((argsLeft % 2) != 0) + error(new ProgramError("Odd number of keyword arguments.")); + LispObject allowOtherKeysValue = null; + for (Parameter parameter : keywordParameters) + { + Symbol keyword = parameter.keyword; + LispObject value = null; + boolean unbound = true; + for (int j = argsUsed; j < argsLength; j += 2) + { + if (args[j] == keyword) + { + if (bindInitForms) + bindArg(specials, parameter.var, args[j+1], ext, thread); + value = array[index++] = args[j+1]; + if (parameter.svar != NIL) + { + if (bindInitForms) + bindArg(specials,(Symbol)parameter.svar, T, ext, thread); + array[index++] = T; + } + args[j] = null; + args[j+1] = null; + unbound = false; + break; + } + } + if (unbound) + { + if (parameter.initVal != null) + value = parameter.initVal; + else + value = eval(parameter.initForm, ext, thread); + if (bindInitForms) + bindArg(specials, parameter.var, value, ext, thread); + array[index++] = value; + if (parameter.svar != NIL) + { + if (bindInitForms) + bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); + array[index++] = NIL; + } + } + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + if (allowOtherKeysValue == null) + allowOtherKeysValue = value; + } + } + if (!allowOtherKeys) + { + if (allowOtherKeysValue == null || allowOtherKeysValue == NIL) + { + LispObject unrecognizedKeyword = null; + for (int j = argsUsed; j < argsLength; j += 2) + { + LispObject keyword = args[j]; + if (keyword == null) + continue; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + if (allowOtherKeysValue == null) + { + allowOtherKeysValue = args[j+1]; + if (allowOtherKeysValue != NIL) + break; + } + continue; + } + // Unused keyword argument. + boolean ok = false; + for (Parameter parameter : keywordParameters) + { + if (parameter.keyword == keyword) + { + // Found it! + ok = true; + break; + } + } + if (ok) + continue; + // Unrecognized keyword argument. + if (unrecognizedKeyword == null) + unrecognizedKeyword = keyword; + } + if (unrecognizedKeyword != null) + { + if (!allowOtherKeys && + (allowOtherKeysValue == null || allowOtherKeysValue == NIL)) + error(new ProgramError("Unrecognized keyword argument " + + unrecognizedKeyword.writeToString())); + } + } + } + } + } + else if (argsUsed < argsLength) + { + // No keyword parameters. + if (argsUsed + 2 <= argsLength) + { + // Check for :ALLOW-OTHER-KEYS. + LispObject allowOtherKeysValue = NIL; + int n = argsUsed; + while (n < argsLength) + { + LispObject keyword = args[n]; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + allowOtherKeysValue = args[n+1]; + break; + } + n += 2; + } + if (allowOtherKeys || allowOtherKeysValue != NIL) + { + // Skip keyword/value pairs. + while (argsUsed + 2 <= argsLength) + argsUsed += 2; + } + else if (andKey) + { + LispObject keyword = args[argsUsed]; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + // Section 3.4.1.4: "Note that if &KEY is present, a + // keyword argument of :ALLOW-OTHER-KEYS is always + // permitted---regardless of whether the associated + // value is true or false." + argsUsed += 2; + } + } + } + if (argsUsed < argsLength) + { + if (restVar == null) + error(new WrongNumberOfArgumentsException(this)); + } + } + thread.lastSpecialBinding = lastSpecialBinding; + return array; + } + + // No optional or keyword parameters. + protected final LispObject[] fastProcessArgs(LispObject[] args) + throws ConditionThrowable + { + final int argsLength = args.length; + if (arity >= 0) + { + // Fixed arity. + if (argsLength != arity) + error(new WrongNumberOfArgumentsException(this)); + return args; + } + // Not fixed arity. + if (argsLength < minArgs) + error(new WrongNumberOfArgumentsException(this)); + final LispObject[] array = new LispObject[variables.length]; + int index = 0; + // Required parameters. + for (int i = 0; i < minArgs; i++) + { + array[index++] = args[i]; + } + int argsUsed = minArgs; + // &rest parameter. + if (restVar != null) + { + LispObject rest = NIL; + for (int j = argsLength; j-- > argsUsed;) + rest = new Cons(args[j], rest); + array[index++] = rest; + } + else if (argsUsed < argsLength) + { + // No keyword parameters. + if (argsUsed + 2 <= argsLength) + { + // Check for :ALLOW-OTHER-KEYS. + LispObject allowOtherKeysValue = NIL; + int n = argsUsed; + while (n < argsLength) + { + LispObject keyword = args[n]; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + allowOtherKeysValue = args[n+1]; + break; + } + n += 2; + } + if (allowOtherKeys || allowOtherKeysValue != NIL) + { + // Skip keyword/value pairs. + while (argsUsed + 2 <= argsLength) + argsUsed += 2; + } + else if (andKey) + { + LispObject keyword = args[argsUsed]; + if (keyword == Keyword.ALLOW_OTHER_KEYS) + { + // Section 3.4.1.4: "Note that if &key is present, a + // keyword argument of :allow-other-keys is always + // permitted---regardless of whether the associated + // value is true or false." + argsUsed += 2; + } + } + } + if (argsUsed < argsLength) + { + if (restVar == null) + error(new WrongNumberOfArgumentsException(this)); + } + } + return array; + } + + private final void bindParameterDefaults(Parameter[] parameters, + Environment env, + LispThread thread) + throws ConditionThrowable + { + for (Parameter parameter : parameters) + { + LispObject value; + if (parameter.initVal != null) + value = parameter.initVal; + else + value = eval(parameter.initForm, env, thread); + bindArg(specials, parameter.var, value, env, thread); + if (parameter.svar != NIL) + bindArg(specials, (Symbol)parameter.svar, NIL, env, thread); + } + } + + private final void bindAuxVars(Environment env, LispThread thread) + throws ConditionThrowable + { + // Aux variable processing is analogous to LET* processing. + for (Parameter parameter : auxVars) + { + Symbol sym = parameter.var; + LispObject value; + + if (parameter.initVal != null) + value = parameter.initVal; + else + value = eval(parameter.initForm, env, thread); + + bindArg(specials, sym, value, env, thread); + } + } + + private static class Parameter implements java.io.Serializable + { + private final Symbol var; + private final LispObject initForm; + private final LispObject initVal; + private final LispObject svar; + private final int type; + private final Symbol keyword; + + public Parameter(Symbol var) + { + this.var = var; + this.initForm = null; + this.initVal = null; + this.svar = NIL; + this.type = REQUIRED; + this.keyword = null; + } + + public Parameter(Symbol var, LispObject initForm, int type) + throws ConditionThrowable + { + this.var = var; + this.initForm = initForm; + this.initVal = processInitForm(initForm); + this.svar = NIL; + this.type = type; + keyword = + type == KEYWORD ? PACKAGE_KEYWORD.intern(var.name) : null; + } + + public Parameter(Symbol var, LispObject initForm, LispObject svar, + int type) + throws ConditionThrowable + { + this.var = var; + this.initForm = initForm; + this.initVal = processInitForm(initForm); + this.svar = (svar != NIL) ? checkSymbol(svar) : NIL; + this.type = type; + keyword = + type == KEYWORD ? PACKAGE_KEYWORD.intern(var.name) : null; + } + + public Parameter(Symbol keyword, Symbol var, LispObject initForm, + LispObject svar) + throws ConditionThrowable + { + this.var = var; + this.initForm = initForm; + this.initVal = processInitForm(initForm); + this.svar = (svar != NIL) ? checkSymbol(svar) : NIL; + type = KEYWORD; + this.keyword = keyword; + } + + @Override + public String toString() + { + if (type == REQUIRED) + return var.toString(); + StringBuffer sb = new StringBuffer(); + if (keyword != null) + { + sb.append(keyword); + sb.append(' '); + } + sb.append(var.toString()); + sb.append(' '); + sb.append(initForm); + sb.append(' '); + sb.append(type); + return sb.toString(); + } + + private static final LispObject processInitForm(LispObject initForm) + throws ConditionThrowable + { + if (initForm.constantp()) + { + if (initForm instanceof Symbol) + return initForm.getSymbolValue(); + if (initForm instanceof Cons) + { + Debug.assertTrue(initForm.car() == Symbol.QUOTE); + return initForm.cadr(); + } + return initForm; + } + return null; + } + } + + // ### lambda-list-names + private static final Primitive LAMBDA_LIST_NAMES = + new Primitive("lambda-list-names", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Closure closure = new Closure(list3(Symbol.LAMBDA, arg, NIL), new Environment()); + return closure.getVariableList(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ClosureTemplateFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,287 @@ +/* + * ClosureTemplateFunction.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: ClosureTemplateFunction.java 11512 2008-12-30 14:48:53Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class ClosureTemplateFunction extends Closure + implements Cloneable +{ + + public LispObject[] ctx; + + public ClosureTemplateFunction(LispObject lambdaList) + throws ConditionThrowable + { + super(list2(Symbol.LAMBDA, lambdaList), null); + } + + final public ClosureTemplateFunction setContext(LispObject[] context) + { + ctx = context; + return this; + } + + final public ClosureTemplateFunction dup() + { + ClosureTemplateFunction result = null; + try { + result = (ClosureTemplateFunction)super.clone(); + } catch (CloneNotSupportedException e) { + } + return result; + } + + + + // execute methods have the semantic meaning + // "evaluate this object" + @Override + public final LispObject execute() throws ConditionThrowable + { + return _execute(ctx); + } + + @Override + public final LispObject execute(LispObject arg) throws ConditionThrowable + { + return _execute(ctx, arg); + } + + @Override + public final LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return _execute(ctx, first, second); + } + + @Override + public final LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return _execute(ctx, first, second, third); + } + + @Override + public final LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return _execute(ctx, first, second, third, fourth); + } + + @Override + public final LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return _execute(ctx, first, second, third, fourth, fifth); + } + + @Override + public final LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return _execute(ctx, first, second, third, fourth, fifth, sixth); + } + + @Override + public final LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return _execute(ctx, first, second, third, fourth, fifth, sixth, seventh); + } + + @Override + public final LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return _execute(ctx, first, second, third, fourth, fifth, + sixth, seventh, eighth); + } + + @Override + public final LispObject execute(LispObject[] args) + throws ConditionThrowable + { + return _execute(ctx, args); + } + + private final LispObject notImplemented() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + + // _execute methods have the semantic meaning + // "evaluate this template with these values" + + // Zero args. + public LispObject _execute(LispObject[] context) throws ConditionThrowable + { + LispObject[] args = new LispObject[0]; + return _execute(context, args); + } + + // One arg. + public LispObject _execute(LispObject[] context, LispObject first) + throws ConditionThrowable + { + LispObject[] args = new LispObject[1]; + args[0] = first; + return _execute(context, args); + } + + // Two args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second) + throws ConditionThrowable + { + LispObject[] args = new LispObject[2]; + args[0] = first; + args[1] = second; + return _execute(context, args); + } + + // Three args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second, LispObject third) + throws ConditionThrowable + { + LispObject[] args = new LispObject[3]; + args[0] = first; + args[1] = second; + args[2] = third; + return _execute(context, args); + } + + // Four args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second, LispObject third, + LispObject fourth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[4]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + return _execute(context, args); + } + + // Five args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[5]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + return _execute(context, args); + } + + // Six args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth, + LispObject sixth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[6]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + return _execute(context, args); + } + + // Seven args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth, + LispObject sixth, LispObject seventh) + throws ConditionThrowable + { + LispObject[] args = new LispObject[7]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + return _execute(context, args); + } + + // Eight args. + public LispObject _execute(LispObject[] context, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth, + LispObject sixth, LispObject seventh, + LispObject eighth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[8]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + args[7] = eighth; + return _execute(context, args); + } + + // Arg array. + public LispObject _execute(LispObject[] context, LispObject[] args) + throws ConditionThrowable + { + return notImplemented(); + } +} Added: branches/save-image/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CompiledClosure.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,134 @@ +/* + * CompiledClosure.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: CompiledClosure.java 11514 2008-12-30 15:36:46Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class CompiledClosure extends Function +{ + private final ClosureTemplateFunction ctf; + private final LispObject[] context; + + public CompiledClosure(ClosureTemplateFunction ctf, LispObject[] context) + { + super(ctf.getLambdaName(), ctf.getLambdaList()); + this.ctf = ctf; + this.context = context; + } + + protected final LispObject[] processArgs(LispObject[] args, LispThread thread) + throws ConditionThrowable + { + return ctf.processArgs(args, thread); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return ctf.execute(); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return ctf.execute(arg); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return ctf.execute(first, second); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ctf.execute(first, second, third); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return ctf.execute(first, second, third, fourth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return ctf.execute(first, second, third, fourth, fifth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return ctf.execute(first, second, third, fourth, fifth, sixth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return ctf.execute(first, second, third, fourth, fifth, sixth, + seventh); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return ctf.execute(first, second, third, fourth, fifth, sixth, + seventh, eighth); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return ctf.execute(args); + } +} Added: branches/save-image/src/org/armedbear/lisp/CompiledFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CompiledFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,216 @@ +/* + * CompiledFunction.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: CompiledFunction.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class CompiledFunction extends Closure +{ + public CompiledFunction(LispObject name, LispObject lambdaList, + LispObject body, Environment env) + throws ConditionThrowable + { + super(name, + new Cons(Symbol.LAMBDA, + new Cons(lambdaList, body)), + env); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILED_FUNCTION; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.COMPILED_FUNCTION) + return T; + return super.typep(typeSpecifier); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + LispObject[] args = new LispObject[0]; + return execute(args); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispObject[] args = new LispObject[1]; + args[0] = arg; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + LispObject[] args = new LispObject[2]; + args[0] = first; + args[1] = second; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + LispObject[] args = new LispObject[3]; + args[0] = first; + args[1] = second; + args[2] = third; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[4]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[5]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[6]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + LispObject[] args = new LispObject[7]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[8]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + args[7] = eighth; + return execute(args); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return error(new LispError("Not implemented.")); + } + + // ### load-compiled-function + private static final Primitive LOAD_COMPILED_FUNCTION = + new Primitive("load-compiled-function", PACKAGE_SYS, true, "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + String namestring = null; + if (arg instanceof Pathname) + namestring = ((Pathname)arg).getNamestring(); + else if (arg instanceof AbstractString) + namestring = arg.getStringValue(); + if (namestring != null) + return loadCompiledFunction(namestring); + return error(new LispError("Unable to load " + arg.writeToString())); + } + }; + + // ### varlist + private static final Primitive VARLIST = + new Primitive("varlist", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Closure) + return ((Closure)arg).getVariableList(); + return type_error(arg, Symbol.COMPILED_FUNCTION); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/CompilerError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CompilerError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +/* + * CompilerError.java + * + * Copyright (C) 2005 Peter Graves + * $Id: CompilerError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class CompilerError extends Condition +{ + public CompilerError(LispObject initArgs) throws ConditionThrowable + { + super(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILER_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.COMPILER_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.COMPILER_ERROR) + return T; + if (type == StandardClass.COMPILER_ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/CompilerUnsupportedFeatureError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/CompilerUnsupportedFeatureError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +/* + * CompilerUnsupportedFeatureError.java + * + * Copyright (C) 2005 Peter Graves + * $Id: CompilerUnsupportedFeatureError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class CompilerUnsupportedFeatureError extends Condition +{ + public CompilerUnsupportedFeatureError(LispObject initArgs) throws ConditionThrowable + { + super(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.COMPILER_UNSUPPORTED_FEATURE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR) + return T; + if (type == StandardClass.COMPILER_UNSUPPORTED_FEATURE_ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Complex.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Complex.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,381 @@ +/* + * Complex.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: Complex.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.lang.reflect.Method; + +public final class Complex extends LispObject +{ + public final LispObject realpart; + public final LispObject imagpart; + + private Complex(LispObject realpart, LispObject imagpart) + { + this.realpart = realpart; + this.imagpart = imagpart; + } + + public static LispObject getInstance(LispObject realpart, + LispObject imagpart) + throws ConditionThrowable + { + if (!realpart.realp()) + return type_error(realpart, Symbol.REAL); + if (!imagpart.realp()) + return type_error(imagpart, Symbol.REAL); + if (realpart instanceof DoubleFloat) + imagpart = DoubleFloat.coerceToFloat(imagpart); + else if (imagpart instanceof DoubleFloat) + realpart = DoubleFloat.coerceToFloat(realpart); + else if (realpart instanceof SingleFloat) + imagpart = SingleFloat.coerceToFloat(imagpart); + else if (imagpart instanceof SingleFloat) + realpart = SingleFloat.coerceToFloat(realpart); + if (imagpart instanceof Fixnum) + { + if (((Fixnum)imagpart).value == 0) + return realpart; + } + return new Complex(realpart, imagpart); + } + + public LispObject getRealPart() + { + return realpart; + } + + public LispObject getImaginaryPart() + { + return imagpart; + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPLEX; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.COMPLEX; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.COMPLEX) + return T; + if (type == Symbol.NUMBER) + return T; + if (type == BuiltInClass.COMPLEX) + return T; + if (type == BuiltInClass.NUMBER) + return T; + return super.typep(type); + } + + @Override + public LispObject NUMBERP() + { + return T; + } + + @Override + public boolean numberp() + { + return true; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return realpart.eql(c.realpart) && imagpart.eql(c.imagpart); + } + return false; + } + + @Override + public boolean equal(LispObject obj) + { + return eql(obj); + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return (realpart.isEqualTo(c.realpart) && + imagpart.isEqualTo(c.imagpart)); + } + if (obj.numberp()) + { + // obj is a number, but not complex. + if (imagpart instanceof SingleFloat) + { + if (((SingleFloat)imagpart).value == 0) + { + if (obj instanceof Fixnum) + return ((Fixnum)obj).value == ((SingleFloat)realpart).value; + if (obj instanceof SingleFloat) + return ((SingleFloat)obj).value == ((SingleFloat)realpart).value; + } + } + if (imagpart instanceof DoubleFloat) + { + if (((DoubleFloat)imagpart).value == 0) + { + if (obj instanceof Fixnum) + return ((Fixnum)obj).value == ((DoubleFloat)realpart).value; + if (obj instanceof DoubleFloat) + return ((DoubleFloat)obj).value == ((DoubleFloat)realpart).value; + } + } + } + return false; + } + + @Override + public final LispObject incr() throws ConditionThrowable + { + return new Complex(realpart.add(Fixnum.ONE), imagpart); + } + + @Override + public final LispObject decr() throws ConditionThrowable + { + return new Complex(realpart.subtract(Fixnum.ONE), imagpart); + } + + @Override + public LispObject add(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return getInstance(realpart.add(c.realpart), imagpart.add(c.imagpart)); + } + return getInstance(realpart.add(obj), imagpart); + } + + @Override + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return getInstance(realpart.subtract(c.realpart), + imagpart.subtract(c.imagpart)); + } + return getInstance(realpart.subtract(obj), imagpart); + } + + @Override + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Complex) + { + LispObject a = realpart; + LispObject b = imagpart; + LispObject c = ((Complex)obj).getRealPart(); + LispObject d = ((Complex)obj).getImaginaryPart(); + // xy = (ac - bd) + i(ad + bc) + // real part = ac - bd + // imag part = (a + b)(c + d) - ac - bd + LispObject ac = a.multiplyBy(c); + LispObject bd = b.multiplyBy(d); + return Complex.getInstance(ac.subtract(bd), + a.add(b).multiplyBy(c.add(d)).subtract(ac).subtract(bd)); + } + return Complex.getInstance(realpart.multiplyBy(obj), + imagpart.multiplyBy(obj)); + } + + @Override + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Complex) + { + LispObject a = realpart; + LispObject b = imagpart; + LispObject c = ((Complex)obj).getRealPart(); + LispObject d = ((Complex)obj).getImaginaryPart(); + LispObject ac = a.multiplyBy(c); + LispObject bd = b.multiplyBy(d); + LispObject bc = b.multiplyBy(c); + LispObject ad = a.multiplyBy(d); + LispObject denominator = c.multiplyBy(c).add(d.multiplyBy(d)); + return Complex.getInstance(ac.add(bd).divideBy(denominator), + bc.subtract(ad).divideBy(denominator)); + } + return Complex.getInstance(realpart.divideBy(obj), + imagpart.divideBy(obj)); + } + + @Override + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return (realpart.isEqualTo(c.realpart) && + imagpart.isEqualTo(c.imagpart)); + } + if (obj.numberp()) + { + // obj is a number, but not complex. + if (imagpart instanceof SingleFloat) + { + if (((SingleFloat)imagpart).value == 0) + { + if (obj instanceof Fixnum) + return ((Fixnum)obj).value == ((SingleFloat)realpart).value; + if (obj instanceof SingleFloat) + return ((SingleFloat)obj).value == ((SingleFloat)realpart).value; + if (obj instanceof DoubleFloat) + return ((DoubleFloat)obj).value == ((SingleFloat)realpart).value; + } + } + if (imagpart instanceof DoubleFloat) + { + if (((DoubleFloat)imagpart).value == 0) + { + if (obj instanceof Fixnum) + return ((Fixnum)obj).value == ((DoubleFloat)realpart).value; + if (obj instanceof SingleFloat) + return ((SingleFloat)obj).value == ((DoubleFloat)realpart).value; + if (obj instanceof DoubleFloat) + return ((DoubleFloat)obj).value == ((DoubleFloat)realpart).value; + } + } + return false; + } + type_error(obj, Symbol.NUMBER); + // Not reached. + return false; + } + + @Override + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + return !isEqualTo(obj); + } + + private static Method hypotMethod = null; + static { try { + hypotMethod = + Class.forName("java.lang.Math") + .getMethod("hypot", new Class[] { Double.TYPE, Double.TYPE }); + } + catch (Throwable t) { Debug.trace(t); } + } + + @Override + public LispObject ABS() throws ConditionThrowable + { + if (realpart.zerop()) + return imagpart.ABS(); + double real = DoubleFloat.coerceToFloat(realpart).value; + double imag = DoubleFloat.coerceToFloat(imagpart).value; + try + { + if (hypotMethod != null) + { + Object[] args; + args = new Object[2]; + args[0] = new Double(real); + args[1] = new Double(imag); + Double d = (Double) hypotMethod.invoke(null, args); + if (realpart instanceof DoubleFloat) + return new DoubleFloat(d.doubleValue()); + else + return new SingleFloat((float)d.doubleValue()); + } + } + catch (Throwable t) + { + Debug.trace(t); + // Fall through... + } + double result = Math.sqrt(real * real + imag * imag); + if (realpart instanceof DoubleFloat) + return new DoubleFloat(result); + else + return new SingleFloat((float)result); + } + + @Override + public boolean zerop() throws ConditionThrowable + { + return realpart.zerop() && imagpart.zerop(); + } + + @Override + public LispObject COMPLEXP() + { + return T; + } + + @Override + public int sxhash() + { + return (mix(realpart.sxhash(), imagpart.sxhash()) & 0x7fffffff); + } + + @Override + public int psxhash() + { + return (mix(realpart.psxhash(), imagpart.psxhash()) & 0x7fffffff); + } + + @Override + public String writeToString() throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("#C("); + sb.append(realpart.writeToString()); + sb.append(' '); + sb.append(imagpart.writeToString()); + sb.append(')'); + return sb.toString(); + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexArray.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexArray.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,293 @@ +/* + * ComplexArray.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: ComplexArray.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ComplexArray extends AbstractArray +{ + private final int[] dimv; + private final LispObject elementType; + private int totalSize; + + // For non-displaced arrays. + private LispObject[] data; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexArray(int[] dimv, LispObject elementType) + { + this.dimv = dimv; + this.elementType = elementType; + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + for (int i = totalSize; i-- > 0;) + data[i] = Fixnum.ZERO; + } + + public ComplexArray(int[] dimv, + LispObject elementType, + LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + this.elementType = elementType; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public ComplexArray(int[] dimv, AbstractArray array, int displacement) + { + this.dimv = dimv; + this.elementType = array.getElementType(); + this.array = array; + this.displacement = displacement; + totalSize = computeTotalSize(dimv); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) { + try { + data[index] = contents; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } else { + int dim = dims[0]; + if (dim != contents.length()) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) { + for (int i = contents.length();i-- > 0;) { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } else { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.ARRAY, elementType, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.ARRAY; + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return elementType; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (data != null) { + try { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + index + ".")); + } + } else + return array.AREF(index + displacement); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (data != null) { + try { + data[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + } + } else + array.aset(index + displacement, newValue); + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + if (data != null) { + for (int i = data.length; i-- > 0;) + data[i] = obj; + } else { + for (int i = totalSize; i-- > 0;) + aset(i, obj); + } + } + + @Override + public String writeToString() throws ConditionThrowable + { + return writeToString(dimv); + } + + @Override + public AbstractArray adjustArray(int[] dims, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable { + if (isAdjustable()) { + if (initialContents != null) + setInitialContents(0, dims, initialContents, 0); + else { + //### FIXME Take the easy way out: we don't want to reorganize + // all of the array code yet + SimpleArray_T tempArray = new SimpleArray_T(dims, elementType); + if (initialElement != null) + tempArray.fill(initialElement); + SimpleArray_T.copyArray(this, tempArray); + this.data = tempArray.data; + + for (int i = 0; i < dims.length; i++) + dimv[i] = dims[i]; + } + return this; + } else { + if (initialContents != null) + return new ComplexArray(dims, elementType, initialContents); + else { + ComplexArray newArray = new ComplexArray(dims, elementType); + if (initialElement != null) + newArray.fill(initialElement); + return newArray; + } + } + } + + @Override + public AbstractArray adjustArray(int[] dims, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable { + if (isAdjustable()) { + for (int i = 0; i < dims.length; i++) + dimv[i] = dims[i]; + + this.data = null; + this.array = displacedTo; + this.displacement = displacement; + this.totalSize = computeTotalSize(dims); + + return this; + } else { + ComplexArray a = new ComplexArray(dims, displacedTo, displacement); + + return a; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexArray_UnsignedByte32.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,290 @@ +/* + * ComplexArray_UnsignedByte32.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ComplexArray_UnsignedByte32.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ComplexArray_UnsignedByte32 extends AbstractArray +{ + private final int[] dimv; + private int totalSize; + + // For non-displaced arrays. + // FIXME We should really use an array of unboxed values! + private LispObject[] data; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexArray_UnsignedByte32(int[] dimv) + { + this.dimv = dimv; + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + for (int i = totalSize; i-- > 0;) + data[i] = NIL; + } + + public ComplexArray_UnsignedByte32(int[] dimv, LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public ComplexArray_UnsignedByte32(int[] dimv, AbstractArray array, + int displacement) + { + this.dimv = dimv; + this.array = array; + this.displacement = displacement; + totalSize = computeTotalSize(dimv); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) { + try { + data[index] = contents; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } else { + int dim = dims[0]; + if (dim != contents.length()) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) { + for (int i = contents.length();i-- > 0;) { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } else { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.ARRAY, UNSIGNED_BYTE_32, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.ARRAY; + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_32; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (data != null) { + try { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + index + ".")); + } + } else + return array.AREF(index + displacement); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (data != null) { + try { + data[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + } + } else + array.aset(index + displacement, newValue); + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + if (data != null) { + for (int i = data.length; i-- > 0;) + data[i] = obj; + } else { + for (int i = totalSize; i-- > 0;) + aset(i, obj); + } + } + + @Override + public String writeToString() throws ConditionThrowable + { + return writeToString(dimv); + } + + + @Override + public AbstractArray adjustArray(int[] dims, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable { + if (isAdjustable()) { + if (initialContents != null) + setInitialContents(0, dims, initialContents, 0); + else { + //### FIXME Take the easy way out: we don't want to reorganize + // all of the array code yet + SimpleArray_UnsignedByte32 tempArray = new SimpleArray_UnsignedByte32(dims); + if (initialElement != null) + tempArray.fill(initialElement); + SimpleArray_UnsignedByte32.copyArray(this, tempArray); + this.data = tempArray.data; + + for (int i = 0; i < dims.length; i++) + dimv[i] = dims[i]; + } + return this; + } else { + if (initialContents != null) + return new ComplexArray_UnsignedByte32(dims, initialContents); + else { + ComplexArray_UnsignedByte32 newArray = new ComplexArray_UnsignedByte32(dims); + if (initialElement != null) + newArray.fill(initialElement); + return newArray; + } + } + } + + @Override + public AbstractArray adjustArray(int[] dims, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable { + if (isAdjustable()) { + for (int i = 0; i < dims.length; i++) + dimv[i] = dims[i]; + + this.data = null; + this.array = displacedTo; + this.displacement = displacement; + this.totalSize = computeTotalSize(dims); + + return this; + } else { + ComplexArray_UnsignedByte32 a = new ComplexArray_UnsignedByte32(dims, displacedTo, displacement); + + return a; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexArray_UnsignedByte8.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,292 @@ +/* + * ComplexArray_UnsignedByte8.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ComplexArray_UnsignedByte8.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ComplexArray_UnsignedByte8 extends AbstractArray +{ + private final int[] dimv; + private int totalSize; + + // For non-displaced arrays. + private byte[] data; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexArray_UnsignedByte8(int[] dimv) + { + this.dimv = dimv; + totalSize = computeTotalSize(dimv); + data = new byte[totalSize]; + } + + public ComplexArray_UnsignedByte8(int[] dimv, LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new byte[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public ComplexArray_UnsignedByte8(int[] dimv, AbstractArray array, int displacement) + { + this.dimv = dimv; + this.array = array; + this.displacement = displacement; + totalSize = computeTotalSize(dimv); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) { + try { + data[index] = coerceLispObjectToJavaByte(contents); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } else { + int dim = dims[0]; + if (dim != contents.length()) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) { + for (int i = contents.length();i-- > 0;) { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } else { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.ARRAY, UNSIGNED_BYTE_8, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.ARRAY; + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_8; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (data != null) { + try { + return coerceJavaByteToLispObject(data[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + index + ".")); + } + } else + return array.AREF(index + displacement); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (data != null) { + try { + data[index] = coerceLispObjectToJavaByte(newValue); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + } + } else + array.aset(index + displacement, newValue); + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + if (data != null) { + byte b = coerceLispObjectToJavaByte(obj); + for (int i = data.length; i-- > 0;) + data[i] = b; + } else { + for (int i = totalSize; i-- > 0;) + aset(i, obj); + } + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (Symbol.PRINT_READABLY.symbolValue() != NIL) { + error(new PrintNotReadable(list2(Keyword.OBJECT, this))); + // Not reached. + return null; + } + return writeToString(dimv); + } + + + @Override + public AbstractArray adjustArray(int[] dims, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable { + if (isAdjustable()) { + if (initialContents != null) + setInitialContents(0, dims, initialContents, 0); + else { + //### FIXME Take the easy way out: we don't want to reorganize + // all of the array code yet + SimpleArray_UnsignedByte8 tempArray = new SimpleArray_UnsignedByte8(dims); + if (initialElement != null) + tempArray.fill(initialElement); + SimpleArray_UnsignedByte8.copyArray(this, tempArray); + this.data = tempArray.data; + + for (int i = 0; i < dims.length; i++) + dimv[i] = dims[i]; + } + return this; + } else { + if (initialContents != null) + return new ComplexArray_UnsignedByte8(dims, initialContents); + else { + ComplexArray_UnsignedByte8 newArray = new ComplexArray_UnsignedByte8(dims); + if (initialElement != null) + newArray.fill(initialElement); + return newArray; + } + } + } + + @Override + public AbstractArray adjustArray(int[] dims, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable { + if (isAdjustable()) { + for (int i = 0; i < dims.length; i++) + dimv[i] = dims[i]; + + this.data = null; + this.array = displacedTo; + this.displacement = displacement; + this.totalSize = computeTotalSize(dims); + + return this; + } else { + ComplexArray_UnsignedByte8 a = new ComplexArray_UnsignedByte8(dims, displacedTo, displacement); + + return a; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexBitVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexBitVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,394 @@ +/* + * ComplexBitVector.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ComplexBitVector.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ComplexBitVector extends AbstractBitVector +{ + private int fillPointer = -1; // -1 indicates no fill pointer. + private boolean isDisplaced; + + // For displaced bit vectors. + private AbstractArray array; + private int displacement; + + public ComplexBitVector(int capacity) throws ConditionThrowable + { + this.capacity = capacity; + int size = capacity >>> 6; + if ((capacity & LONG_MASK) != 0) + ++size; + bits = new long[size]; + } + + public ComplexBitVector(int capacity, AbstractArray array, int displacement) + { + this.capacity = capacity; + this.array = array; + this.displacement = displacement; + isDisplaced = true; + } + + @Override + public LispObject typeOf() + { + return list2(Symbol.BIT_VECTOR, new Fixnum(capacity)); + } + + @Override + public boolean hasFillPointer() + { + return fillPointer >= 0; + } + + @Override + public int getFillPointer() + { + return fillPointer; + } + + @Override + public void setFillPointer(int n) + { + fillPointer = n; + } + + @Override + public void setFillPointer(LispObject obj) throws ConditionThrowable + { + if (obj == T) + fillPointer = capacity(); + else { + int n = Fixnum.getValue(obj); + if (n > capacity()) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") exceeds the capacity of the vector ("); + sb.append(capacity()); + sb.append(")."); + error(new LispError(sb.toString())); + } else if (n < 0) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") is negative."); + error(new LispError(sb.toString())); + } else + fillPointer = n; + } + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public int length() + { + return fillPointer >= 0 ? fillPointer : capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + if (index >= length()) + badIndex(index, length()); + return AREF(index); + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (index < 0 || index >= capacity) + badIndex(index, capacity); + if (bits != null) { + int offset = index >> 6; + return (bits[offset] & (1L << index)) != 0 ? Fixnum.ONE : Fixnum.ZERO; + } else { + // Displaced bit vector. + return array.AREF(index + displacement); + } + } + + @Override + protected int getBit(int index) throws ConditionThrowable + { + if (bits != null) { + int offset = index >> 6; + return (bits[offset] & (1L << index)) != 0 ? 1 : 0; + } else + return Fixnum.getValue(array.AREF(index + displacement)); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (index < 0 || index >= capacity) + badIndex(index, capacity); + try { + switch (((Fixnum)newValue).value) { + case 0: + if (bits != null) { + final int offset = index >> 6; + bits[offset] &= ~(1L << index); + } else + clearBit(index); + return; + case 1: + if (bits != null) { + final int offset = index >> 6; + bits[offset] |= 1L << index; + } else + setBit(index); + return; + } + } + catch (ClassCastException e) { + // Fall through... + } + type_error(newValue, Symbol.BIT); + } + + @Override + protected void setBit(int index) throws ConditionThrowable + { + if (bits != null) { + int offset = index >> 6; + bits[offset] |= 1L << index; + } else + array.aset(index + displacement, Fixnum.ONE); + } + + @Override + protected void clearBit(int index) throws ConditionThrowable + { + if (bits != null) { + int offset = index >> 6; + bits[offset] &= ~(1L << index); + } else + array.aset(index + displacement, Fixnum.ZERO); + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (bits != null) { + if (n < capacity) { + int size = n >>> 6; + if ((n & LONG_MASK) != 0) + ++size; + if (size < bits.length) { + long[] newbits = new long[size]; + System.arraycopy(bits, 0, newbits, 0, size); + bits = newbits; + } + capacity = n; + return; + } + if (n == capacity) + return; + } + error(new LispError()); + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + // FIXME + @Override + public void vectorPushExtend(LispObject element) throws ConditionThrowable + { + final int fp = getFillPointer(); + if (fp < 0) + noFillPointer(); + if (fp >= capacity()) { + // Need to extend vector. + ensureCapacity(capacity() * 2 + 1); + } + aset(fp, element); + setFillPointer(fp + 1); + } + + // FIXME + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element) + throws ConditionThrowable + { + vectorPushExtend(element); + return new Fixnum(getFillPointer() - 1); + } + + // FIXME + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element, LispObject extension) + throws ConditionThrowable + { + int ext = Fixnum.getValue(extension); + final int fp = getFillPointer(); + if (fp < 0) + noFillPointer(); + if (fp >= capacity()) { + // Need to extend vector. + ext = Math.max(ext, capacity() + 1); + ensureCapacity(capacity() + ext); + } + aset(fp, element); + setFillPointer(fp + 1); + return new Fixnum(fp); + } + + private final void ensureCapacity(int minCapacity) throws ConditionThrowable + { + if (bits != null) { + if (capacity < minCapacity) { + int size = minCapacity >>> 6; + if ((minCapacity & LONG_MASK) != 0) + ++size; + long[] newBits = new long[size]; + System.arraycopy(bits, 0, newBits, 0, bits.length); + bits = newBits; + capacity = minCapacity; + } + } else { + Debug.assertTrue(array != null); + if (capacity < minCapacity || + array.getTotalSize() - displacement < minCapacity) + { + // Copy array. + int size = minCapacity >>> 6; + if ((minCapacity & LONG_MASK) != 0) + ++size; + bits = new long[size]; + final int limit = + Math.min(capacity, array.getTotalSize() - displacement); + for (int i = 0; i < limit; i++) { + int n = Fixnum.getValue(array.AREF(displacement + i)); + if (n == 1) + setBit(i); + else + clearBit(i); + } + capacity = minCapacity; + array = null; + displacement = 0; + isDisplaced = false; + } + } + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (bits == null) { + // Copy array. + int size = capacity >>> 6; + if ((capacity & LONG_MASK) != 0) + ++size; + bits = new long[size]; + for (int i = 0; i < capacity; i++) { + int n = Fixnum.getValue(array.AREF(displacement + i)); + if (n == 1) + setBit(i); + else + clearBit(i); + } + array = null; + displacement = 0; + isDisplaced = false; + } + if (capacity != newCapacity) { + int size = newCapacity >>> 6; + if ((newCapacity & LONG_MASK) != 0) + ++size; + if (initialContents != null) { + bits = new long[size]; + capacity = newCapacity; + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + aset(i, list.car()); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + aset(i, initialContents.elt(i)); + } else + type_error(initialContents, Symbol.SEQUENCE); + } else { + long[] newBits = new long[size]; + System.arraycopy(bits, 0, newBits, 0, + Math.min(bits.length, newBits.length)); + bits = newBits; + if (newCapacity > capacity && initialElement != null) { + int n = Fixnum.getValue(initialElement); + if (n == 1) + for (int i = capacity; i < newCapacity; i++) + setBit(i); + else + for (int i = capacity; i < newCapacity; i++) + clearBit(i); + } + } + capacity = newCapacity; + } + return this; + } + + @Override + public AbstractVector adjustArray(int size, AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + capacity = size; + array = displacedTo; + this.displacement = displacement; + bits = null; + isDisplaced = true; + return this; + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexString.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexString.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,689 @@ +/* + * ComplexString.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: ComplexString.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ComplexString extends AbstractString +{ + private int capacity; + private int fillPointer = -1; // -1 indicates no fill pointer. + private boolean isDisplaced; + + // For non-displaced arrays. + private char[] chars; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexString(int capacity) + { + this.capacity = capacity; + chars = new char[capacity]; + isDisplaced = false; + } + + public ComplexString(int capacity, AbstractArray array, int displacement) + { + this.capacity = capacity; + this.array = array; + this.displacement = displacement; + isDisplaced = true; + } + + @Override + public LispObject typeOf() + { + return list2(Symbol.STRING, number(capacity())); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.STRING; + } + + @Override + public boolean hasFillPointer() + { + return fillPointer >= 0; + } + + @Override + public int getFillPointer() + { + return fillPointer; + } + + @Override + public void setFillPointer(int n) + { + fillPointer = n; + } + + @Override + public void setFillPointer(LispObject obj) throws ConditionThrowable + { + if (obj == T) + fillPointer = capacity(); + else + { + int n = Fixnum.getValue(obj); + if (n > capacity()) + { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") exceeds the capacity of the vector ("); + sb.append(capacity()); + sb.append(")."); + error(new LispError(sb.toString())); + } + else if (n < 0) + { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") is negative."); + error(new LispError(sb.toString())); + } + else + fillPointer = n; + } + } + + @Override + public boolean isDisplaced() + { + return isDisplaced; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) + { + value1 = array; + value2 = new Fixnum(displacement); + } + else + { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public char[] chars() throws ConditionThrowable + { + if (chars != null) + return chars; + Debug.assertTrue(array != null); + char[] copy = new char[capacity]; + if (array instanceof AbstractString) + System.arraycopy(array.chars(), displacement, copy, 0, capacity); + else if (array.getElementType() == Symbol.CHARACTER) + { + for (int i = 0; i < capacity; i++) + { + LispObject obj = array.AREF(displacement + i); + try + { + copy[i] = ((LispCharacter)obj).value; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.CHARACTER); + } + } + } + else + type_error(array, Symbol.STRING); + return copy; + } + + @Override + public char[] getStringChars() throws ConditionThrowable + { + if (fillPointer < 0) + return chars(); + char[] ret = new char[fillPointer]; + System.arraycopy(chars(), 0, ret, 0, fillPointer); + return ret; + } + + @Override + public boolean equal(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof AbstractString) + { + AbstractString string = (AbstractString) obj; + if (string.length() != length()) + return false; + for (int i = length(); i-- > 0;) + if (string.charAt(i) != charAt(i)) + return false; + return true; + } + if (obj instanceof NilVector) + return obj.equal(this); + return false; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof AbstractString) + { + AbstractString string = (AbstractString) obj; + if (string.length() != length()) + return false; + for (int i = length(); i-- > 0;) + { + if (string.charAt(i) != charAt(i)) + { + if (LispCharacter.toLowerCase(string.charAt(i)) != LispCharacter.toLowerCase(charAt(i))) + return false; + } + } + return true; + } + if (obj instanceof AbstractBitVector) + return false; + if (obj instanceof AbstractArray) + return obj.equalp(this); + return false; + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + SimpleString s = new SimpleString(end - start); + int i = start, j = 0; + while (i < end) + s.setCharAt(j++, charAt(i++)); + return s; + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + fill(LispCharacter.getValue(obj)); + } + + @Override + public void fill(char c) throws ConditionThrowable + { + for (int i = length(); i-- > 0;) + setCharAt(i, c); + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (chars != null) + { + if (n < capacity) + { + char[] newArray = new char[n]; + System.arraycopy(chars, 0, newArray, 0, n); + chars = newArray; + capacity = n; + fillPointer = -1; + return; + } + if (n == capacity) + return; + } + Debug.assertTrue(chars == null); + // Displaced array. Copy existing characters. + chars = new char[n]; + if (array instanceof AbstractString) + { + AbstractString string = (AbstractString) array; + for (int i = 0; i < n; i++) + { + chars[i] = string.charAt(displacement + i); + } + } + else + { + for (int i = 0; i < n; i++) + { + LispCharacter character = + (LispCharacter) array.AREF(displacement + i); + chars[i] = character.value; + } + } + capacity = n; + array = null; + displacement = 0; + isDisplaced = false; + fillPointer = -1; + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + int length = length(); + SimpleString result = new SimpleString(length); + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + result.setCharAt(i, charAt(j)); + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = length() - 1; + while (i < j) + { + char temp = charAt(i); + setCharAt(i, charAt(j)); + setCharAt(j, temp); + ++i; + --j; + } + return this; + } + + @Override + public String getStringValue() throws ConditionThrowable + { + if (fillPointer >= 0) + return new String(chars(), 0, fillPointer); + else + return new String(chars()); + } + + @Override + public Object javaInstance() throws ConditionThrowable + { + return new String(chars()); + } + + @Override + public Object javaInstance(Class c) throws ConditionThrowable + { + return javaInstance(); + } + + @Override + public final int capacity() + { + return capacity; + } + + @Override + public final int length() + { + return fillPointer >= 0 ? fillPointer : capacity; + } + + @Override + public char charAt(int index) throws ConditionThrowable + { + if (chars != null) + { + try + { + return chars[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + return 0; // Not reached. + } + } + else + return LispCharacter.getValue(array.AREF(index + displacement)); + } + + @Override + public void setCharAt(int index, char c) throws ConditionThrowable + { + if (chars != null) + { + try + { + chars[index] = c; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + } + } + else + array.aset(index + displacement, LispCharacter.getInstance(c)); + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + final int limit = length(); + if (index < 0 || index >= limit) + badIndex(index, limit); + return LispCharacter.getInstance(charAt(index)); + } + + // Ignores fill pointer. + @Override + public LispObject CHAR(int index) throws ConditionThrowable + { + return LispCharacter.getInstance(charAt(index)); + } + + // Ignores fill pointer. + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + return LispCharacter.getInstance(charAt(index)); + } + + // Ignores fill pointer. + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + return LispCharacter.getInstance(charAt(Fixnum.getValue(index))); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + try + { + setCharAt(index, ((LispCharacter)newValue).value); + } + catch (ClassCastException e) + { + type_error(newValue, Symbol.CHARACTER); + } + } + + @Override + public void vectorPushExtend(LispObject element) + throws ConditionThrowable + { + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) + { + // Need to extend vector. + ensureCapacity(capacity * 2 + 1); + } + if (chars != null) + { + try + { + chars[fillPointer] = ((LispCharacter)element).value; + } + catch (ClassCastException e) + { + type_error(element, Symbol.CHARACTER); + } + } + else + array.aset(fillPointer + displacement, element); + ++fillPointer; + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element) + throws ConditionThrowable + { + vectorPushExtend(element); + return new Fixnum(fillPointer - 1); + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element, LispObject extension) + throws ConditionThrowable + { + int ext = Fixnum.getValue(extension); + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) + { + // Need to extend vector. + ext = Math.max(ext, capacity + 1); + ensureCapacity(capacity + ext); + } + if (chars != null) + { + try + { + chars[fillPointer] = ((LispCharacter)element).value; + } + catch (ClassCastException e) + { + type_error(element, Symbol.CHARACTER); + } + } + else + array.aset(fillPointer + displacement, element); + return new Fixnum(fillPointer++); + } + + public final void ensureCapacity(int minCapacity) throws ConditionThrowable + { + if (chars != null) + { + if (capacity < minCapacity) + { + char[] newArray = new char[minCapacity]; + System.arraycopy(chars, 0, newArray, 0, capacity); + chars = newArray; + capacity = minCapacity; + } + } + else + { + Debug.assertTrue(array != null); + if (capacity < minCapacity || + array.getTotalSize() - displacement < minCapacity) + { + // Copy array. + chars = new char[minCapacity]; + final int limit = + Math.min(capacity, array.getTotalSize() - displacement); + if (array instanceof AbstractString) + { + AbstractString string = (AbstractString) array; + for (int i = 0; i < limit; i++) + { + chars[i] = string.charAt(displacement + i); + } + } + else + { + for (int i = 0; i < limit; i++) + { + LispCharacter character = + (LispCharacter) array.AREF(displacement + i); + chars[i] = character.value; + } + } + capacity = minCapacity; + array = null; + displacement = 0; + isDisplaced = false; + } + } + } + + @Override + public int sxhash() + { + int hashCode = 0; + final int limit = length(); + for (int i = 0; i < limit; i++) + { + try + { + hashCode += charAt(i); + } + catch (ConditionThrowable t) + { + Debug.trace(t); + } + hashCode += (hashCode << 10); + hashCode ^= (hashCode >> 6); + } + hashCode += (hashCode << 3); + hashCode ^= (hashCode >> 11); + hashCode += (hashCode << 15); + return (hashCode & 0x7fffffff); + } + + // For EQUALP hash tables. + @Override + public int psxhash() + { + int hashCode = 0; + final int limit = length(); + for (int i = 0; i < limit; i++) + { + try + { + hashCode += Character.toUpperCase(charAt(i)); + } + catch (ConditionThrowable t) + { + Debug.trace(t); + } + hashCode += (hashCode << 10); + hashCode ^= (hashCode >> 6); + } + hashCode += (hashCode << 3); + hashCode ^= (hashCode >> 11); + hashCode += (hashCode << 15); + return (hashCode & 0x7fffffff); + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + { + // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE- + // ARRAY. In this case none of the original contents of array + // appears in the resulting array." + char[] newChars = new char[newCapacity]; + if (initialContents.listp()) + { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) + { + newChars[i] = LispCharacter.getValue(list.car()); + list = list.cdr(); + } + } + else if (initialContents.vectorp()) + { + for (int i = 0; i < newCapacity; i++) + newChars[i] = LispCharacter.getValue(initialContents.elt(i)); + } + else + type_error(initialContents, Symbol.SEQUENCE); + chars = newChars; + } + else + { + if (chars == null) + { + // Displaced array. Copy existing characters. + chars = new char[newCapacity]; + final int limit = Math.min(capacity, newCapacity); + if (array instanceof AbstractString) + { + AbstractString string = (AbstractString) array; + for (int i = 0; i < limit; i++) + { + chars[i] = string.charAt(displacement + i); + } + } + else + { + for (int i = 0; i < limit; i++) + { + LispCharacter character = + (LispCharacter) array.AREF(displacement + i); + chars[i] = character.value; + } + } + } + else if (capacity != newCapacity) + { + char[] newElements = new char[newCapacity]; + System.arraycopy(chars, 0, newElements, 0, + Math.min(capacity, newCapacity)); + chars = newElements; + } + if (initialElement != null && capacity < newCapacity) + { + // Initialize new elements. + final char c = LispCharacter.getValue(initialElement); + for (int i = capacity; i < newCapacity; i++) + chars[i] = c; + } + } + capacity = newCapacity; + array = null; + displacement = 0; + isDisplaced = false; + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + capacity = newCapacity; + array = displacedTo; + this.displacement = displacement; + chars = null; + isDisplaced = true; + return this; + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,428 @@ +/* + * ComplexVector.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: ComplexVector.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// A vector that is displaced to another array, has a fill pointer, and/or is +// expressly adjustable. It can hold elements of any type. +public final class ComplexVector extends AbstractVector +{ + private int capacity; + private int fillPointer = -1; // -1 indicates no fill pointer. + private boolean isDisplaced; + + // For non-displaced arrays. + private LispObject[] elements; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexVector(int capacity) + { + elements = new LispObject[capacity]; + for (int i = capacity; i-- > 0;) + elements[i] = Fixnum.ZERO; + this.capacity = capacity; + } + + public ComplexVector(int capacity, AbstractArray array, int displacement) + { + this.capacity = capacity; + this.array = array; + this.displacement = displacement; + isDisplaced = true; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.VECTOR, T, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.VECTOR; + } + + @Override + public boolean hasFillPointer() + { + return fillPointer >= 0; + } + + @Override + public int getFillPointer() + { + return fillPointer; + } + + @Override + public void setFillPointer(int n) + { + fillPointer = n; + } + + @Override + public void setFillPointer(LispObject obj) throws ConditionThrowable + { + if (obj == T) + fillPointer = capacity(); + else { + int n = Fixnum.getValue(obj); + if (n > capacity()) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") exceeds the capacity of the vector ("); + sb.append(capacity()); + sb.append(")."); + error(new LispError(sb.toString())); + } else if (n < 0) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") is negative."); + error(new LispError(sb.toString())); + } else + fillPointer = n; + } + } + + @Override + public boolean isDisplaced() + { + return isDisplaced; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public LispObject getElementType() + { + return T; + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return fillPointer >= 0 ? fillPointer : capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + final int limit = length(); + if (index < 0 || index >= limit) + badIndex(index, limit); + return AREF(index); + } + + // Ignores fill pointer. + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (elements != null) { + try { + return elements[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + return NIL; // Not reached. + } + } else { + // Displaced array. + if (index < 0 || index >= capacity) + badIndex(index, capacity); + return array.AREF(index + displacement); + } + } + + // Ignores fill pointer. + // FIXME inline + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + return AREF(Fixnum.getValue(index)); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (elements != null) { + try { + elements[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + } + } else { + // Displaced array. + if (index < 0 || index >= capacity) + badIndex(index, capacity); + else + array.aset(index + displacement, newValue); + } + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + SimpleVector v = new SimpleVector(end - start); + int i = start, j = 0; + try { + while (i < end) + v.aset(j++, AREF(i++)); + return v; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + for (int i = capacity; i-- > 0;) + elements[i] = obj; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (elements != null) { + if (n < elements.length) { + LispObject[] newArray = new LispObject[n]; + System.arraycopy(elements, 0, newArray, 0, n); + elements = newArray; + capacity = n; + return; + } + if (n == elements.length) + return; + } + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + int length = length(); + SimpleVector result = new SimpleVector(length); + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + result.aset(i, AREF(j)); + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + if (elements != null) { + int i = 0; + int j = length() - 1; + while (i < j) { + LispObject temp = elements[i]; + elements[i] = elements[j]; + elements[j] = temp; + ++i; + --j; + } + } else { + // Displaced array. + int length = length(); + LispObject[] data = new LispObject[length]; + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + data[i] = AREF(j); + elements = data; + capacity = length; + array = null; + displacement = 0; + isDisplaced = false; + fillPointer = -1; + } + return this; + } + + @Override + public void vectorPushExtend(LispObject element) + throws ConditionThrowable + { + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) { + // Need to extend vector. + ensureCapacity(capacity * 2 + 1); + } + aset(fillPointer++, element); + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element) + throws ConditionThrowable + { + vectorPushExtend(element); + return new Fixnum(fillPointer - 1); + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element, LispObject extension) + throws ConditionThrowable + { + int ext = Fixnum.getValue(extension); + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) { + // Need to extend vector. + ext = Math.max(ext, capacity + 1); + ensureCapacity(capacity + ext); + } + aset(fillPointer, element); + return new Fixnum(fillPointer++); + } + + private final void ensureCapacity(int minCapacity) throws ConditionThrowable + { + if (elements != null) { + if (capacity < minCapacity) { + LispObject[] newArray = new LispObject[minCapacity]; + System.arraycopy(elements, 0, newArray, 0, capacity); + elements = newArray; + capacity = minCapacity; + } + } else { + // Displaced array. + Debug.assertTrue(array != null); + if (capacity < minCapacity || + array.getTotalSize() - displacement < minCapacity) + { + // Copy array. + elements = new LispObject[minCapacity]; + final int limit = + Math.min(capacity, array.getTotalSize() - displacement); + for (int i = 0; i < limit; i++) + elements[i] = array.AREF(displacement + i); + capacity = minCapacity; + array = null; + displacement = 0; + isDisplaced = false; + } + } + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) { + // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE- + // ARRAY. In this case none of the original contents of array + // appears in the resulting array." + LispObject[] newElements = new LispObject[newCapacity]; + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + newElements[i] = list.car(); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + newElements[i] = initialContents.elt(i); + } else + error(new TypeError(initialContents, Symbol.SEQUENCE)); + elements = newElements; + } else { + if (elements == null) { + // Displaced array. Copy existing elements. + elements = new LispObject[newCapacity]; + final int limit = Math.min(capacity, newCapacity); + for (int i = 0; i < limit; i++) + elements[i] = array.AREF(displacement + i); + } else if (capacity != newCapacity) { + LispObject[] newElements = new LispObject[newCapacity]; + System.arraycopy(elements, 0, newElements, 0, + Math.min(capacity, newCapacity)); + elements = newElements; + } + // Initialize new elements (if any). + if (initialElement != null) + for (int i = capacity; i < newCapacity; i++) + elements[i] = initialElement; + } + capacity = newCapacity; + array = null; + displacement = 0; + isDisplaced = false; + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + capacity = newCapacity; + array = displacedTo; + this.displacement = displacement; + elements = null; + isDisplaced = true; + return this; + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexVector_UnsignedByte32.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,431 @@ +/* + * ComplexVector_UnsignedByte32.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: ComplexVector_UnsignedByte32.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// A specialized vector of element type (UNSIGNED-BYTE 32) that is displaced to +// another array, has a fill pointer, and/or is expressly adjustable. +public final class ComplexVector_UnsignedByte32 extends AbstractVector +{ + private int capacity; + private int fillPointer = -1; // -1 indicates no fill pointer. + private boolean isDisplaced; + + // For non-displaced arrays. + private LispObject[] elements; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexVector_UnsignedByte32(int capacity) + { + elements = new LispObject[capacity]; + for (int i = capacity; i-- > 0;) + elements[i] = Fixnum.ZERO; + this.capacity = capacity; + } + + public ComplexVector_UnsignedByte32(int capacity, AbstractArray array, + int displacement) + { + this.capacity = capacity; + this.array = array; + this.displacement = displacement; + isDisplaced = true; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.VECTOR, UNSIGNED_BYTE_32, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.VECTOR; + } + + @Override + public boolean hasFillPointer() + { + return fillPointer >= 0; + } + + @Override + public int getFillPointer() + { + return fillPointer; + } + + @Override + public void setFillPointer(int n) + { + fillPointer = n; + } + + @Override + public void setFillPointer(LispObject obj) throws ConditionThrowable + { + if (obj == T) + fillPointer = capacity(); + else { + int n = Fixnum.getValue(obj); + if (n > capacity()) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") exceeds the capacity of the vector ("); + sb.append(capacity()); + sb.append(")."); + error(new LispError(sb.toString())); + } else if (n < 0) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") is negative."); + error(new LispError(sb.toString())); + } else + fillPointer = n; + } + } + + @Override + public boolean isDisplaced() + { + return isDisplaced; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_32; + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return fillPointer >= 0 ? fillPointer : capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + final int limit = length(); + if (index < 0 || index >= limit) + badIndex(index, limit); + return AREF(index); + } + + // Ignores fill pointer. + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (elements != null) { + try { + return elements[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + return NIL; // Not reached. + } + } else { + // Displaced array. + if (index < 0 || index >= capacity) + badIndex(index, capacity); + return array.AREF(index + displacement); + } + } + + // Ignores fill pointer. + // FIXME inline + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + return AREF(Fixnum.getValue(index)); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (elements != null) { + try { + elements[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + } + } else { + // Displaced array. + if (index < 0 || index >= capacity) + badIndex(index, capacity); + else + array.aset(index + displacement, newValue); + } + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + SimpleVector v = new SimpleVector(end - start); + int i = start, j = 0; + try { + while (i < end) + v.aset(j++, AREF(i++)); + return v; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + for (int i = capacity; i-- > 0;) + elements[i] = obj; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (elements != null) { + if (n < elements.length) { + LispObject[] newArray = new LispObject[n]; + System.arraycopy(elements, 0, newArray, 0, n); + elements = newArray; + capacity = n; + return; + } + if (n == elements.length) + return; + } + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + int length = length(); + SimpleVector result = new SimpleVector(length); + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + result.aset(i, AREF(j)); + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + if (elements != null) { + int i = 0; + int j = length() - 1; + while (i < j) { + LispObject temp = elements[i]; + elements[i] = elements[j]; + elements[j] = temp; + ++i; + --j; + } + } else { + // Displaced array. + int length = length(); + LispObject[] data = new LispObject[length]; + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + data[i] = AREF(j); + elements = data; + capacity = length; + array = null; + displacement = 0; + isDisplaced = false; + fillPointer = -1; + } + return this; + } + + @Override + public void vectorPushExtend(LispObject element) + throws ConditionThrowable + { + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) { + // Need to extend vector. + ensureCapacity(capacity * 2 + 1); + } + aset(fillPointer, element); + ++fillPointer; + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element) + throws ConditionThrowable + { + vectorPushExtend(element); + return new Fixnum(fillPointer - 1); + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element, LispObject extension) + throws ConditionThrowable + { + int ext = Fixnum.getValue(extension); + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) { + // Need to extend vector. + ext = Math.max(ext, capacity + 1); + ensureCapacity(capacity + ext); + } + aset(fillPointer, element); + return new Fixnum(fillPointer++); + } + + private final void ensureCapacity(int minCapacity) throws ConditionThrowable + { + if (elements != null) { + if (capacity < minCapacity) { + LispObject[] newArray = new LispObject[minCapacity]; + System.arraycopy(elements, 0, newArray, 0, capacity); + elements = newArray; + capacity = minCapacity; + } + } else { + // Displaced array. + Debug.assertTrue(array != null); + if (capacity < minCapacity || + array.getTotalSize() - displacement < minCapacity) + { + // Copy array. + elements = new LispObject[minCapacity]; + final int limit = + Math.min(capacity, array.getTotalSize() - displacement); + for (int i = 0; i < limit; i++) + elements[i] = array.AREF(displacement + i); + capacity = minCapacity; + array = null; + displacement = 0; + isDisplaced = false; + } + } + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) { + // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE- + // ARRAY. In this case none of the original contents of array + // appears in the resulting array." + LispObject[] newElements = new LispObject[newCapacity]; + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + newElements[i] = list.car(); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + newElements[i] = initialContents.elt(i); + } else + error(new TypeError(initialContents, Symbol.SEQUENCE)); + elements = newElements; + } else { + if (elements == null) { + // Displaced array. Copy existing elements. + elements = new LispObject[newCapacity]; + final int limit = Math.min(capacity, newCapacity); + for (int i = 0; i < limit; i++) + elements[i] = array.AREF(displacement + i); + } else if (capacity != newCapacity) { + LispObject[] newElements = new LispObject[newCapacity]; + System.arraycopy(elements, 0, newElements, 0, + Math.min(capacity, newCapacity)); + elements = newElements; + } + // Initialize new elements (if aapplicable). + if (initialElement != null) { + for (int i = capacity; i < newCapacity; i++) + elements[i] = initialElement; + } + } + capacity = newCapacity; + array = null; + displacement = 0; + isDisplaced = false; + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + capacity = newCapacity; + array = displacedTo; + this.displacement = displacement; + elements = null; + isDisplaced = true; + return this; + } +} Added: branches/save-image/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ComplexVector_UnsignedByte8.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,444 @@ +/* + * ComplexVector_UnsignedByte8.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: ComplexVector_UnsignedByte8.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// A specialized vector of element type (UNSIGNED-BYTE 8) that is displaced to +// another array, has a fill pointer, and/or is expressly adjustable. +public final class ComplexVector_UnsignedByte8 extends AbstractVector +{ + private int capacity; + private int fillPointer = -1; // -1 indicates no fill pointer. + private boolean isDisplaced; + + // For non-displaced arrays. + private byte[] elements; + + // For displaced arrays. + private AbstractArray array; + private int displacement; + + public ComplexVector_UnsignedByte8(int capacity) + { + elements = new byte[capacity]; + this.capacity = capacity; + } + + public ComplexVector_UnsignedByte8(int capacity, AbstractArray array, + int displacement) + { + this.capacity = capacity; + this.array = array; + this.displacement = displacement; + isDisplaced = true; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.VECTOR, UNSIGNED_BYTE_8, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.VECTOR; + } + + @Override + public boolean hasFillPointer() + { + return fillPointer >= 0; + } + + @Override + public int getFillPointer() + { + return fillPointer; + } + + @Override + public void setFillPointer(int n) + { + fillPointer = n; + } + + @Override + public void setFillPointer(LispObject obj) throws ConditionThrowable + { + if (obj == T) + fillPointer = capacity(); + else { + int n = Fixnum.getValue(obj); + if (n > capacity()) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") exceeds the capacity of the vector ("); + sb.append(capacity()); + sb.append(")."); + error(new LispError(sb.toString())); + } else if (n < 0) { + StringBuffer sb = new StringBuffer("The new fill pointer ("); + sb.append(n); + sb.append(") is negative."); + error(new LispError(sb.toString())); + } else + fillPointer = n; + } + } + + @Override + public boolean isDisplaced() + { + return isDisplaced; + } + + @Override + public LispObject arrayDisplacement() throws ConditionThrowable + { + LispObject value1, value2; + if (array != null) { + value1 = array; + value2 = new Fixnum(displacement); + } else { + value1 = NIL; + value2 = Fixnum.ZERO; + } + return LispThread.currentThread().setValues(value1, value2); + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_8; + } + + @Override + public boolean isSimpleVector() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return fillPointer >= 0 ? fillPointer : capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + final int limit = length(); + if (index < 0 || index >= limit) + badIndex(index, limit); + return AREF(index); + } + + // Ignores fill pointer. + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (elements != null) { + try { + return coerceJavaByteToLispObject(elements[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + return NIL; // Not reached. + } + } else { + // Displaced array. + if (index < 0 || index >= capacity) + badIndex(index, capacity); + return array.AREF(index + displacement); + } + } + + // Ignores fill pointer. + // FIXME inline + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + return AREF(Fixnum.getValue(index)); + } + + @Override + public void aset(int index, int n) throws ConditionThrowable + { + if (elements != null) { + try { + elements[index] = (byte) n; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + } + } else { + // Displaced array. + if (index < 0 || index >= capacity) + badIndex(index, capacity); + else + array.aset(index + displacement, n); + } + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (elements != null) { + try { + elements[index] = coerceLispObjectToJavaByte(newValue); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, elements.length); + } + } else + array.aset(index + displacement, newValue); + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + SimpleVector v = new SimpleVector(end - start); + int i = start, j = 0; + try { + while (i < end) + v.aset(j++, AREF(i++)); + return v; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + byte b = (byte) Fixnum.getValue(obj); + for (int i = capacity; i-- > 0;) + elements[i] = b; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (elements != null) { + if (n < elements.length) { + byte[] newArray = new byte[n]; + System.arraycopy(elements, 0, newArray, 0, n); + elements = newArray; + capacity = n; + return; + } + if (n == elements.length) + return; + } + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + int length = length(); + BasicVector_UnsignedByte8 result = new BasicVector_UnsignedByte8(length); + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + result.aset(i, AREF(j)); + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + if (elements != null) { + int i = 0; + int j = length() - 1; + while (i < j) { + byte temp = elements[i]; + elements[i] = elements[j]; + elements[j] = temp; + ++i; + --j; + } + } else { + // Displaced array. + int length = length(); + byte[] data = new byte[length]; + int i, j; + for (i = 0, j = length - 1; i < length; i++, j--) + data[i] = coerceLispObjectToJavaByte(AREF(j)); + elements = data; + capacity = length; + array = null; + displacement = 0; + isDisplaced = false; + fillPointer = -1; + } + return this; + } + + @Override + public void vectorPushExtend(LispObject element) throws ConditionThrowable + { + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) { + // Need to extend vector. + ensureCapacity(capacity * 2 + 1); + } + aset(fillPointer, element); + ++fillPointer; + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element) + throws ConditionThrowable + { + vectorPushExtend(element); + return new Fixnum(fillPointer - 1); + } + + @Override + public LispObject VECTOR_PUSH_EXTEND(LispObject element, LispObject extension) + throws ConditionThrowable + { + int ext = Fixnum.getValue(extension); + if (fillPointer < 0) + noFillPointer(); + if (fillPointer >= capacity) { + // Need to extend vector. + ext = Math.max(ext, capacity + 1); + ensureCapacity(capacity + ext); + } + aset(fillPointer, element); + return new Fixnum(fillPointer++); + } + + private final void ensureCapacity(int minCapacity) throws ConditionThrowable + { + if (elements != null) { + if (capacity < minCapacity) { + byte[] newArray = new byte[minCapacity]; + System.arraycopy(elements, 0, newArray, 0, capacity); + elements = newArray; + capacity = minCapacity; + } + } else { + // Displaced array. + Debug.assertTrue(array != null); + if (capacity < minCapacity || + array.getTotalSize() - displacement < minCapacity) + { + // Copy array. + elements = new byte[minCapacity]; + final int limit = + Math.min(capacity, array.getTotalSize() - displacement); + for (int i = 0; i < limit; i++) + elements[i] = coerceLispObjectToJavaByte(array.AREF(displacement + i)); + capacity = minCapacity; + array = null; + displacement = 0; + isDisplaced = false; + } + } + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) { + // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE- + // ARRAY. In this case none of the original contents of array + // appears in the resulting array." + byte[] newElements = new byte[newCapacity]; + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + newElements[i] = coerceLispObjectToJavaByte(list.car()); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + newElements[i] = coerceLispObjectToJavaByte(initialContents.elt(i)); + } else + error(new TypeError(initialContents, Symbol.SEQUENCE)); + elements = newElements; + } else { + if (elements == null) { + // Displaced array. Copy existing elements. + elements = new byte[newCapacity]; + final int limit = Math.min(capacity, newCapacity); + for (int i = 0; i < limit; i++) + elements[i] = coerceLispObjectToJavaByte(array.AREF(displacement + i)); + } else if (capacity != newCapacity) { + byte[] newElements = new byte[newCapacity]; + System.arraycopy(elements, 0, newElements, 0, + Math.min(capacity, newCapacity)); + elements = newElements; + } + // Initialize new elements (if aapplicable). + if (initialElement != null) { + byte b = coerceLispObjectToJavaByte(initialElement); + for (int i = capacity; i < newCapacity; i++) + elements[i] = b; + } + } + capacity = newCapacity; + array = null; + displacement = 0; + isDisplaced = false; + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + capacity = newCapacity; + array = displacedTo; + this.displacement = displacement; + elements = null; + isDisplaced = true; + return this; + } +} Added: branches/save-image/src/org/armedbear/lisp/ConcatenatedStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ConcatenatedStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,284 @@ +/* + * ConcatenatedStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: ConcatenatedStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ConcatenatedStream extends Stream +{ + private LispObject streams; + + private ConcatenatedStream(LispObject streams) throws ConditionThrowable + { + this.streams = streams; + isInputStream = true; + } + + @Override + public boolean isCharacterInputStream() throws ConditionThrowable + { + if (streams == NIL) + return true; + return ((Stream)streams.car()).isCharacterInputStream(); + } + + @Override + public boolean isBinaryInputStream() throws ConditionThrowable + { + if (streams == NIL) + return true; + return ((Stream)streams.car()).isBinaryInputStream(); + } + + @Override + public boolean isCharacterOutputStream() throws ConditionThrowable + { + return false; + } + + @Override + public boolean isBinaryOutputStream() throws ConditionThrowable + { + return false; + } + + @Override + public LispObject typeOf() + { + return Symbol.CONCATENATED_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.CONCATENATED_STREAM; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.CONCATENATED_STREAM) + return T; + if (typeSpecifier == BuiltInClass.CONCATENATED_STREAM) + return T; + return super.typep(typeSpecifier); + } + + @Override + public LispObject getElementType() throws ConditionThrowable + { + if (streams == NIL) + return NIL; + return ((Stream)streams.car()).getElementType(); + } + + @Override + public LispObject readCharNoHang(boolean eofError, LispObject eofValue) + throws ConditionThrowable + { + if (streams == NIL) { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + return _charReady() ? readChar(eofError, eofValue) : NIL; + } + + @Override + public LispObject listen() throws ConditionThrowable + { + if (unreadChar >= 0) + return T; + if (streams == NIL) + return NIL; + LispObject obj = readCharNoHang(false, this); + if (obj == this) + return NIL; + unreadChar = ((LispCharacter)obj).getValue(); + return T; + } + + private int unreadChar = -1; + + // Returns -1 at end of file. + @Override + protected int _readChar() throws ConditionThrowable + { + int n; + if (unreadChar >= 0) { + n = unreadChar; + unreadChar = -1; + return n; + } + if (streams == NIL) + return -1; + Stream stream = (Stream) streams.car(); + n = stream._readChar(); + if (n >= 0) + return n; + streams = streams.cdr(); + return _readChar(); + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + if (unreadChar >= 0) + error(new StreamError(this, "UNREAD-CHAR was invoked twice consecutively without an intervening call to READ-CHAR.")); + unreadChar = n; + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + if (unreadChar >= 0) + return true; + if (streams == NIL) + return false; + Stream stream = (Stream) streams.car(); + if (stream._charReady()) + return true; + LispObject remainingStreams = streams.cdr(); + while (remainingStreams != NIL) { + stream = (Stream) remainingStreams.car(); + if (stream._charReady()) + return true; + remainingStreams = remainingStreams.cdr(); + } + return false; + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + outputStreamError(); + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + outputStreamError(); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + outputStreamError(); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + outputStreamError(); + } + + // Reads an 8-bit byte. + @Override + public int _readByte() throws ConditionThrowable + { + if (streams == NIL) + return -1; + Stream stream = (Stream) streams.car(); + int n = stream._readByte(); + if (n >= 0) + return n; + streams = streams.cdr(); + return _readByte(); + } + + // Writes an 8-bit byte. + @Override + public void _writeByte(int n) throws ConditionThrowable + { + outputStreamError(); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + outputStreamError(); + } + + @Override + public void _clearInput() throws ConditionThrowable + { + // FIXME + } + + private void outputStreamError() throws ConditionThrowable + { + error(new StreamError(this, + String.valueOf(this) + " is not an output stream.")); + } + + // ### make-concatenated-stream &rest streams => concatenated-stream + private static final Primitive MAKE_CONCATENATED_STREAM = + new Primitive("make-concatenated-stream", "&rest streams") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject streams = NIL; + for (int i = 0; i < args.length; i++) { + if (args[i] instanceof Stream) { + Stream stream = (Stream) args[i]; + if (stream.isInputStream()) { + // streams[i] = (Stream) args[i]; + streams = new Cons(stream, streams); + continue; + } + } + error(new TypeError(String.valueOf(args[i]) + + " is not an input stream.")); + } + return new ConcatenatedStream(streams.nreverse()); + } + }; + + // ### concatenated-stream-streams concatenated-stream => streams + private static final Primitive CONCATENATED_STREAM_STREAMS = + new Primitive("concatenated-stream-streams", "concatenated-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((ConcatenatedStream)arg).streams; + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.CONCATENATED_STREAM)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Condition.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Condition.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,224 @@ +/* + * Condition.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Condition.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Condition extends StandardObject +{ + protected String message; + + public Condition() throws ConditionThrowable + { + super(StandardClass.CONDITION); + Debug.assertTrue(slots.length == 2); + setFormatArguments(NIL); + } + + protected Condition(LispClass cls) throws ConditionThrowable + { + super(cls); + Debug.assertTrue(slots.length >= 2); + setFormatArguments(NIL); + } + + public Condition(LispClass cls, int length) + { + super(cls, length); + } + + public Condition(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.CONDITION); + Debug.assertTrue(slots.length == 2); + initialize(initArgs); + } + + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + LispObject control = null; + LispObject arguments = null; + LispObject first, second; + while (initArgs instanceof Cons) + { + first = initArgs.car(); + initArgs = initArgs.cdr(); + second = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.FORMAT_CONTROL) + { + if (control == null) + control = second; + } + else if (first == Keyword.FORMAT_ARGUMENTS) + { + if (arguments == null) + arguments = second; + } + } + if (control != null) + setFormatControl(control); + if (arguments == null) + arguments = NIL; + setFormatArguments(arguments); + } + + public Condition(String message) + { + super(StandardClass.CONDITION); + Debug.assertTrue(slots.length == 2); + try + { + setFormatControl(message); + setFormatArguments(NIL); + } + catch (Throwable t) + { + Debug.trace(t); + } + } + + public final LispObject getFormatControl() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.FORMAT_CONTROL); + } + + public final void setFormatControl(LispObject formatControl) + throws ConditionThrowable + { + setInstanceSlotValue(Symbol.FORMAT_CONTROL, formatControl); + } + + public final void setFormatControl(String s) throws ConditionThrowable + { + setFormatControl(new SimpleString(s)); + } + + public final LispObject getFormatArguments() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.FORMAT_ARGUMENTS); + } + + public final void setFormatArguments(LispObject formatArguments) + throws ConditionThrowable + { + setInstanceSlotValue(Symbol.FORMAT_ARGUMENTS, formatArguments); + } + + public String getMessage() throws ConditionThrowable + { + return message; + } + + @Override + public LispObject typeOf() + { + LispClass c = getLispClass(); + if (c != null) + return c.getSymbol(); + return Symbol.CONDITION; + } + + @Override + public LispObject classOf() + { + LispClass c = getLispClass(); + if (c != null) + return c; + return StandardClass.CONDITION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.CONDITION) + return T; + if (type == StandardClass.CONDITION) + return T; + return super.typep(type); + } + + public String getConditionReport() throws ConditionThrowable + { + String s = getMessage(); + if (s != null) + return s; + LispObject formatControl = getFormatControl(); + if (formatControl != NIL) + { + try + { + return format(formatControl, getFormatArguments()); + } + catch (Throwable t) {} + } + return unreadableString(typeOf().writeToString()); + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (Symbol.PRINT_ESCAPE.symbolValue(thread) == NIL) + { + String s = getMessage(); + if (s != null) + return s; + LispObject formatControl = getFormatControl(); + if (formatControl instanceof Function) + { + StringOutputStream stream = new StringOutputStream(); + Symbol.APPLY.execute(formatControl, stream, getFormatArguments()); + return stream.getString().getStringValue(); + } + if (formatControl instanceof AbstractString) + { + LispObject f = Symbol.FORMAT.getSymbolFunction(); + if (f == null || f instanceof Autoload) + return format(formatControl, getFormatArguments()); + return Symbol.APPLY.execute(f, NIL, formatControl, getFormatArguments()).getStringValue(); + } + } + final int maxLevel; + LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + else + maxLevel = Integer.MAX_VALUE; + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = ((Fixnum)currentPrintLevel).value; + if (currentLevel >= maxLevel) + return "#"; + return unreadableString(typeOf().writeToString()); + } +} Added: branches/save-image/src/org/armedbear/lisp/ConditionThrowable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ConditionThrowable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,67 @@ +/* + * ConditionThrowable.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ConditionThrowable.java 11413 2008-12-03 22:52:02Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class ConditionThrowable extends Throwable +{ + public Condition condition; + + public ConditionThrowable() + { + } + /** + * Overridden in order to make ConditionThrowable construct + * faster. This avoids gathering stack trace information. + */ + @Override + public Throwable fillInStackTrace() + { + return this; + } + + public ConditionThrowable(Condition condition) + { + this.condition = condition; + } + + public ConditionThrowable(String message) + { + super(message); + } + + public LispObject getCondition() throws ConditionThrowable + { + return condition != null ? condition : new Condition(); + } +} Added: branches/save-image/src/org/armedbear/lisp/Cons.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Cons.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,721 @@ +/* + * Cons.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Cons.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Cons extends LispObject +{ + public LispObject car; + public LispObject cdr; + + public Cons(LispObject car, LispObject cdr) + { + this.car = car; + this.cdr = cdr; + ++count; + } + + public Cons(LispObject car) + { + this.car = car; + this.cdr = NIL; + ++count; + } + + public Cons(String name, LispObject value) + { + this.car = new SimpleString(name); + this.cdr = value != null ? value : NULL_VALUE; + ++count; + } + + @Override + public LispObject typeOf() + { + return Symbol.CONS; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.CONS; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier instanceof Symbol) + { + if (typeSpecifier == Symbol.LIST) + return T; + if (typeSpecifier == Symbol.CONS) + return T; + if (typeSpecifier == Symbol.SEQUENCE) + return T; + if (typeSpecifier == T) + return T; + } + else if (typeSpecifier instanceof BuiltInClass) + { + if (typeSpecifier == BuiltInClass.LIST) + return T; + if (typeSpecifier == BuiltInClass.CONS) + return T; + if (typeSpecifier == BuiltInClass.SEQUENCE) + return T; + if (typeSpecifier == BuiltInClass.CLASS_T) + return T; + } + return NIL; + } + + @Override + public final boolean constantp() + { + if (car == Symbol.QUOTE) + { + if (cdr instanceof Cons) + if (((Cons)cdr).cdr == NIL) + return true; + } + return false; + } + + @Override + public LispObject ATOM() + { + return NIL; + } + + @Override + public boolean atom() + { + return false; + } + + @Override + public final LispObject car() + { + return car; + } + + @Override + public final LispObject cdr() + { + return cdr; + } + + @Override + public final void setCar(LispObject obj) + { + car = obj; + } + + @Override + public LispObject RPLACA(LispObject obj) throws ConditionThrowable + { + car = obj; + return this; + } + + @Override + public final void setCdr(LispObject obj) + { + cdr = obj; + } + + @Override + public LispObject RPLACD(LispObject obj) throws ConditionThrowable + { + cdr = obj; + return this; + } + + @Override + public final LispObject cadr() throws ConditionThrowable + { + return cdr.car(); + } + + @Override + public final LispObject cddr() throws ConditionThrowable + { + return cdr.cdr(); + } + + @Override + public final LispObject caddr() throws ConditionThrowable + { + return cdr.cadr(); + } + + @Override + public LispObject nthcdr(int n) throws ConditionThrowable + { + if (n < 0) + return type_error(new Fixnum(n), + list2(Symbol.INTEGER, Fixnum.ZERO)); + LispObject result = this; + for (int i = n; i-- > 0;) + { + result = result.cdr(); + if (result == NIL) + break; + } + return result; + } + + @Override + public final LispObject push(LispObject obj) + { + return new Cons(obj, this); + } + + @Override + public final int sxhash() + { + return computeHash(this, 4); + } + + private static final int computeHash(LispObject obj, int depth) + { + if (obj instanceof Cons) + { + if (depth > 0) + { + int n1 = computeHash(((Cons)obj).car, depth - 1); + int n2 = computeHash(((Cons)obj).cdr, depth - 1); + return n1 ^ n2; + } + else + { + // This number comes from SBCL, but since we're not really + // using SBCL's SXHASH algorithm, it's probably not optimal. + // But who knows? + return 261835505; + } + } + else + return obj.sxhash(); + } + + @Override + public final int psxhash() //throws ConditionThrowable + { + return computeEqualpHash(this, 4); + } + + private static final int computeEqualpHash(LispObject obj, int depth) + { + if (obj instanceof Cons) + { + if (depth > 0) + { + int n1 = computeEqualpHash(((Cons)obj).car, depth - 1); + int n2 = computeEqualpHash(((Cons)obj).cdr, depth - 1); + return n1 ^ n2; + } + else + return 261835505; // See above. + } + else + return obj.psxhash(); + } + + @Override + public final boolean equal(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof Cons) + { + if (car.equal(((Cons)obj).car) && cdr.equal(((Cons)obj).cdr)) + return true; + } + return false; + } + + @Override + public final boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof Cons) + { + if (car.equalp(((Cons)obj).car) && cdr.equalp(((Cons)obj).cdr)) + return true; + } + return false; + } + + @Override + public final int length() throws ConditionThrowable + { + int length = 0; + LispObject obj = this; + try + { + while (obj != NIL) + { + ++length; + obj = ((Cons)obj).cdr; + } + } + catch (ClassCastException e) + { + type_error(obj, Symbol.LIST); + } + return length; + } + + @Override + public LispObject NTH(int index) throws ConditionThrowable + { + if (index < 0) + type_error(new Fixnum(index), Symbol.UNSIGNED_BYTE); + int i = 0; + LispObject obj = this; + while (true) + { + if (i == index) + return obj.car(); + obj = obj.cdr(); + if (obj == NIL) + return NIL; + ++i; + } + } + + @Override + public LispObject NTH(LispObject arg) throws ConditionThrowable + { + int index; + try + { + index = ((Fixnum)arg).value; + } + catch (ClassCastException e) + { + if (arg instanceof Bignum) + { + // FIXME (when machines have enough memory for it to matter) + if (arg.minusp()) + return type_error(arg, Symbol.UNSIGNED_BYTE); + return NIL; + } + return type_error(arg, Symbol.UNSIGNED_BYTE); + } + if (index < 0) + type_error(arg, Symbol.UNSIGNED_BYTE); + int i = 0; + LispObject obj = this; + while (true) + { + if (i == index) + return obj.car(); + obj = obj.cdr(); + if (obj == NIL) + return NIL; + ++i; + } + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + if (index < 0) + type_error(new Fixnum(index), Symbol.UNSIGNED_BYTE); + int i = 0; + Cons cons = this; + while (true) + { + if (i == index) + return cons.car; + try + { + cons = (Cons) cons.cdr; + } + catch (ClassCastException e) + { + if (cons.cdr == NIL) + { + // Index too large. + type_error(new Fixnum(index), + list3(Symbol.INTEGER, Fixnum.ZERO, + new Fixnum(length() - 1))); + } + else + { + // Dotted list. + type_error(cons.cdr, Symbol.LIST); + } + // Not reached. + return NIL; + } + ++i; + } + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + Cons cons = this; + LispObject result = new Cons(cons.car); + while (cons.cdr instanceof Cons) + { + cons = (Cons) cons.cdr; + result = new Cons(cons.car, result); + } + if (cons.cdr != NIL) + return type_error(cons.cdr, Symbol.LIST); + return result; + } + + @Override + public final LispObject nreverse() throws ConditionThrowable + { + if (cdr instanceof Cons) + { + Cons cons = (Cons) cdr; + if (cons.cdr instanceof Cons) + { + Cons cons1 = cons; + LispObject list = NIL; + do + { + Cons temp = (Cons) cons.cdr; + cons.cdr = list; + list = cons; + cons = temp; + } + while (cons.cdr instanceof Cons); + if (cons.cdr != NIL) + return type_error(cons.cdr, Symbol.LIST); + cdr = list; + cons1.cdr = cons; + } + else if (cons.cdr != NIL) + return type_error(cons.cdr, Symbol.LIST); + LispObject temp = car; + car = cons.car; + cons.car = temp; + } + else if (cdr != NIL) + return type_error(cdr, Symbol.LIST); + return this; + } + + @Override + public final boolean listp() + { + return true; + } + + @Override + public final LispObject LISTP() + { + return T; + } + + @Override + public final boolean endp() + { + return false; + } + + @Override + public final LispObject ENDP() + { + return NIL; + } + + @Override + public final LispObject[] copyToArray() throws ConditionThrowable + { + final int length = length(); + LispObject[] array = new LispObject[length]; + LispObject rest = this; + for (int i = 0; i < length; i++) + { + array[i] = rest.car(); + rest = rest.cdr(); + } + return array; + } + + @Override + public LispObject execute() throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(arg); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second, third); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second, third, fourth); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second, third, fourth, fifth); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second, third, fourth, fifth, sixth); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second, third, fourth, fifth, sixth, + seventh); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(first, second, third, fourth, fifth, sixth, + seventh, eighth); + } + return signalExecutionError(); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (car == Symbol.LAMBDA) + { + Closure closure = new Closure(this, new Environment()); + return closure.execute(args); + } + return signalExecutionError(); + } + + private final LispObject signalExecutionError() throws ConditionThrowable + { + return type_error(this, list3(Symbol.OR, Symbol.FUNCTION, + Symbol.SYMBOL)); + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final LispObject printLength = Symbol.PRINT_LENGTH.symbolValue(thread); + final int maxLength; + if (printLength instanceof Fixnum) + maxLength = ((Fixnum)printLength).value; + else + maxLength = Integer.MAX_VALUE; + final LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); + final int maxLevel; + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + else + maxLevel = Integer.MAX_VALUE; + FastStringBuffer sb = new FastStringBuffer(); + if (car == Symbol.QUOTE) + { + if (cdr instanceof Cons) + { + // Not a dotted list. + if (cdr.cdr() == NIL) + { + sb.append('\''); + sb.append(cdr.car().writeToString()); + return sb.toString(); + } + } + } + if (car == Symbol.FUNCTION) + { + if (cdr instanceof Cons) + { + // Not a dotted list. + if (cdr.cdr() == NIL) + { + sb.append("#'"); + sb.append(cdr.car().writeToString()); + return sb.toString(); + } + } + } + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = Fixnum.getValue(currentPrintLevel); + if (currentLevel < maxLevel) + { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(_CURRENT_PRINT_LEVEL_, currentPrintLevel.incr()); + try + { + int count = 0; + boolean truncated = false; + sb.append('('); + if (count < maxLength) + { + LispObject p = this; + sb.append(p.car().writeToString()); + ++count; + while ((p = p.cdr()) instanceof Cons) + { + sb.append(' '); + if (count < maxLength) + { + sb.append(p.car().writeToString()); + ++count; + } + else + { + truncated = true; + break; + } + } + if (!truncated && p != NIL) + { + sb.append(" . "); + sb.append(p.writeToString()); + } + } + else + truncated = true; + if (truncated) + sb.append("..."); + sb.append(')'); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + else + sb.append('#'); + return sb.toString(); + } + + // Statistics for TIME. + private static long count; + + /*package*/ static long getCount() + { + return count; + } + + /*package*/ static void setCount(long n) + { + count = n; + } +} Added: branches/save-image/src/org/armedbear/lisp/ControlError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ControlError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,72 @@ +/* + * ControlError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ControlError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ControlError extends LispError +{ + public ControlError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.CONTROL_ERROR); + initialize(initArgs); + } + + public ControlError(String message) throws ConditionThrowable + { + super(StandardClass.CONTROL_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + } + + @Override + public LispObject typeOf() + { + return Symbol.CONTROL_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.CONTROL_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.CONTROL_ERROR) + return T; + if (type == StandardClass.CONTROL_ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Debug.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Debug.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,63 @@ +/* + * Debug.java + * + * Copyright (C) 2002-2003 Peter Graves + * $Id: Debug.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Debug extends Lisp +{ + public static final void assertTrue(boolean b) + { + if (!b) { + System.err.println("Assertion failed!"); + Error e = new Error(); + e.printStackTrace(); + throw e; + } + } + + // Does not throw an exception. + public static void bug() + { + trace(new Exception("BUG!")); + } + + public static final void trace(String s) + { + System.err.println(s); + } + + public static final void trace(Throwable t) + { + t.printStackTrace(); + } +} Added: branches/save-image/src/org/armedbear/lisp/DispatchMacroFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/DispatchMacroFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,81 @@ +/* + * DispatchMacroFunction.java + * + * Copyright (C) 2004 Peter Graves + * $Id: DispatchMacroFunction.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class DispatchMacroFunction extends Function +{ + public DispatchMacroFunction(String name) + { + super(name); + } + + public DispatchMacroFunction(String name, String arglist) + { + super(name, arglist); + } + + public DispatchMacroFunction(String name, Package pkg) + { + super(name, pkg); + } + + public DispatchMacroFunction(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public DispatchMacroFunction(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + Stream stream = inSynonymOf(first); + char c = LispCharacter.getValue(second); + int n; + if (third == NIL) + n = -1; + else + n = Fixnum.getValue(third); + return execute(stream, c, n); + } + + public abstract LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable; +} Added: branches/save-image/src/org/armedbear/lisp/DivisionByZero.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/DivisionByZero.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,71 @@ +/* + * DivisionByZero.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: DivisionByZero.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class DivisionByZero extends ArithmeticError +{ + public DivisionByZero() throws ConditionThrowable + { + super(StandardClass.DIVISION_BY_ZERO); + setFormatControl("Arithmetic error DIVISION-BY-ZERO signalled."); + } + + public DivisionByZero(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.DIVISION_BY_ZERO); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.DIVISION_BY_ZERO; + } + + @Override + public LispObject classOf() + { + return StandardClass.DIVISION_BY_ZERO; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.DIVISION_BY_ZERO) + return T; + if (type == StandardClass.DIVISION_BY_ZERO) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Do.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Do.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,267 @@ +/* + * Do.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: Do.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Do extends Lisp +{ + // ### do + private static final SpecialOperator DO = + new SpecialOperator(Symbol.DO, "varlist endlist &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + return _do(args, env, false); + } + }; + + // ### do* + private static final SpecialOperator DO_STAR = + new SpecialOperator(Symbol.DO_STAR, "varlist endlist &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + return _do(args, env, true); + } + }; + + private static final LispObject _do(LispObject args, Environment env, + boolean sequential) + throws ConditionThrowable + { + LispObject varlist = args.car(); + LispObject second = args.cadr(); + LispObject end_test_form = second.car(); + LispObject result_forms = second.cdr(); + LispObject body = args.cddr(); + // Process variable specifications. + final int numvars = varlist.length(); + Symbol[] vars = new Symbol[numvars]; + LispObject[] initforms = new LispObject[numvars]; + LispObject[] stepforms = new LispObject[numvars]; + for (int i = 0; i < numvars; i++) + { + final LispObject varspec = varlist.car(); + if (varspec instanceof Cons) + { + vars[i] = checkSymbol(varspec.car()); + initforms[i] = varspec.cadr(); + // Is there a step form? + if (varspec.cddr() != NIL) + stepforms[i] = varspec.caddr(); + } + else + { + // Not a cons, must be a symbol. + vars[i] = checkSymbol(varspec); + initforms[i] = NIL; + } + varlist = varlist.cdr(); + } + final LispThread thread = LispThread.currentThread(); + final LispObject stack = thread.getStack(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + // Process declarations. + LispObject specials = NIL; + while (body != NIL) + { + LispObject obj = body.car(); + if (obj instanceof Cons && obj.car() == Symbol.DECLARE) + { + LispObject decls = obj.cdr(); + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) + { + LispObject names = decl.cdr(); + while (names != NIL) + { + specials = new Cons(names.car(), specials); + names = names.cdr(); + } + } + decls = decls.cdr(); + } + body = body.cdr(); + } + else + break; + } + final Environment ext = new Environment(env); + for (int i = 0; i < numvars; i++) + { + Symbol var = vars[i]; + LispObject value = eval(initforms[i], (sequential ? ext : env), thread); + if (specials != NIL && memq(var, specials)) + thread.bindSpecial(var, value); + else if (var.isSpecialVariable()) + thread.bindSpecial(var, value); + else + ext.bind(var, value); + } + LispObject list = specials; + while (list != NIL) + { + ext.declareSpecial(checkSymbol(list.car())); + list = list.cdr(); + } + // Look for tags. + LispObject remaining = body; + while (remaining != NIL) + { + LispObject current = remaining.car(); + remaining = remaining.cdr(); + if (current instanceof Cons) + continue; + // It's a tag. + ext.addTagBinding(current, remaining); + } + try + { + // Implicit block. + ext.addBlock(NIL, new LispObject()); + while (true) + { + // Execute body. + // Test for termination. + if (eval(end_test_form, ext, thread) != NIL) + break; + remaining = body; + while (remaining != NIL) + { + LispObject current = remaining.car(); + if (current instanceof Cons) + { + try + { + // Handle GO inline if possible. + if (current.car() == Symbol.GO) + { + LispObject tag = current.cadr(); + Binding binding = ext.getTagBinding(tag); + if (binding != null && binding.value != null) + { + remaining = binding.value; + continue; + } + throw new Go(tag); + } + eval(current, ext, thread); + } + catch (Go go) + { + LispObject tag = go.getTag(); + Binding binding = ext.getTagBinding(tag); + if (binding != null && binding.value != null) + { + remaining = binding.value; + thread.setStack(stack); + continue; + } + throw go; + } + } + remaining = remaining.cdr(); + } + // Update variables. + if (sequential) + { + for (int i = 0; i < numvars; i++) + { + LispObject step = stepforms[i]; + if (step != null) + { + Symbol symbol = vars[i]; + LispObject value = eval(step, ext, thread); + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) + thread.rebindSpecial(symbol, value); + else + ext.rebind(symbol, value); + } + } + } + else + { + // Evaluate step forms. + LispObject results[] = new LispObject[numvars]; + for (int i = 0; i < numvars; i++) + { + LispObject step = stepforms[i]; + if (step != null) + { + LispObject result = eval(step, ext, thread); + results[i] = result; + } + } + // Update variables. + for (int i = 0; i < numvars; i++) + { + if (results[i] != null) + { + Symbol symbol = vars[i]; + LispObject value = results[i]; + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) + thread.rebindSpecial(symbol, value); + else + ext.rebind(symbol, value); + } + } + } + if (interrupted) + handleInterrupt(); + } + LispObject result = progn(result_forms, ext, thread); + return result; + } + catch (Return ret) + { + if (ret.getTag() == NIL) + { + thread.setStack(stack); + return ret.getResult(); + } + throw ret; + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/DoubleFloat.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/DoubleFloat.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,653 @@ +/* + * DoubleFloat.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: DoubleFloat.java 11579 2009-01-24 10:24:34Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class DoubleFloat extends LispObject +{ + public static final DoubleFloat ZERO = new DoubleFloat(0); + public static final DoubleFloat MINUS_ZERO = new DoubleFloat(-0.0d); + public static final DoubleFloat ONE = new DoubleFloat(1); + public static final DoubleFloat MINUS_ONE = new DoubleFloat(-1); + + public static final DoubleFloat DOUBLE_FLOAT_POSITIVE_INFINITY = + new DoubleFloat(Double.POSITIVE_INFINITY); + + public static final DoubleFloat DOUBLE_FLOAT_NEGATIVE_INFINITY = + new DoubleFloat(Double.NEGATIVE_INFINITY); + + static { + Symbol.DOUBLE_FLOAT_POSITIVE_INFINITY.initializeConstant(DOUBLE_FLOAT_POSITIVE_INFINITY); + Symbol.DOUBLE_FLOAT_NEGATIVE_INFINITY.initializeConstant(DOUBLE_FLOAT_NEGATIVE_INFINITY); + } + + public static DoubleFloat getInstance(double d) { + if (d == 0) + return ZERO; + else if (d == -0.0d ) + return MINUS_ZERO; + else if (d == 1) + return ONE; + else if (d == -1) + return MINUS_ONE; + else + return new DoubleFloat(d); + } + + public final double value; + + public DoubleFloat(double value) + { + this.value = value; + } + + @Override + public LispObject typeOf() + { + return Symbol.DOUBLE_FLOAT; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.DOUBLE_FLOAT; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.FLOAT) + return T; + if (typeSpecifier == Symbol.REAL) + return T; + if (typeSpecifier == Symbol.NUMBER) + return T; + if (typeSpecifier == Symbol.DOUBLE_FLOAT) + return T; + if (typeSpecifier == Symbol.LONG_FLOAT) + return T; + if (typeSpecifier == BuiltInClass.FLOAT) + return T; + if (typeSpecifier == BuiltInClass.DOUBLE_FLOAT) + return T; + return super.typep(typeSpecifier); + } + + @Override + public LispObject NUMBERP() + { + return T; + } + + @Override + public boolean numberp() + { + return true; + } + + @Override + public boolean realp() + { + return true; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof DoubleFloat) { + if (value == 0) { + // "If an implementation supports positive and negative zeros + // as distinct values, then (EQL 0.0 -0.0) returns false." + double d = ((DoubleFloat)obj).value; + long bits = Double.doubleToRawLongBits(d); + return bits == Double.doubleToRawLongBits(value); + } + if (value == ((DoubleFloat)obj).value) + return true; + } + return false; + } + + @Override + public boolean equal(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof DoubleFloat) { + if (value == 0) { + // same as EQL + double d = ((DoubleFloat)obj).value; + long bits = Double.doubleToRawLongBits(d); + return bits == Double.doubleToRawLongBits(value); + } + if (value == ((DoubleFloat)obj).value) + return true; + } + return false; + } + + @Override + public boolean equalp(int n) + { + // "If two numbers are the same under =." + return value == n; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (obj instanceof SingleFloat) + return value == ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value == ((DoubleFloat)obj).value; + if (obj instanceof Fixnum) + return value == ((Fixnum)obj).value; + if (obj instanceof Bignum) + return value == ((Bignum)obj).doubleValue(); + if (obj instanceof Ratio) + return value == ((Ratio)obj).doubleValue(); + return false; + } + + @Override + public LispObject ABS() + { + if (value > 0) + return this; + if (value == 0) // 0.0 or -0.0 + return ZERO; + return new DoubleFloat(- value); + } + + @Override + public boolean plusp() + { + return value > 0; + } + + @Override + public boolean minusp() + { + return value < 0; + } + + @Override + public boolean zerop() + { + return value == 0; + } + + @Override + public LispObject FLOATP() + { + return T; + } + + @Override + public boolean floatp() + { + return true; + } + + public static double getValue(LispObject obj) throws ConditionThrowable + { + try { + return ((DoubleFloat)obj).value; + } + catch (ClassCastException e) { + type_error(obj, Symbol.FLOAT); + // Not reached. + return 0; + } + } + + public final double getValue() + { + return value; + } + + @Override + public double doubleValue() { + return value; + } + + @Override + public Object javaInstance() + { + return Double.valueOf(value); + } + + @Override + public Object javaInstance(Class c) + { + String cn = c.getName(); + if (cn.equals("java.lang.Float") || cn.equals("float")) + return Float.valueOf((float)value); + return javaInstance(); + } + + @Override + public final LispObject incr() + { + return new DoubleFloat(value + 1); + } + + @Override + public final LispObject decr() + { + return new DoubleFloat(value - 1); + } + + @Override + public LispObject negate() + { + if (value == 0) { + long bits = Double.doubleToRawLongBits(value); + return (bits < 0) ? ZERO : MINUS_ZERO; + } + return new DoubleFloat(-value); + } + + @Override + public LispObject add(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new DoubleFloat(value + ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new DoubleFloat(value + ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value + ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new DoubleFloat(value + ((Bignum)obj).doubleValue()); + if (obj instanceof Ratio) + return new DoubleFloat(value + ((Ratio)obj).doubleValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(add(c.getRealPart()), c.getImaginaryPart()); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new DoubleFloat(value - ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new DoubleFloat(value - ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value - ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new DoubleFloat(value - ((Bignum)obj).doubleValue()); + if (obj instanceof Ratio) + return new DoubleFloat(value - ((Ratio)obj).doubleValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(subtract(c.getRealPart()), + ZERO.subtract(c.getImaginaryPart())); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new DoubleFloat(value * ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new DoubleFloat(value * ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value * ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new DoubleFloat(value * ((Bignum)obj).doubleValue()); + if (obj instanceof Ratio) + return new DoubleFloat(value * ((Ratio)obj).doubleValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(multiplyBy(c.getRealPart()), + multiplyBy(c.getImaginaryPart())); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new DoubleFloat(value / ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new DoubleFloat(value / ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value / ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new DoubleFloat(value / ((Bignum)obj).doubleValue()); + if (obj instanceof Ratio) + return new DoubleFloat(value / ((Ratio)obj).doubleValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + LispObject re = c.getRealPart(); + LispObject im = c.getImaginaryPart(); + LispObject denom = re.multiplyBy(re).add(im.multiplyBy(im)); + LispObject resX = multiplyBy(re).divideBy(denom); + LispObject resY = + multiplyBy(Fixnum.MINUS_ONE).multiplyBy(im).divideBy(denom); + return Complex.getInstance(resX, resY); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value == ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return value == ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value == ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isEqualTo(obj); + if (obj instanceof Ratio) + return rational().isEqualTo(obj); + if (obj instanceof Complex) + return obj.isEqualTo(this); + type_error(obj, Symbol.NUMBER); + // Not reached. + return false; + } + + @Override + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + return !isEqualTo(obj); + } + + @Override + public boolean isLessThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value < ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return value < ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value < ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isLessThan(obj); + if (obj instanceof Ratio) + return rational().isLessThan(obj); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value > ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return value > ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value > ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isGreaterThan(obj); + if (obj instanceof Ratio) + return rational().isGreaterThan(obj); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isLessThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value <= ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return value <= ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value <= ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isLessThanOrEqualTo(obj); + if (obj instanceof Ratio) + return rational().isLessThanOrEqualTo(obj); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value >= ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return value >= ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value >= ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isGreaterThanOrEqualTo(obj); + if (obj instanceof Ratio) + return rational().isGreaterThanOrEqualTo(obj); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public LispObject truncate(LispObject obj) throws ConditionThrowable + { + // "When rationals and floats are combined by a numerical function, + // the rational is first converted to a float of the same format." + // 12.1.4.1 + if (obj instanceof Fixnum) { + return truncate(new DoubleFloat(((Fixnum)obj).value)); + } + if (obj instanceof Bignum) { + return truncate(new DoubleFloat(((Bignum)obj).doubleValue())); + } + if (obj instanceof Ratio) { + return truncate(new DoubleFloat(((Ratio)obj).doubleValue())); + } + if (obj instanceof SingleFloat) { + final LispThread thread = LispThread.currentThread(); + double divisor = ((SingleFloat)obj).value; + double quotient = value / divisor; + if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { + int q = (int) quotient; + return thread.setValues(new Fixnum(q), + new DoubleFloat(value - q * divisor)); + } + // We need to convert the quotient to a bignum. + long bits = Double.doubleToRawLongBits((double)quotient); + int s = ((bits >> 63) == 0) ? 1 : -1; + int e = (int) ((bits >> 52) & 0x7ffL); + long m; + if (e == 0) + m = (bits & 0xfffffffffffffL) << 1; + else + m = (bits & 0xfffffffffffffL) | 0x10000000000000L; + LispObject significand = number(m); + Fixnum exponent = new Fixnum(e - 1075); + Fixnum sign = new Fixnum(s); + LispObject result = significand; + result = + result.multiplyBy(MathFunctions.EXPT.execute(Fixnum.TWO, exponent)); + result = result.multiplyBy(sign); + // Calculate remainder. + LispObject product = result.multiplyBy(obj); + LispObject remainder = subtract(product); + return thread.setValues(result, remainder); + } + if (obj instanceof DoubleFloat) { +// Debug.trace("value = " + value); + final LispThread thread = LispThread.currentThread(); + double divisor = ((DoubleFloat)obj).value; +// Debug.trace("divisor = " + divisor); + double quotient = value / divisor; +// Debug.trace("quotient = " + quotient); + if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { + int q = (int) quotient; + return thread.setValues(new Fixnum(q), + new DoubleFloat(value - q * divisor)); + } + // We need to convert the quotient to a bignum. + long bits = Double.doubleToRawLongBits((double)quotient); + int s = ((bits >> 63) == 0) ? 1 : -1; + int e = (int) ((bits >> 52) & 0x7ffL); + long m; + if (e == 0) + m = (bits & 0xfffffffffffffL) << 1; + else + m = (bits & 0xfffffffffffffL) | 0x10000000000000L; + LispObject significand = number(m); +// Debug.trace("significand = " + significand.writeToString()); + Fixnum exponent = new Fixnum(e - 1075); +// Debug.trace("exponent = " + exponent.writeToString()); + Fixnum sign = new Fixnum(s); +// Debug.trace("sign = " + sign.writeToString()); + LispObject result = significand; +// Debug.trace("result = " + result.writeToString()); + result = + result.multiplyBy(MathFunctions.EXPT.execute(Fixnum.TWO, exponent)); +// Debug.trace("result = " + result.writeToString()); + + + result = result.truncate(Fixnum.ONE); + LispObject remainder = coerceToFloat(thread._values[1]); + + result = result.multiplyBy(sign); +// Debug.trace("result = " + result.writeToString()); +// // Calculate remainder. +// LispObject product = result.multiplyBy(obj); +// Debug.trace("product = " + product.writeToString()); +// LispObject remainder = subtract(product); + return thread.setValues(result, remainder); + } + return type_error(obj, Symbol.REAL); + } + + @Override + public int hashCode() + { + long bits = Double.doubleToLongBits(value); + return (int) (bits ^ (bits >>> 32)); + } + + @Override + public int psxhash() + { + if ((value % 1) == 0) + return (((int)value) & 0x7fffffff); + else + return (hashCode() & 0x7fffffff); + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (value == Double.POSITIVE_INFINITY) { + FastStringBuffer sb = new FastStringBuffer("#."); + sb.append(Symbol.DOUBLE_FLOAT_POSITIVE_INFINITY.writeToString()); + return sb.toString(); + } + if (value == Double.NEGATIVE_INFINITY) { + FastStringBuffer sb = new FastStringBuffer("#."); + sb.append(Symbol.DOUBLE_FLOAT_NEGATIVE_INFINITY.writeToString()); + return sb.toString(); + } + if (value != value) + return "#"; + String s1 = String.valueOf(value); + LispThread thread = LispThread.currentThread(); + if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL || + !memq(Symbol.READ_DEFAULT_FLOAT_FORMAT.symbolValue(thread), + list2(Symbol.DOUBLE_FLOAT, Symbol.LONG_FLOAT))) + { + if (s1.indexOf('E') >= 0) + return s1.replace('E', 'd'); + else + return s1.concat("d0"); + } else + return s1; + } + + public LispObject rational() throws ConditionThrowable + { + final long bits = Double.doubleToRawLongBits(value); + int sign = ((bits >> 63) == 0) ? 1 : -1; + int storedExponent = (int) ((bits >> 52) & 0x7ffL); + long mantissa; + if (storedExponent == 0) + mantissa = (bits & 0xfffffffffffffL) << 1; + else + mantissa = (bits & 0xfffffffffffffL) | 0x10000000000000L; + if (mantissa == 0) + return Fixnum.ZERO; + if (sign < 0) + mantissa = -mantissa; + // Subtract bias. + final int exponent = storedExponent - 1023; + BigInteger numerator, denominator; + if (exponent < 0) { + numerator = BigInteger.valueOf(mantissa); + denominator = BigInteger.valueOf(1).shiftLeft(52 - exponent); + } else { + numerator = BigInteger.valueOf(mantissa).shiftLeft(exponent); + denominator = BigInteger.valueOf(0x10000000000000L); // (ash 1 52) + } + return number(numerator, denominator); + } + + public static DoubleFloat coerceToFloat(LispObject obj) throws ConditionThrowable + { + if (obj instanceof DoubleFloat) + return (DoubleFloat) obj; + if (obj instanceof Fixnum) + return new DoubleFloat(((Fixnum)obj).value); + if (obj instanceof Bignum) + return new DoubleFloat(((Bignum)obj).doubleValue()); + if (obj instanceof SingleFloat) + return new DoubleFloat(((SingleFloat)obj).value); + if (obj instanceof Ratio) + return new DoubleFloat(((Ratio)obj).doubleValue()); + error(new TypeError("The value " + obj.writeToString() + + " cannot be converted to type DOUBLE-FLOAT.")); + // Not reached. + return null; + } +} Added: branches/save-image/src/org/armedbear/lisp/DowncaseStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/DowncaseStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +/* + * DowncaseStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: DowncaseStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class DowncaseStream extends CaseFrobStream +{ + public DowncaseStream(Stream target) throws ConditionThrowable + { + super(target); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + target._writeChar(LispCharacter.toLowerCase(c)); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + target._writeString(s.toLowerCase()); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + target._writeLine(s.toLowerCase()); + } +} Added: branches/save-image/src/org/armedbear/lisp/EchoStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/EchoStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,288 @@ +/* + * EchoStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: EchoStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class EchoStream extends Stream +{ + private final Stream in; + private final Stream out; + + private int unreadChar = -1; + + public EchoStream(Stream in, Stream out) + { + this.in = in; + this.out = out; + } + + public EchoStream(Stream in, Stream out, boolean interactive) + { + this.in = in; + this.out = out; + setInteractive(interactive); + } + + @Override + public LispObject getElementType() throws ConditionThrowable + { + LispObject itype = in.getElementType(); + LispObject otype = out.getElementType(); + if (itype.equal(otype)) + return itype; + return Symbol.NULL; // FIXME + } + + public Stream getInputStream() + { + return in; + } + + public Stream getOutputStream() + { + return out; + } + + @Override + public LispObject typeOf() + { + return Symbol.ECHO_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.ECHO_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.ECHO_STREAM) + return T; + if (type == BuiltInClass.ECHO_STREAM) + return T; + return super.typep(type); + } + + @Override + public boolean isInputStream() + { + return true; + } + + @Override + public boolean isOutputStream() + { + return true; + } + + @Override + public boolean isCharacterInputStream() throws ConditionThrowable + { + return in.isCharacterInputStream(); + } + + @Override + public boolean isBinaryInputStream() throws ConditionThrowable + { + return in.isBinaryInputStream(); + } + + @Override + public boolean isCharacterOutputStream() throws ConditionThrowable + { + return out.isCharacterOutputStream(); + } + + @Override + public boolean isBinaryOutputStream() throws ConditionThrowable + { + return out.isBinaryOutputStream(); + } + + // Returns -1 at end of file. + @Override + protected int _readChar() throws ConditionThrowable + { + int n = in._readChar(); + if (n >= 0) { + // Not at end of file. + if (unreadChar < 0) + out._writeChar((char)n); + else + unreadChar = -1; + } + return n; + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + in._unreadChar(n); + unreadChar = n; + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + return in._charReady(); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + out._writeChar(c); + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + out._writeChars(chars, start, end); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + out._writeString(s); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + out._writeLine(s); + } + + // Reads an 8-bit byte. + @Override + public int _readByte() throws ConditionThrowable + { + int n = in._readByte(); + if (n >= 0) + out._writeByte(n); + return n; + } + + // Writes an 8-bit byte. + @Override + public void _writeByte(int n) throws ConditionThrowable + { + out._writeByte(n); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + out._finishOutput(); + } + + @Override + public void _clearInput() throws ConditionThrowable + { + in._clearInput(); + } + + @Override + public LispObject close(LispObject abort) throws ConditionThrowable + { + // "The effect of CLOSE on a constructed stream is to close the + // argument stream only. There is no effect on the constituents of + // composite streams." + setOpen(false); + return T; + } + + @Override + public LispObject listen() throws ConditionThrowable + { + return in.listen(); + } + + @Override + public LispObject freshLine() throws ConditionThrowable + { + return out.freshLine(); + } + + @Override + public String toString() + { + return unreadableString("ECHO-STREAM"); + } + + // ### make-echo-stream + // input-stream output-stream => echo-stream + private static final Primitive MAKE_ECHO_STREAM = + new Primitive("make-echo-stream", "input-stream output-stream") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (!(first instanceof Stream)) + return type_error(first, Symbol.STREAM); + if (!(second instanceof Stream)) + return type_error(second, Symbol.STREAM); + return new EchoStream((Stream) first, (Stream) second); + } + }; + + // ### echo-stream-input-stream + // echo-stream => input-stream + private static final Primitive ECHO_STREAM_INPUT_STREAM = + new Primitive("echo-stream-input-stream", "echo-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof EchoStream) + return ((EchoStream)arg).getInputStream(); + return type_error(arg, Symbol.ECHO_STREAM); + } + }; + + // ### echo-stream-output-stream + // echo-stream => output-stream + private static final Primitive ECHO_STREAM_OUTPUT_STREAM = + new Primitive("echo-stream-output-stream", "echo-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof EchoStream) + return ((EchoStream)arg).getOutputStream(); + return type_error(arg, Symbol.ECHO_STREAM); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/EndOfFile.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/EndOfFile.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,77 @@ +/* + * EndOfFile.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: EndOfFile.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class EndOfFile extends StreamError +{ + public EndOfFile(Stream stream) throws ConditionThrowable + { + super(StandardClass.END_OF_FILE); + setStream(stream); + } + + public EndOfFile(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.END_OF_FILE); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.END_OF_FILE; + } + + @Override + public LispObject classOf() + { + return StandardClass.END_OF_FILE; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.END_OF_FILE) + return T; + if (type == StandardClass.END_OF_FILE) + return T; + return super.typep(type); + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.END_OF_FILE); + } +} Added: branches/save-image/src/org/armedbear/lisp/Environment.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Environment.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,372 @@ +/* + * Environment.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: Environment.java 11551 2009-01-08 20:24:45Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Environment extends LispObject +{ + private Binding vars; + private FunctionBinding lastFunctionBinding; + private Binding blocks; + private Binding tags; + + public Environment() {} + + public Environment(Environment parent) + { + if (parent != null) + { + vars = parent.vars; + lastFunctionBinding = parent.lastFunctionBinding; + blocks = parent.blocks; + tags = parent.tags; + } + } + + // Construct a new Environment extending parent with the specified symbol- + // value binding. + public Environment(Environment parent, Symbol symbol, LispObject value) + { + if (parent != null) + { + vars = parent.vars; + lastFunctionBinding = parent.lastFunctionBinding; + blocks = parent.blocks; + tags = parent.tags; + } + vars = new Binding(symbol, value, vars); + } + + @Override + public LispObject typeOf() + { + return Symbol.ENVIRONMENT; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.ENVIRONMENT; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.ENVIRONMENT) + return T; + if (type == BuiltInClass.ENVIRONMENT) + return T; + return super.typep(type); + } + + public boolean isEmpty() + { + if (lastFunctionBinding != null) + return false; + if (vars != null) + { + for (Binding binding = vars; binding != null; binding = binding.next) + if (!binding.specialp) + return false; + } + return true; + } + + public void bind(Symbol symbol, LispObject value) + { + vars = new Binding(symbol, value, vars); + } + + public void rebind(Symbol symbol, LispObject value) + { + Binding binding = getBinding(symbol); + binding.value = value; + } + + public LispObject lookup(LispObject symbol) + { + Binding binding = vars; + while (binding != null) + { + if (binding.symbol == symbol) + return binding.value; + binding = binding.next; + } + return null; + } + + public Binding getBinding(LispObject symbol) + { + Binding binding = vars; + while (binding != null) + { + if (binding.symbol == symbol) + return binding; + binding = binding.next; + } + return null; + } + + // Function bindings. + public void addFunctionBinding(LispObject name, LispObject value) + { + lastFunctionBinding = + new FunctionBinding(name, value, lastFunctionBinding); + } + + public LispObject lookupFunction(LispObject name) + throws ConditionThrowable + { + FunctionBinding binding = lastFunctionBinding; + if (name instanceof Symbol) + { + while (binding != null) + { + if (binding.name == name) + return binding.value; + binding = binding.next; + } + // Not found in environment. + return name.getSymbolFunction(); + } + if (name instanceof Cons) + { + while (binding != null) + { + if (binding.name.equal(name)) + return binding.value; + binding = binding.next; + } + } + return null; + } + + public void addBlock(LispObject tag, LispObject block) + { + blocks = new Binding(tag, block, blocks); + } + + public LispObject lookupBlock(LispObject symbol) + { + Binding binding = blocks; + while (binding != null) + { + if (binding.symbol == symbol) + return binding.value; + binding = binding.next; + } + return null; + } + + public void addTagBinding(LispObject tag, LispObject code) + { + tags = new Binding(tag, code, tags); + } + + public Binding getTagBinding(LispObject tag) + { + Binding binding = tags; + while (binding != null) + { + if (binding.symbol.eql(tag)) + return binding; + binding = binding.next; + } + return null; + } + + // Returns body with declarations removed. + public LispObject processDeclarations(LispObject body) + throws ConditionThrowable + { + while (body != NIL) + { + LispObject obj = body.car(); + if (obj instanceof Cons && ((Cons)obj).car == Symbol.DECLARE) + { + LispObject decls = ((Cons)obj).cdr; + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && ((Cons)decl).car == Symbol.SPECIAL) + { + LispObject names = ((Cons)decl).cdr; + while (names != NIL) + { + Symbol var = checkSymbol(names.car()); + declareSpecial(var); + names = ((Cons)names).cdr; + } + } + decls = ((Cons)decls).cdr; + } + body = ((Cons)body).cdr; + } + else + break; + } + return body; + } + + public void declareSpecial(Symbol var) + { + vars = new Binding(var, null, vars); + vars.specialp = true; + } + + /** Return true if a symbol is declared special. + * + * If there is no binding in the current (lexical) environment, + * the current dynamic environment (thread) is checked. + */ + public boolean isDeclaredSpecial(LispObject var) + { + Binding binding = getBinding(var); + return (binding != null) ? binding.specialp : + (LispThread.currentThread().getSpecialBinding(var) != null); + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.ENVIRONMENT); + } + + // ### make-environment + public static final Primitive MAKE_ENVIRONMENT = + new Primitive("make-environment", PACKAGE_SYS, true, + "&optional parent-environment") + { + @Override + public LispObject execute() + { + return new Environment(); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == NIL) + return new Environment(); + return new Environment(checkEnvironment(arg)); + } + }; + + // ### environment-add-macro-definition + public static final Primitive ENVIRONMENT_ADD_MACRO_DEFINITION = + new Primitive("environment-add-macro-definition", PACKAGE_SYS, true, + "environment name expander") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + Environment env = checkEnvironment(first); + LispObject name = second; + LispObject expander = third; + env.addFunctionBinding(name, expander); + return env; + } + }; + + // ### environment-add-function-definition + public static final Primitive ENVIRONMENT_ADD_FUNCTION_DEFINITION = + new Primitive("environment-add-function-definition", PACKAGE_SYS, true, + "environment name lambda-expression") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + checkEnvironment(first).addFunctionBinding(second, third); + return first; + } + }; + + // ### environment-add-symbol-binding + public static final Primitive ENVIRONMENT_ADD_SYMBOL_BINDING = + new Primitive("environment-add-symbol-binding", PACKAGE_SYS, true, + "environment symbol value") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + checkEnvironment(first).bind(checkSymbol(second), third); + return first; + } + }; + + // ### empty-environment-p + private static final Primitive EMPTY_ENVIRONMENT_P = + new Primitive("empty-environment-p", PACKAGE_SYS, true, "environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Environment)arg).isEmpty() ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ENVIRONMENT); + } + } + }; + + // ### environment-variables + private static final Primitive ENVIRONMENT_VARS = + new Primitive("environment-variables", PACKAGE_SYS, true, "environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + Environment env = (Environment) arg; + LispObject result = NIL; + for (Binding binding = env.vars; binding != null; binding = binding.next) + if (!binding.specialp) + result = result.push(new Cons(binding.symbol, binding.value)); + return result.nreverse(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ENVIRONMENT); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/EqHashTable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/EqHashTable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,162 @@ +/* + * EqHashTable.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: EqHashTable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class EqHashTable extends HashTable +{ + private LispObject cachedKey; + private int cachedIndex; + + private int mask; + + public EqHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) + { + super(calculateInitialCapacity(size), rehashSize, rehashThreshold); + mask = buckets.length - 1; + } + + @Override + public Symbol getTest() + { + return Symbol.EQ; + } + + @Override + public LispObject get(LispObject key) + { + final int index; + if (key == cachedKey) { + index = cachedIndex; + } else { + index = key.sxhash() & mask; + cachedKey = key; + cachedIndex = index; + } + HashEntry e = buckets[index]; + while (e != null) { + if (key == e.key) + return e.value; + e = e.next; + } + return null; + } + + @Override + public void put(LispObject key, LispObject value) + { + int index; + if (key == cachedKey) { + index = cachedIndex; + } else { + index = key.sxhash() & mask; + cachedKey = key; + cachedIndex = index; + } + HashEntry e = buckets[index]; + while (e != null) { + if (key == e.key) { + e.value = value; + return; + } + e = e.next; + } + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); + // Need a new hash value to suit the bigger table. + index = key.sxhash() & mask; + cachedKey = key; + cachedIndex = index; + } + e = new HashEntry(key, value); + e.next = buckets[index]; + buckets[index] = e; + } + + @Override + public LispObject remove(LispObject key) + { + final int index; + if (key == cachedKey) { + index = cachedIndex; + } else { + index = key.sxhash() & mask; + cachedKey = key; + cachedIndex = index; + } + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) { + if (key == e.key) { + if (last == null) + buckets[index] = e.next; + else + last.next = e.next; + --count; + return e.value; + } + last = e; + e = e.next; + } + return null; + } + + @Override + protected void rehash() + { + cachedKey = null; // Invalidate the cache! + HashEntry[] oldBuckets = buckets; + final int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * loadFactor); + buckets = new HashEntry[newCapacity]; + mask = buckets.length - 1; + for (int i = oldBuckets.length; i-- > 0;) { + HashEntry e = oldBuckets[i]; + while (e != null) { + final int index = e.key.sxhash() & mask; + HashEntry dest = buckets[index]; + if (dest != null) { + while (dest.next != null) + dest = dest.next; + dest.next = e; + } else + buckets[index] = e; + HashEntry next = e.next; + e.next = null; + e = next; + } + } + } +} Added: branches/save-image/src/org/armedbear/lisp/EqlHashTable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/EqlHashTable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,148 @@ +/* + * EqlHashTable.java + * + * Copyright (C) 2004-2006 Peter Graves + * $Id: EqlHashTable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class EqlHashTable extends HashTable +{ + private int mask; + + public EqlHashTable() + { + } + + public EqlHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) + { + super(calculateInitialCapacity(size), rehashSize, rehashThreshold); + mask = buckets.length - 1; + } + + @Override + public Symbol getTest() + { + return Symbol.EQL; + } + + @Override + public LispObject get(LispObject key) + { + HashEntry e = buckets[key.sxhash() & mask]; + while (e != null) + { + if (key.eql(e.key)) + return e.value; + e = e.next; + } + return null; + } + + @Override + public void put(LispObject key, LispObject value) + { + int index = key.sxhash() & mask; + HashEntry e = buckets[index]; + while (e != null) + { + if (key.eql(e.key)) + { + e.value = value; + return; + } + e = e.next; + } + // Not found. We need to add a new entry. + if (++count > threshold) + { + rehash(); + // Need a new hash value to suit the bigger table. + index = key.sxhash() & mask; + } + e = new HashEntry(key, value); + e.next = buckets[index]; + buckets[index] = e; + } + + @Override + public LispObject remove(LispObject key) + { + final int index = key.sxhash() & mask; + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) + { + if (key.eql(e.key)) + { + if (last == null) + buckets[index] = e.next; + else + last.next = e.next; + --count; + return e.value; + } + last = e; + e = e.next; + } + return null; + } + + @Override + protected void rehash() + { + HashEntry[] oldBuckets = buckets; + int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * loadFactor); + buckets = new HashEntry[newCapacity]; + mask = buckets.length - 1; + for (int i = oldBuckets.length; i-- > 0;) + { + HashEntry e = oldBuckets[i]; + while (e != null) + { + final int index = e.key.sxhash() & mask; + HashEntry dest = buckets[index]; + if (dest != null) + { + while (dest.next != null) + dest = dest.next; + dest.next = e; + } + else + buckets[index] = e; + HashEntry next = e.next; + e.next = null; + e = next; + } + } + } +} Added: branches/save-image/src/org/armedbear/lisp/EqualHashTable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/EqualHashTable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,151 @@ +/* + * EqualHashTable.java + * + * Copyright (C) 2004-2006 Peter Graves + * $Id: EqualHashTable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class EqualHashTable extends HashTable +{ + private int mask; + + public EqualHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) + { + super(calculateInitialCapacity(size), rehashSize, rehashThreshold); + mask = buckets.length - 1; + } + + @Override + public Symbol getTest() + { + return Symbol.EQUAL; + } + + @Override + public LispObject get(LispObject key) + { + HashEntry e = buckets[key.sxhash() & mask]; + while (e != null) + { + try + { + if (key == e.key || key.equal(e.key)) + return e.value; + } + catch (ConditionThrowable t) + { + Debug.trace(t); + } + e = e.next; + } + return null; + } + + @Override + public void put(LispObject key, LispObject value) throws ConditionThrowable + { + int index = key.sxhash() & mask; + HashEntry e = buckets[index]; + while (e != null) + { + if (key == e.key || key.equal(e.key)) + { + e.value = value; + return; + } + e = e.next; + } + // Not found. We need to add a new entry. + if (++count > threshold) + { + rehash(); + // Need a new hash value to suit the bigger table. + index = key.sxhash() & mask; + } + e = new HashEntry(key, value); + e.next = buckets[index]; + buckets[index] = e; + } + + @Override + public LispObject remove(LispObject key) throws ConditionThrowable + { + final int index = key.sxhash() & mask; + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) + { + if (key == e.key || key.equal(e.key)) + { + if (last == null) + buckets[index] = e.next; + else + last.next = e.next; + --count; + return e.value; + } + last = e; + e = e.next; + } + return null; + } + + @Override + protected void rehash() + { + HashEntry[] oldBuckets = buckets; + int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * loadFactor); + buckets = new HashEntry[newCapacity]; + mask = buckets.length - 1; + for (int i = oldBuckets.length; i-- > 0;) + { + HashEntry e = oldBuckets[i]; + while (e != null) + { + final int index = e.key.sxhash() & mask; + HashEntry dest = buckets[index]; + if (dest != null) + { + while (dest.next != null) + dest = dest.next; + dest.next = e; + } + else + buckets[index] = e; + HashEntry next = e.next; + e.next = null; + e = next; + } + } + } +} Added: branches/save-image/src/org/armedbear/lisp/EqualpHashTable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/EqualpHashTable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,148 @@ +/* + * EqualpHashTable.java + * + * Copyright (C) 2004-2006 Peter Graves + * $Id: EqualpHashTable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class EqualpHashTable extends HashTable +{ + public EqualpHashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) + { + super(size, rehashSize, rehashThreshold); + } + + @Override + public Symbol getTest() + { + return Symbol.EQUALP; + } + + @Override + public LispObject get(LispObject key) + { + final int index = key.psxhash() % buckets.length; + HashEntry e = buckets[index]; + while (e != null) + { + try + { + if (key.equalp(e.key)) + return e.value; + } + catch (ConditionThrowable t) + { + Debug.trace(t); + } + e = e.next; + } + return null; + } + + @Override + public void put(LispObject key, LispObject value) throws ConditionThrowable + { + int index = key.psxhash() % buckets.length; + HashEntry e = buckets[index]; + while (e != null) + { + if (key.equalp(e.key)) + { + e.value = value; + return; + } + e = e.next; + } + // Not found. We need to add a new entry. + if (++count > threshold) + { + rehash(); + // Need a new hash value to suit the bigger table. + index = key.psxhash() % buckets.length; + } + e = new HashEntry(key, value); + e.next = buckets[index]; + buckets[index] = e; + } + + @Override + public LispObject remove(LispObject key) throws ConditionThrowable + { + final int index = key.psxhash() % buckets.length; + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) + { + if (key.equalp(e.key)) + { + if (last == null) + buckets[index] = e.next; + else + last.next = e.next; + --count; + return e.value; + } + last = e; + e = e.next; + } + return null; + } + + @Override + protected void rehash() + { + HashEntry[] oldBuckets = buckets; + int newCapacity = buckets.length * 2 + 1; + threshold = (int) (newCapacity * loadFactor); + buckets = new HashEntry[newCapacity]; + for (int i = oldBuckets.length; i-- > 0;) + { + HashEntry e = oldBuckets[i]; + while (e != null) + { + final int index = e.key.psxhash() % buckets.length; + HashEntry dest = buckets[index]; + if (dest != null) + { + while (dest.next != null) + dest = dest.next; + dest.next = e; + } + else + buckets[index] = e; + HashEntry next = e.next; + e.next = null; + e = next; + } + } + } +} Added: branches/save-image/src/org/armedbear/lisp/Extensions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Extensions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,290 @@ +/* + * Extensions.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Extensions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.IOException; + +public final class Extensions extends Lisp +{ + // ### *ed-functions* + public static final Symbol _ED_FUNCTIONS_ = + exportSpecial("*ED-FUNCTIONS*", PACKAGE_EXT, + list1(intern("DEFAULT-ED-FUNCTION", PACKAGE_SYS))); + + // ### truly-the value-type form => result* + private static final SpecialOperator TRULY_THE = + new SpecialOperator("truly-the", PACKAGE_EXT, true, "type value") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() != 2) + return error(new WrongNumberOfArgumentsException(this)); + return eval(args.cadr(), env, LispThread.currentThread()); + } + }; + + // ### neq + private static final Primitive NEQ = + new Primitive(Symbol.NEQ, "obj1 obj2") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first != second ? T : NIL; + } + }; + + // ### memq item list => tail + private static final Primitive MEMQ = + new Primitive(Symbol.MEMQ, "item list") + { + @Override + public LispObject execute(LispObject item, LispObject list) + throws ConditionThrowable + { + while (list instanceof Cons) + { + if (item == ((Cons)list).car) + return list; + list = ((Cons)list).cdr; + } + if (list != NIL) + type_error(list, Symbol.LIST); + return NIL; + } + }; + + // ### memql item list => tail + private static final Primitive MEMQL = + new Primitive(Symbol.MEMQL, "item list") + { + @Override + public LispObject execute(LispObject item, LispObject list) + throws ConditionThrowable + { + while (list instanceof Cons) + { + if (item.eql(((Cons)list).car)) + return list; + list = ((Cons)list).cdr; + } + if (list != NIL) + type_error(list, Symbol.LIST); + return NIL; + } + }; + + // ### adjoin-eql item list => new-list + private static final Primitive ADJOIN_EQL = + new Primitive(Symbol.ADJOIN_EQL, "item list") + { + @Override + public LispObject execute(LispObject item, LispObject list) + throws ConditionThrowable + { + return memql(item, list) ? list : new Cons(item, list); + } + }; + + // ### special-variable-p + private static final Primitive SPECIAL_VARIABLE_P = + new Primitive("special-variable-p", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.isSpecialVariable() ? T : NIL; + } + }; + + // ### source + private static final Primitive SOURCE = + new Primitive("source", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return get(arg, Symbol._SOURCE, NIL); + } + }; + + // ### source-file-position + private static final Primitive SOURCE_FILE_POSITION = + new Primitive("source-file-position", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispObject obj = get(arg, Symbol._SOURCE, NIL); + if (obj instanceof Cons) + return obj.cdr(); + return NIL; + } + }; + + // ### source-pathname + public static final Primitive SOURCE_PATHNAME = + new Primitive("source-pathname", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispObject obj = get(arg, Symbol._SOURCE, NIL); + if (obj instanceof Cons) + return obj.car(); + return obj; + } + }; + + // ### exit + private static final Primitive EXIT = + new Primitive("exit", PACKAGE_EXT, true, "&key status") + { + @Override + public LispObject execute() throws ConditionThrowable + { + exit(0); + return LispThread.currentThread().nothing(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + int status = 0; + if (first == Keyword.STATUS) + { + if (second instanceof Fixnum) + status = ((Fixnum)second).value; + } + exit(status); + return LispThread.currentThread().nothing(); + } + }; + + // ### quit + private static final Primitive QUIT = + new Primitive("quit", PACKAGE_EXT, true, "&key status") + { + @Override + public LispObject execute() throws ConditionThrowable + { + exit(0); + return LispThread.currentThread().nothing(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + int status = 0; + if (first == Keyword.STATUS) + { + if (second instanceof Fixnum) + status = ((Fixnum)second).value; + } + exit(status); + return LispThread.currentThread().nothing(); + } + }; + + // ### dump-java-stack + private static final Primitive DUMP_JAVA_STACK = + new Primitive("dump-java-stack", PACKAGE_EXT, true) + { + @Override + public LispObject execute() throws ConditionThrowable + { + Thread.dumpStack(); + return LispThread.currentThread().nothing(); + } + }; + + // ### make-temp-file => namestring + private static final Primitive MAKE_TEMP_FILE = + new Primitive("make-temp-file", PACKAGE_EXT, true, "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + try + { + File file = File.createTempFile("abcl", null, null); + if (file != null) + return new Pathname(file.getPath()); + } + catch (IOException e) + { + Debug.trace(e); + } + return NIL; + } + }; + + // ### interrupt-lisp + private static final Primitive INTERRUPT_LISP = + new Primitive("interrupt-lisp", PACKAGE_EXT, true, "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + setInterrupted(true); + return T; + } + }; + + // ### getenv + private static final Primitive GETENV = + new Primitive("getenv", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + AbstractString string; + try { + string = (AbstractString) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STRING); + } + String result = System.getenv(string.getStringValue()); + if (result != null) + return new SimpleString(result); + else + return NIL; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/ExternalizedCompiledFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ExternalizedCompiledFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,40 @@ +package org.armedbear.lisp; + +import java.io.*; + +public class ExternalizedCompiledFunction extends Lisp implements Serializable { + + + private String functionName; + private String className; + private byte[] classBytes; + + public ExternalizedCompiledFunction(byte[] classBytes, String functionName, String className) { + this.classBytes = classBytes; + this.functionName = functionName; + this.className = className; + } + + protected Object readResolve() throws ObjectStreamException { + Object o = null; + try { + o = loadCompiledFunction(classBytes); + if(o instanceof Function) { + return o; + } + } catch(Throwable t) { + System.err.println("Error deserializing compiled function"); + t.printStackTrace(System.err); + } + throw new InvalidClassException(o != null ? o.getClass().getName() : "null"); + } + + public String getFunctionName() { + return functionName; + } + + public String getClassName() { + return className; + } + +} \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/FaslReader.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FaslReader.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,463 @@ +/* + * FaslReader.java + * + * Copyright (C) 2005 Peter Graves + * $Id: FaslReader.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FaslReader extends Lisp +{ + // ### fasl-read-comment + public static final ReaderMacroFunction FASL_READ_COMMENT = + new ReaderMacroFunction("fasl-read-comment", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + while (true) { + int n = stream._readChar(); + if (n < 0) + return null; + if (n == '\n') + return null; + } + } + }; + + // ### fasl-read-string + public static final ReaderMacroFunction FASL_READ_STRING = + new ReaderMacroFunction("fasl-read-string", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char terminator) + throws ConditionThrowable + { + final Readtable rt = FaslReadtable.getInstance(); + FastStringBuffer sb = new FastStringBuffer(); + while (true) { + int n = stream._readChar(); + if (n < 0) { + error(new EndOfFile(stream)); + // Not reached. + return null; + } + char c = (char) n; + if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { + // Single escape. + n = stream._readChar(); + if (n < 0) { + error(new EndOfFile(stream)); + // Not reached. + return null; + } + sb.append((char)n); + continue; + } + if (Utilities.isPlatformWindows) { + if (c == '\r') { + n = stream._readChar(); + if (n < 0) { + error(new EndOfFile(stream)); + // Not reached. + return null; + } + if (n == '\n') { + sb.append('\n'); + } else { + // '\r' was not followed by '\n'. + stream._unreadChar(n); + sb.append('\r'); + } + continue; + } + } + if (c == terminator) + break; + // Default. + sb.append(c); + } + return new SimpleString(sb); + } + }; + + // ### fasl-read-list + public static final ReaderMacroFunction FASL_READ_LIST = + new ReaderMacroFunction("fasl-read-list", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + return stream.readList(false, true); + } + }; + + // ### fasl-read-right-paren + public static final ReaderMacroFunction FASL_READ_RIGHT_PAREN = + new ReaderMacroFunction("fasl-read-right-paren", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + return error(new ReaderError("Unmatched right parenthesis.", stream)); + } + }; + + // ### fasl-read-quote + public static final ReaderMacroFunction FASL_READ_QUOTE = + new ReaderMacroFunction("fasl-read-quote", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + return new Cons(Symbol.QUOTE, + new Cons(stream.faslRead(true, NIL, true, + LispThread.currentThread()))); + } + }; + + // ### fasl-read-dispatch-char + public static final ReaderMacroFunction FASL_READ_DISPATCH_CHAR = + new ReaderMacroFunction("fasl-read-dispatch-char", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char c) + throws ConditionThrowable + { + return stream.readDispatchChar(c, true); + } + }; + + // ### fasl-sharp-left-paren + public static final DispatchMacroFunction FASL_SHARP_LEFT_PAREN = + new DispatchMacroFunction("fasl-sharp-left-paren", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject list = stream.readList(true, true); + if (_BACKQUOTE_COUNT_.symbolValue(thread).zerop()) { + if (n >= 0) { + LispObject[] array = new LispObject[n]; + for (int i = 0; i < n; i++) { + array[i] = list.car(); + if (list.cdr() != NIL) + list = list.cdr(); + } + return new SimpleVector(array); + } else + return new SimpleVector(list); + } + return new Cons(_BQ_VECTOR_FLAG_.symbolValue(thread), list); + } + }; + + // ### fasl-sharp-star + public static final DispatchMacroFunction FASL_SHARP_STAR = + new DispatchMacroFunction("fasl-sharp-star", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char ignored, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final Readtable rt = FaslReadtable.getInstance(); + final boolean suppress = + (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL); + FastStringBuffer sb = new FastStringBuffer(); + while (true) { + int ch = stream._readChar(); + if (ch < 0) + break; + char c = (char) ch; + if (c == '0' || c == '1') + sb.append(c); + else { + int syntaxType = rt.getSyntaxType(c); + if (syntaxType == Readtable.SYNTAX_TYPE_WHITESPACE || + syntaxType == Readtable.SYNTAX_TYPE_TERMINATING_MACRO) { + stream._unreadChar(c); + break; + } else if (!suppress) { + String name = LispCharacter.charToName(c); + if (name == null) + name = "#\\" + c; + error(new ReaderError("Illegal element for bit-vector: " + name, + stream)); + } + } + } + if (suppress) + return NIL; + if (n >= 0) { + // n was supplied. + final int length = sb.length(); + if (length == 0) { + if (n > 0) + return error(new ReaderError("No element specified for bit vector of length " + + n + '.', + stream)); + } + if (n > length) { + final char c = sb.charAt(length - 1); + for (int i = length; i < n; i++) + sb.append(c); + } else if (n < length) { + return error(new ReaderError("Bit vector is longer than specified length: #" + + n + '*' + sb.toString(), + stream)); + } + } + return new SimpleBitVector(sb.toString()); + } + }; + + // ### fasl-sharp-dot + public static final DispatchMacroFunction FASL_SHARP_DOT = + new DispatchMacroFunction("fasl-sharp-dot", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (Symbol.READ_EVAL.symbolValue(thread) == NIL) + return error(new ReaderError("Can't read #. when *READ-EVAL* is NIL.", + stream)); + else + return eval(stream.faslRead(true, NIL, true, thread), + new Environment(), thread); + } + }; + + // ### fasl-sharp-colon + public static final DispatchMacroFunction FASL_SHARP_COLON = + new DispatchMacroFunction("fasl-sharp-colon", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + LispThread thread = LispThread.currentThread(); + Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance()); + LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread); + if (pkg == NIL) { + thread.bindSpecial(Load._FASL_ANONYMOUS_PACKAGE_, + pkg = new Package()); + } + symbol = ((Package)pkg).intern(symbol.getName()); + symbol.setPackage(NIL); + return symbol; + } + }; + + // ### fasl-sharp-a + public static final DispatchMacroFunction FASL_SHARP_A = + new DispatchMacroFunction("fasl-sharp-a", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadArray(n); + } + }; + + // ### fasl-sharp-b + public static final DispatchMacroFunction FASL_SHARP_B = + new DispatchMacroFunction("fasl-sharp-b", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadRadix(2); + } + }; + + // ### fasl-sharp-c + public static final DispatchMacroFunction FASL_SHARP_C = + new DispatchMacroFunction("fasl-sharp-c", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadComplex(); + } + }; + + // ### fasl-sharp-o + public static final DispatchMacroFunction FASL_SHARP_O = + new DispatchMacroFunction("fasl-sharp-o", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadRadix(8); + } + }; + + // ### fasl-sharp-p + public static final DispatchMacroFunction FASL_SHARP_P = + new DispatchMacroFunction("fasl-sharp-p", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadPathname(); + } + }; + + // ### fasl-sharp-r + public static final DispatchMacroFunction FASL_SHARP_R = + new DispatchMacroFunction("fasl-sharp-r", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadRadix(n); + } + }; + + // ### fasl-sharp-s + public static final DispatchMacroFunction FASL_SHARP_S = + new DispatchMacroFunction("fasl-sharp-s", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readStructure(); + } + }; + + // ### fasl-sharp-x + public static final DispatchMacroFunction FASL_SHARP_X = + new DispatchMacroFunction("fasl-sharp-x", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.faslReadRadix(16); + } + }; + + // ### fasl-sharp-quote + public static final DispatchMacroFunction FASL_SHARP_QUOTE = + new DispatchMacroFunction("fasl-sharp-quote", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return new Cons(Symbol.FUNCTION, + new Cons(stream.faslRead(true, NIL, true, + LispThread.currentThread()))); + } + }; + + // ### fasl-sharp-backslash + public static final DispatchMacroFunction FASL_SHARP_BACKSLASH = + new DispatchMacroFunction("fasl-sharp-backslash", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readCharacterLiteral(FaslReadtable.getInstance(), + LispThread.currentThread()); + } + }; + + // ### fasl-sharp-vertical-bar + public static final DispatchMacroFunction FASL_SHARP_VERTICAL_BAR = + new DispatchMacroFunction("sharp-vertical-bar", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + stream.skipBalancedComment(); + return null; + } + }; + + // ### fasl-sharp-illegal + public static final DispatchMacroFunction FASL_SHARP_ILLEGAL = + new DispatchMacroFunction("fasl-sharp-illegal", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + FastStringBuffer sb = + new FastStringBuffer("Illegal # macro character: #\\"); + String s = LispCharacter.charToName(c); + if (s != null) + sb.append(s); + else + sb.append(c); + return error(new ReaderError(sb.toString(), stream)); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/FaslReadtable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FaslReadtable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,111 @@ +/* + * FaslReadtable.java + * + * Copyright (C) 2005 Peter Graves + * $Id: FaslReadtable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FaslReadtable extends Readtable +{ + public FaslReadtable() + { + super(); + } + + @Override + protected void initialize() + { + syntax[9] = SYNTAX_TYPE_WHITESPACE; // tab + syntax[10] = SYNTAX_TYPE_WHITESPACE; // linefeed + syntax[12] = SYNTAX_TYPE_WHITESPACE; // form feed + syntax[13] = SYNTAX_TYPE_WHITESPACE; // return + syntax[' '] = SYNTAX_TYPE_WHITESPACE; + + syntax['"'] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax['\''] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax['('] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax[')'] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax[','] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax[';'] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax['`'] = SYNTAX_TYPE_TERMINATING_MACRO; + + syntax['#'] = SYNTAX_TYPE_NON_TERMINATING_MACRO; + + syntax['\\'] = SYNTAX_TYPE_SINGLE_ESCAPE; + syntax['|'] = SYNTAX_TYPE_MULTIPLE_ESCAPE; + + readerMacroFunctions[';'] = FaslReader.FASL_READ_COMMENT; + readerMacroFunctions['"'] = FaslReader.FASL_READ_STRING; + readerMacroFunctions['('] = FaslReader.FASL_READ_LIST; + readerMacroFunctions[')'] = FaslReader.FASL_READ_RIGHT_PAREN; + readerMacroFunctions['\''] = FaslReader.FASL_READ_QUOTE; + readerMacroFunctions['#'] = FaslReader.FASL_READ_DISPATCH_CHAR; + + // BACKQUOTE-MACRO and COMMA-MACRO are defined in backquote.lisp. + readerMacroFunctions['`'] = Symbol.BACKQUOTE_MACRO; + readerMacroFunctions[','] = Symbol.COMMA_MACRO; + + DispatchTable dt = new DispatchTable(); + dt.functions['('] = FaslReader.FASL_SHARP_LEFT_PAREN; + dt.functions['*'] = FaslReader.FASL_SHARP_STAR; + dt.functions['.'] = FaslReader.FASL_SHARP_DOT; + dt.functions[':'] = FaslReader.FASL_SHARP_COLON; + dt.functions['A'] = FaslReader.FASL_SHARP_A; + dt.functions['B'] = FaslReader.FASL_SHARP_B; + dt.functions['C'] = FaslReader.FASL_SHARP_C; + dt.functions['O'] = FaslReader.FASL_SHARP_O; + dt.functions['P'] = FaslReader.FASL_SHARP_P; + dt.functions['R'] = FaslReader.FASL_SHARP_R; + dt.functions['S'] = FaslReader.FASL_SHARP_S; + dt.functions['X'] = FaslReader.FASL_SHARP_X; + dt.functions['\''] = FaslReader.FASL_SHARP_QUOTE; + dt.functions['\\'] = FaslReader.FASL_SHARP_BACKSLASH; + dt.functions['|'] = FaslReader.FASL_SHARP_VERTICAL_BAR; + dt.functions[')'] = FaslReader.FASL_SHARP_ILLEGAL; + dt.functions['<'] = FaslReader.FASL_SHARP_ILLEGAL; + dt.functions[' '] = FaslReader.FASL_SHARP_ILLEGAL; + dt.functions[8] = FaslReader.FASL_SHARP_ILLEGAL; // backspace + dt.functions[9] = FaslReader.FASL_SHARP_ILLEGAL; // tab + dt.functions[10] = FaslReader.FASL_SHARP_ILLEGAL; // newline, linefeed + dt.functions[12] = FaslReader.FASL_SHARP_ILLEGAL; // page + dt.functions[13] = FaslReader.FASL_SHARP_ILLEGAL; // return + dispatchTables['#'] = dt; + + readtableCase = Keyword.UPCASE; + } + + private static final FaslReadtable instance = new FaslReadtable(); + + public static final FaslReadtable getInstance() + { + return instance; + } +} Added: branches/save-image/src/org/armedbear/lisp/FastStringBuffer.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FastStringBuffer.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,177 @@ +/* + * FastStringBuffer.java + * + * Copyright (C) 1998-2005 Peter Graves + * Copyright (C) 2008 Phil Hudson + * $Id: FastStringBuffer.java 11527 2009-01-03 12:30:16Z mevenson $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +/** + * An adaptor of the Java 1.5 java.lang.StringBuilder. + * + * "This class should be removed with all references to it replaced + * with java.lang.StringBuilder once enough confidence in this change + * has been gained." -- Phil Hudson 20090202 via . + */ +public final class FastStringBuffer implements Appendable, CharSequence +{ + private static final int SPARE_CAPACITY = 128; + + private final StringBuilder builder; + + public FastStringBuffer() + { + this(SPARE_CAPACITY); + } + + public FastStringBuffer(String s) + { + builder = new StringBuilder(s); + } + + public FastStringBuffer(char c) + { + this(String.valueOf(c)); + } + + public FastStringBuffer(int length) throws NegativeArraySizeException + { + builder = new StringBuilder(length); + } + + public final int length() + { + return builder.length(); + } + + public final int capacity() + { + return builder.capacity(); + } + + public final char charAt(int index) + { + return builder.charAt(index); + } + + public void getChars(int srcBegin, int srcEnd, char dst[], int dstBegin) + { + builder.getChars(srcBegin, srcEnd, dst, dstBegin); + } + + public void setCharAt(int index, char c) + { + builder.setCharAt(index, c); + } + + public void ensureCapacity(int minimumCapacity) + { + builder.ensureCapacity(minimumCapacity); + } + + public FastStringBuffer append(String s) + { + builder.append(s); + return this; + } + + public FastStringBuffer append(char[] chars) + { + builder.append(chars); + return this; + } + + public FastStringBuffer append(char[] chars, int offset, int len) + { + builder.append(chars, offset, len); + return this; + } + + public FastStringBuffer append(Object object) + { + return append(String.valueOf(object)); + } + + public FastStringBuffer append(char c) + { + builder.append(c); + return this; + } + + public final FastStringBuffer append(int n) + { + return append(String.valueOf(n)); + } + + public final FastStringBuffer append(long n) + { + return append(String.valueOf(n)); + } + + public void setLength(int newLength) throws IndexOutOfBoundsException + { + builder.setLength(newLength); + } + + public FastStringBuffer reverse() + { + builder.reverse(); + return this; + } + + @Override + public final String toString() + { + return builder.toString(); + } + + public final char[] toCharArray() + { + return toString().toCharArray(); + } + + public CharSequence subSequence(int start, int end) + { + return builder.subSequence(start, end); + } + + public FastStringBuffer append(CharSequence seq) + { + builder.append(seq); + return this; + } + + public FastStringBuffer append(CharSequence seq, int start, int end) + { + builder.append(seq, start, end); + return this; + } +} Added: branches/save-image/src/org/armedbear/lisp/FileError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FileError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,112 @@ +/* + * FileError.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: FileError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FileError extends LispError +{ + // initArgs is either a normal initArgs list or a pathname. + public FileError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.FILE_ERROR); + if (initArgs instanceof Cons) + initialize(initArgs); + else + setPathname(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + LispObject pathname = NIL; + while (initArgs != NIL) { + LispObject first = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.PATHNAME) { + pathname = initArgs.car(); + break; + } + initArgs = initArgs.cdr(); + } + setPathname(pathname); + } + + public FileError(String message) throws ConditionThrowable + { + super(StandardClass.FILE_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + } + + public FileError(String message, LispObject pathname) + throws ConditionThrowable + { + super(StandardClass.FILE_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + setPathname(pathname); + } + + public LispObject getPathname() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.PATHNAME); + } + + private void setPathname(LispObject pathname) throws ConditionThrowable + { + setInstanceSlotValue(Symbol.PATHNAME, pathname); + } + + @Override + public LispObject typeOf() + { + return Symbol.FILE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.FILE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.FILE_ERROR) + return T; + if (type == StandardClass.FILE_ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/FileStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FileStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,322 @@ +/* + * FileStream.java + * + * Copyright (C) 2004-2006 Peter Graves + * Copyright (C) 2008 Hideo at Yokohama + * $Id: FileStream.java 11434 2008-12-07 23:24:31Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.InputStream; +import java.io.OutputStream; +import java.io.Reader; +import java.io.Writer; +import java.io.FileNotFoundException; +import java.io.IOException; +import java.io.RandomAccessFile; +import org.armedbear.lisp.util.RandomAccessCharacterFile; + +public final class FileStream extends Stream +{ + private final RandomAccessCharacterFile racf; + private final Pathname pathname; + private final int bytesPerUnit; + + public FileStream(Pathname pathname, String namestring, + LispObject elementType, LispObject direction, + LispObject ifExists, LispObject format) + throws IOException + { + /* externalFormat is a LispObject of which the first char is a + * name of a character encoding (such as :UTF-8 or :ISO-8859-1), used + * by ABCL as a string designator, unless the name is :CODE-PAGE. + * A real string is (thus) also allowed. + * + * Then, a property list follows with 3 possible keys: + * :ID (values: code page numbers supported by MS-DOS/IBM-DOS/MS-Windows + * :EOL-STYLE (values: :CR / :LF / :CRLF [none means native]) + * :LITTLE-ENDIAN (values: NIL / T) + * + * These definitions have been taken from FLEXI-STREAMS: + * http://www.weitz.de/flexi-streams/#make-external-format + */ + final File file = new File(namestring); + String mode = null; + if (direction == Keyword.INPUT) { + mode = "r"; + isInputStream = true; + } else if (direction == Keyword.OUTPUT) { + mode = "rw"; + isOutputStream = true; + } else if (direction == Keyword.IO) { + mode = "rw"; + isInputStream = true; + isOutputStream = true; + } + + Debug.assertTrue(mode != null); + RandomAccessFile raf = new RandomAccessFile(file, mode); + + // ifExists is ignored unless we have an output stream. + if (isOutputStream) { + final long length = file.isFile() ? file.length() : 0; + if (length > 0) { + if (ifExists == Keyword.OVERWRITE) + raf.seek(0); + else if (ifExists == Keyword.APPEND) + raf.seek(raf.length()); + else + raf.setLength(0); + } + } + setExternalFormat(format); + + // don't touch raf directly after passing it to racf. + // the state will become inconsistent if you do that. + racf = new RandomAccessCharacterFile(raf, encoding); + + this.pathname = pathname; + this.elementType = elementType; + if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { + isCharacterStream = true; + bytesPerUnit = 1; + if (isInputStream) { + initAsCharacterInputStream(racf.getReader()); + } + if (isOutputStream) { + initAsCharacterOutputStream(racf.getWriter()); + } + } else { + isBinaryStream = true; + int width; + try { + width = Fixnum.getValue(elementType.cadr()); + } + catch (ConditionThrowable t) { + width = 8; + } + bytesPerUnit = width / 8; + if (isInputStream) { + initAsBinaryInputStream(racf.getInputStream()); + } + if (isOutputStream) { + initAsBinaryOutputStream(racf.getOutputStream()); + } + } + } + + @Override + public LispObject typeOf() + { + return Symbol.FILE_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.FILE_STREAM; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.FILE_STREAM) + return T; + if (typeSpecifier == BuiltInClass.FILE_STREAM) + return T; + return super.typep(typeSpecifier); + } + + public Pathname getPathname() + { + return pathname; + } + + @Override + public LispObject fileLength() throws ConditionThrowable + { + final long length; + if (isOpen()) { + try { + length = racf.length(); + } + catch (IOException e) { + error(new StreamError(this, e)); + // Not reached. + return NIL; + } + } else { + String namestring = pathname.getNamestring(); + if (namestring == null) + return error(new SimpleError("Pathname has no namestring: " + + pathname.writeToString())); + File file = new File(namestring); + length = file.length(); // in 8-bit bytes + } + if (isCharacterStream) + return number(length); + // "For a binary file, the length is measured in units of the + // element type of the stream." + return number(length / bytesPerUnit); + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + try { + racf.unreadChar((char)n); + } + catch (IOException e) { + error(new StreamError(this, e)); + } + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + return true; + } + + @Override + public void _clearInput() throws ConditionThrowable + { + try { + if (isInputStream) { + racf.position(racf.length()); + } else { + streamNotInputStream(); + } + } + catch (IOException e) { + error(new StreamError(this, e)); + } + } + + @Override + protected long _getFilePosition() throws ConditionThrowable + { + try { + long pos = racf.position(); + return pos / bytesPerUnit; + } + catch (IOException e) { + error(new StreamError(this, e)); + // Not reached. + return -1; + } + } + + @Override + protected boolean _setFilePosition(LispObject arg) throws ConditionThrowable + { + try { + long pos; + if (arg == Keyword.START) + pos = 0; + else if (arg == Keyword.END) + pos = racf.length(); + else { + long n = Fixnum.getValue(arg); // FIXME arg might be a bignum + pos = n * bytesPerUnit; + } + racf.position(pos); + } + catch (IOException e) { + error(new StreamError(this, e)); + } + return true; + } + + @Override + public void _close() throws ConditionThrowable + { + try { + racf.close(); + setOpen(false); + } + catch (IOException e) { + error(new StreamError(this, e)); + } + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.FILE_STREAM); + } + + // ### make-file-stream pathname namestring element-type direction if-exists external-format => stream + private static final Primitive MAKE_FILE_STREAM = + new Primitive("make-file-stream", PACKAGE_SYS, true, + "pathname namestring element-type direction if-exists external-format") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + final Pathname pathname; + try { + pathname = (Pathname) first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.PATHNAME); + } + final LispObject namestring; + try { + namestring = (AbstractString) second; + } + catch (ClassCastException e) { + return type_error(second, Symbol.STRING); + } + LispObject elementType = third; + LispObject direction = fourth; + LispObject ifExists = fifth; + LispObject externalFormat = sixth; + + if (direction != Keyword.INPUT && direction != Keyword.OUTPUT && + direction != Keyword.IO) + error(new LispError("Direction must be :INPUT, :OUTPUT, or :IO.")); + try { + return new FileStream(pathname, namestring.getStringValue(), + elementType, direction, ifExists, + externalFormat); + } + catch (FileNotFoundException e) { + return NIL; + } + catch (IOException e) { + return error(new StreamError(null, e)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/FillPointerOutputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FillPointerOutputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,108 @@ +/* + * FillPointerOutputStream.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: FillPointerOutputStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FillPointerOutputStream extends Stream +{ + private ComplexString string; + + private FillPointerOutputStream(ComplexString string) + { + elementType = Symbol.CHARACTER; + isOutputStream = true; + isInputStream = false; + isCharacterStream = true; + isBinaryStream = false; + this.string = string; + setWriter(new Writer()); + } + + // ### make-fill-pointer-output-stream string => string-stream + private static final Primitive MAKE_FILL_POINTER_OUTPUT_STREAM = + new Primitive("make-fill-pointer-output-stream", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof ComplexString) { + ComplexString string = (ComplexString) arg; + if (string.getFillPointer() >= 0) + return new FillPointerOutputStream(string); + } + return type_error(arg, list3(Symbol.AND, Symbol.STRING, + list2(Symbol.SATISFIES, + Symbol.ARRAY_HAS_FILL_POINTER_P))); + } + }; + + private class Writer extends java.io.Writer + { + @Override + public void write(char cbuf[], int off, int len) + { + int fp = string.getFillPointer(); + if (fp >= 0) { + final int limit = Math.min(cbuf.length, off + len); + try { + string.ensureCapacity(fp + limit); + } + catch (ConditionThrowable t) { + // Shouldn't happen. + Debug.trace(t); + } + for (int i = off; i < limit; i++) { + try { + string.setCharAt(fp, cbuf[i]); + } + catch (ConditionThrowable t) { + // Shouldn't happen. + Debug.trace(t); + } + ++fp; + } + } + string.setFillPointer(fp); + } + + @Override + public void flush() + { + } + + @Override + public void close() + { + } + } +} Added: branches/save-image/src/org/armedbear/lisp/Fixnum.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Fixnum.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1035 @@ +/* + * Fixnum.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: Fixnum.java 11579 2009-01-24 10:24:34Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class Fixnum extends LispInteger +{ + public static final Fixnum[] constants = new Fixnum[256]; + static + { + for (int i = 0; i < 256; i++) + constants[i] = new Fixnum(i); + } + + public static final Fixnum ZERO = constants[0]; + public static final Fixnum ONE = constants[1]; + public static final Fixnum TWO = constants[2]; + public static final Fixnum THREE = constants[3]; + + public static final Fixnum MINUS_ONE = new Fixnum(-1); + + public static Fixnum getInstance(int n) + { + return (n >= 0 && n < 256) ? constants[n] : new Fixnum(n); + } + + public final int value; + + public Fixnum(int value) + { + this.value = value; + } + + @Override + public Object javaInstance() + { + return Integer.valueOf(value); + } + + @Override + public Object javaInstance(Class c) + { + String cn = c.getName(); + if (cn.equals("java.lang.Byte") || cn.equals("byte")) + return Byte.valueOf((byte)value); + if (cn.equals("java.lang.Short") || cn.equals("short")) + return Short.valueOf((short)value); + if (cn.equals("java.lang.Long") || cn.equals("long")) + return Long.valueOf((long)value); + return javaInstance(); + } + + @Override + public LispObject typeOf() + { + if (value == 0 || value == 1) + return Symbol.BIT; + if (value > 1) + return list3(Symbol.INTEGER, ZERO, new Fixnum(Integer.MAX_VALUE)); + return Symbol.FIXNUM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.FIXNUM; + } + + @Override + public LispObject getDescription() + { + StringBuffer sb = new StringBuffer("The fixnum "); + sb.append(value); + return new SimpleString(sb); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type instanceof Symbol) + { + if (type == Symbol.FIXNUM) + return T; + if (type == Symbol.INTEGER) + return T; + if (type == Symbol.RATIONAL) + return T; + if (type == Symbol.REAL) + return T; + if (type == Symbol.NUMBER) + return T; + if (type == Symbol.SIGNED_BYTE) + return T; + if (type == Symbol.UNSIGNED_BYTE) + return value >= 0 ? T : NIL; + if (type == Symbol.BIT) + return (value == 0 || value == 1) ? T : NIL; + } + else if (type instanceof LispClass) + { + if (type == BuiltInClass.FIXNUM) + return T; + if (type == BuiltInClass.INTEGER) + return T; + if (type == BuiltInClass.RATIONAL) + return T; + if (type == BuiltInClass.REAL) + return T; + if (type == BuiltInClass.NUMBER) + return T; + } + else if (type instanceof Cons) + { + if (type.equal(UNSIGNED_BYTE_8)) + return (value >= 0 && value <= 255) ? T : NIL; + if (type.equal(UNSIGNED_BYTE_16)) + return (value >= 0 && value <= 65535) ? T : NIL; + if (type.equal(UNSIGNED_BYTE_32)) + return value >= 0 ? T : NIL; + } + return super.typep(type); + } + + @Override + public LispObject NUMBERP() + { + return T; + } + + @Override + public boolean numberp() + { + return true; + } + + @Override + public LispObject INTEGERP() + { + return T; + } + + @Override + public boolean integerp() + { + return true; + } + + @Override + public boolean rationalp() + { + return true; + } + + @Override + public boolean realp() + { + return true; + } + + @Override + public boolean eql(int n) + { + return value == n; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof Fixnum) + { + if (value == ((Fixnum)obj).value) + return true; + } + return false; + } + + @Override + public boolean equal(int n) + { + return value == n; + } + + @Override + public boolean equal(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof Fixnum) + { + if (value == ((Fixnum)obj).value) + return true; + } + return false; + } + + @Override + public boolean equalp(int n) + { + return value == n; + } + + @Override + public boolean equalp(LispObject obj) + { + if (obj instanceof Fixnum) + return value == ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return value == ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value == ((DoubleFloat)obj).value; + return false; + } + + @Override + public LispObject ABS() + { + if (value >= 0) + return this; + if (value > Integer.MIN_VALUE) + return new Fixnum(-value); + return new Bignum(-((long)Integer.MIN_VALUE)); + } + + @Override + public LispObject NUMERATOR() + { + return this; + } + + @Override + public LispObject DENOMINATOR() + { + return ONE; + } + + @Override + public boolean evenp() throws ConditionThrowable + { + return (value & 0x01) == 0; + } + + @Override + public boolean oddp() throws ConditionThrowable + { + return (value & 0x01) != 0; + } + + @Override + public boolean plusp() + { + return value > 0; + } + + @Override + public boolean minusp() + { + return value < 0; + } + + @Override + public boolean zerop() + { + return value == 0; + } + + public static int getValue(LispObject obj) throws ConditionThrowable + { + try + { + return ((Fixnum)obj).value; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.FIXNUM); + // Not reached. + return 0; + } + } + + @Override + public float floatValue() { + return (float)value; + } + + @Override + public double doubleValue() { + return (double)value; + } + + public static int getInt(LispObject obj) throws ConditionThrowable + { + try + { + return (int) ((Fixnum)obj).value; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.FIXNUM); + // Not reached. + return 0; + } + } + + public static BigInteger getBigInteger(LispObject obj) throws ConditionThrowable + { + try + { + return BigInteger.valueOf(((Fixnum)obj).value); + } + catch (ClassCastException e) + { + type_error(obj, Symbol.FIXNUM); + // Not reached. + return null; + } + } + + @Override + public int intValue() + { + return value; + } + + @Override + public long longValue() + { + return (long) value; + } + + public final BigInteger getBigInteger() + { + return BigInteger.valueOf(value); + } + + @Override + public final LispObject incr() + { + if (value < Integer.MAX_VALUE) + return new Fixnum(value + 1); + return new Bignum((long) value + 1); + } + + @Override + public final LispObject decr() + { + if (value > Integer.MIN_VALUE) + return new Fixnum(value - 1); + return new Bignum((long) value - 1); + } + + @Override + public LispObject negate() + { + long result = 0L - value; + if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) + return new Fixnum((int)result); + else + return new Bignum(result); + } + + @Override + public LispObject add(int n) + { + long result = (long) value + n; + if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) + return new Fixnum((int)result); + else + return new Bignum(result); + } + + @Override + public LispObject add(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + { + long result = (long) value + ((Fixnum)obj).value; + if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) + return new Fixnum((int)result); + else + return new Bignum(result); + } + if (obj instanceof Bignum) + return number(getBigInteger().add(((Bignum)obj).value)); + if (obj instanceof Ratio) + { + BigInteger numerator = ((Ratio)obj).numerator(); + BigInteger denominator = ((Ratio)obj).denominator(); + return number(getBigInteger().multiply(denominator).add(numerator), + denominator); + } + if (obj instanceof SingleFloat) + return new SingleFloat(value + ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value + ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return Complex.getInstance(add(c.getRealPart()), c.getImaginaryPart()); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject subtract(int n) + { + long result = (long) value - n; + if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) + return new Fixnum((int)result); + else + return new Bignum(result); + } + + @Override + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return number((long) value - ((Fixnum)obj).value); + if (obj instanceof Bignum) + return number(getBigInteger().subtract(Bignum.getValue(obj))); + if (obj instanceof Ratio) + { + BigInteger numerator = ((Ratio)obj).numerator(); + BigInteger denominator = ((Ratio)obj).denominator(); + return number( + getBigInteger().multiply(denominator).subtract(numerator), + denominator); + } + if (obj instanceof SingleFloat) + return new SingleFloat(value - ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value - ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return Complex.getInstance(subtract(c.getRealPart()), + ZERO.subtract(c.getImaginaryPart())); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject multiplyBy(int n) + { + long result = (long) value * n; + if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) + return new Fixnum((int)result); + else + return new Bignum(result); + } + + @Override + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + { + long result = (long) value * ((Fixnum)obj).value; + if (result >= Integer.MIN_VALUE && result <= Integer.MAX_VALUE) + return new Fixnum((int)result); + else + return new Bignum(result); + } + if (obj instanceof Bignum) + return number(getBigInteger().multiply(((Bignum)obj).value)); + if (obj instanceof Ratio) + { + BigInteger numerator = ((Ratio)obj).numerator(); + BigInteger denominator = ((Ratio)obj).denominator(); + return number( + getBigInteger().multiply(numerator), + denominator); + } + if (obj instanceof SingleFloat) + return new SingleFloat(value * ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value * ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + return Complex.getInstance(multiplyBy(c.getRealPart()), + multiplyBy(c.getImaginaryPart())); + } + return type_error(obj, Symbol.NUMBER); + } + + @Override + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + try + { + if (obj instanceof Fixnum) + { + final int divisor = ((Fixnum)obj).value; + // (/ MOST-NEGATIVE-FIXNUM -1) is a bignum. + if (value > Integer.MIN_VALUE) + if (value % divisor == 0) + return new Fixnum(value / divisor); + return number(BigInteger.valueOf(value), + BigInteger.valueOf(divisor)); + } + if (obj instanceof Bignum) + return number(getBigInteger(), ((Bignum)obj).value); + if (obj instanceof Ratio) + { + BigInteger numerator = ((Ratio)obj).numerator(); + BigInteger denominator = ((Ratio)obj).denominator(); + return number(getBigInteger().multiply(denominator), + numerator); + } + if (obj instanceof SingleFloat) + return new SingleFloat(value / ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value / ((DoubleFloat)obj).value); + if (obj instanceof Complex) + { + Complex c = (Complex) obj; + LispObject realPart = c.getRealPart(); + LispObject imagPart = c.getImaginaryPart(); + LispObject denominator = + realPart.multiplyBy(realPart).add(imagPart.multiplyBy(imagPart)); + return Complex.getInstance(multiplyBy(realPart).divideBy(denominator), + Fixnum.ZERO.subtract(multiplyBy(imagPart).divideBy(denominator))); + } + return type_error(obj, Symbol.NUMBER); + } + catch (ArithmeticException e) + { + if (obj.zerop()) + return error(new DivisionByZero()); + return error(new ArithmeticError(e.getMessage())); + } + } + + @Override + public boolean isEqualTo(int n) + { + return value == n; + } + + @Override + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value == ((Fixnum)obj).value; + if (obj instanceof SingleFloat) + return isEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return value == ((DoubleFloat)obj).value; + if (obj instanceof Complex) + return obj.isEqualTo(this); + if (obj.numberp()) + return false; + type_error(obj, Symbol.NUMBER); + // Not reached. + return false; + } + + @Override + public boolean isNotEqualTo(int n) + { + return value != n; + } + + @Override + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value != ((Fixnum)obj).value; + // obj is not a fixnum. + if (obj instanceof SingleFloat) + return isNotEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return value != ((DoubleFloat)obj).value; + if (obj instanceof Complex) + return obj.isNotEqualTo(this); + if (obj.numberp()) + return true; + type_error(obj, Symbol.NUMBER); + // Not reached. + return false; + } + + @Override + public boolean isLessThan(int n) + { + return value < n; + } + + @Override + public boolean isLessThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value < ((Fixnum)obj).value; + if (obj instanceof Bignum) + return getBigInteger().compareTo(Bignum.getValue(obj)) < 0; + if (obj instanceof Ratio) + { + BigInteger n = getBigInteger().multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) < 0; + } + if (obj instanceof SingleFloat) + return isLessThan(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isLessThan(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThan(int n) throws ConditionThrowable + { + return value > n; + } + + @Override + public boolean isGreaterThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value > ((Fixnum)obj).value; + if (obj instanceof Bignum) + return getBigInteger().compareTo(Bignum.getValue(obj)) > 0; + if (obj instanceof Ratio) + { + BigInteger n = getBigInteger().multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) > 0; + } + if (obj instanceof SingleFloat) + return isGreaterThan(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isGreaterThan(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isLessThanOrEqualTo(int n) + { + return value <= n; + } + + @Override + public boolean isLessThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value <= ((Fixnum)obj).value; + if (obj instanceof Bignum) + return getBigInteger().compareTo(Bignum.getValue(obj)) <= 0; + if (obj instanceof Ratio) + { + BigInteger n = getBigInteger().multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) <= 0; + } + if (obj instanceof SingleFloat) + return isLessThanOrEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isLessThanOrEqualTo(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThanOrEqualTo(int n) + { + return value >= n; + } + + @Override + public boolean isGreaterThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return value >= ((Fixnum)obj).value; + if (obj instanceof Bignum) + return getBigInteger().compareTo(Bignum.getValue(obj)) >= 0; + if (obj instanceof Ratio) + { + BigInteger n = getBigInteger().multiply(((Ratio)obj).denominator()); + return n.compareTo(((Ratio)obj).numerator()) >= 0; + } + if (obj instanceof SingleFloat) + return isGreaterThanOrEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isGreaterThanOrEqualTo(((DoubleFloat)obj).rational()); + type_error(obj, Symbol.REAL); + // Not reached. + return false; + } + + @Override + public LispObject truncate(LispObject obj) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final LispObject value1, value2; + try + { + if (obj instanceof Fixnum) + { + int divisor = ((Fixnum)obj).value; + int quotient = value / divisor; + int remainder = value % divisor; + value1 = new Fixnum(quotient); + value2 = remainder == 0 ? Fixnum.ZERO : new Fixnum(remainder); + } + else if (obj instanceof Bignum) + { + BigInteger val = getBigInteger(); + BigInteger divisor = ((Bignum)obj).value; + BigInteger[] results = val.divideAndRemainder(divisor); + BigInteger quotient = results[0]; + BigInteger remainder = results[1]; + value1 = number(quotient); + value2 = (remainder.signum() == 0) ? Fixnum.ZERO : number(remainder); + } + else if (obj instanceof Ratio) + { + Ratio divisor = (Ratio) obj; + LispObject quotient = + multiplyBy(divisor.DENOMINATOR()).truncate(divisor.NUMERATOR()); + LispObject remainder = + subtract(quotient.multiplyBy(divisor)); + value1 = quotient; + value2 = remainder; + } + else if (obj instanceof SingleFloat) + { + // "When rationals and floats are combined by a numerical function, + // the rational is first converted to a float of the same format." + // 12.1.4.1 + return new SingleFloat(value).truncate(obj); + } + else if (obj instanceof DoubleFloat) + { + // "When rationals and floats are combined by a numerical function, + // the rational is first converted to a float of the same format." + // 12.1.4.1 + return new DoubleFloat(value).truncate(obj); + } + else + return type_error(obj, Symbol.REAL); + } + catch (ArithmeticException e) + { + if (obj.zerop()) + return error(new DivisionByZero()); + else + return error(new ArithmeticError(e.getMessage())); + } + return thread.setValues(value1, value2); + } + + @Override + public LispObject MOD(LispObject divisor) throws ConditionThrowable + { + if (divisor instanceof Fixnum) + return MOD(((Fixnum)divisor).value); + return super.MOD(divisor); + } + + @Override + public LispObject MOD(int divisor) throws ConditionThrowable + { + final int r; + try + { + r = value % divisor; + } + catch (ArithmeticException e) + { + return error(new ArithmeticError("Division by zero.")); + } + if (r == 0) + return Fixnum.ZERO; + if (divisor < 0) + { + if (value > 0) + return new Fixnum(r + divisor); + } + else + { + if (value < 0) + return new Fixnum(r + divisor); + } + return new Fixnum(r); + } + + @Override + public LispObject ash(int shift) + { + if (value == 0) + return this; + if (shift == 0) + return this; + long n = value; + if (shift <= -32) + { + // Right shift. + return n >= 0 ? Fixnum.ZERO : Fixnum.MINUS_ONE; + } + if (shift < 0) + return new Fixnum((int)(n >> -shift)); + if (shift <= 32) + { + n = n << shift; + if (n >= Integer.MIN_VALUE && n <= Integer.MAX_VALUE) + return new Fixnum((int)n); + else + return new Bignum(n); + } + // BigInteger.shiftLeft() succumbs to a stack overflow if shift + // is Integer.MIN_VALUE, so... + if (shift == Integer.MIN_VALUE) + return n >= 0 ? Fixnum.ZERO : Fixnum.MINUS_ONE; + return number(BigInteger.valueOf(value).shiftLeft(shift)); + } + + @Override + public LispObject ash(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return ash(((Fixnum)obj).value); + if (obj instanceof Bignum) + { + if (value == 0) + return this; + BigInteger n = BigInteger.valueOf(value); + BigInteger shift = ((Bignum)obj).value; + if (shift.signum() > 0) + return error(new LispError("Can't represent result of left shift.")); + if (shift.signum() < 0) + return n.signum() >= 0 ? Fixnum.ZERO : Fixnum.MINUS_ONE; + Debug.bug(); // Shouldn't happen. + } + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LOGNOT() + { + return new Fixnum(~value); + } + + @Override + public LispObject LOGAND(int n) throws ConditionThrowable + { + return new Fixnum(value & n); + } + + @Override + public LispObject LOGAND(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new Fixnum(value & ((Fixnum)obj).value); + if (obj instanceof Bignum) + { + if (value >= 0) + { + int n2 = (((Bignum)obj).value).intValue(); + return new Fixnum(value & n2); + } + else + { + BigInteger n1 = getBigInteger(); + BigInteger n2 = ((Bignum)obj).value; + return number(n1.and(n2)); + } + } + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LOGIOR(int n) throws ConditionThrowable + { + return new Fixnum(value | n); + } + + @Override + public LispObject LOGIOR(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new Fixnum(value | ((Fixnum)obj).value); + if (obj instanceof Bignum) + { + BigInteger n1 = getBigInteger(); + BigInteger n2 = ((Bignum)obj).value; + return number(n1.or(n2)); + } + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LOGXOR(int n) throws ConditionThrowable + { + return new Fixnum(value ^ n); + } + + @Override + public LispObject LOGXOR(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new Fixnum(value ^ ((Fixnum)obj).value); + if (obj instanceof Bignum) + { + BigInteger n1 = getBigInteger(); + BigInteger n2 = ((Bignum)obj).value; + return number(n1.xor(n2)); + } + return type_error(obj, Symbol.INTEGER); + } + + @Override + public LispObject LDB(int size, int position) + { + long n = (long) value >> position; + long mask = (1L << size) - 1; + return number(n & mask); + } + + final static BigInteger BIGINTEGER_TWO = new BigInteger ("2"); + + /** Computes fixnum^bignum, returning a fixnum or a bignum. + */ + public LispObject pow(LispObject obj) throws ConditionThrowable + { + BigInteger y = Bignum.getValue(obj); + + if (y.compareTo (BigInteger.ZERO) < 0) + return (new Fixnum(1)).divideBy(this.pow(new Bignum(y.negate()))); + + if (y.compareTo(BigInteger.ZERO) == 0) + // No need to test base here; CLHS says 0^0 == 1. + return new Fixnum(1); + + int x = this.value; + + if (x == 0) + return new Fixnum(0); + + if (x == 1) + return new Fixnum(1); + + BigInteger xy = BigInteger.ONE; + BigInteger term = BigInteger.valueOf((long) x); + + while (! y.equals(BigInteger.ZERO)) + { + if (y.testBit(0)) + xy = xy.multiply(term); + + term = term.multiply(term); + y = y.shiftLeft(1); + } + + return new Bignum(xy); + } + + @Override + public int hashCode() + { + return value; + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); + String s = Integer.toString(value, base).toUpperCase(); + if (Symbol.PRINT_RADIX.symbolValue(thread) != NIL) + { + FastStringBuffer sb = new FastStringBuffer(); + switch (base) + { + case 2: + sb.append("#b"); + sb.append(s); + break; + case 8: + sb.append("#o"); + sb.append(s); + break; + case 10: + sb.append(s); + sb.append('.'); + break; + case 16: + sb.append("#x"); + sb.append(s); + break; + default: + sb.append('#'); + sb.append(String.valueOf(base)); + sb.append('r'); + sb.append(s); + break; + } + s = sb.toString(); + } + return s; + } +} Added: branches/save-image/src/org/armedbear/lisp/FloatFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FloatFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,470 @@ +/* + * FloatFunctions.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: FloatFunctions.java 11572 2009-01-21 21:25:18Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class FloatFunctions extends Lisp +{ + // ### set-floating-point-modes &key traps => + private static final Primitive SET_FLOATING_POINT_MODES = + new Primitive("set-floating-point-modes", PACKAGE_EXT, true, + "&key traps") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length % 2 != 0) + error(new ProgramError("Odd number of keyword arguments.")); + for (int i = 0; i < args.length; i += 2) { + LispObject key = checkSymbol(args[i]); + LispObject value = args[i+1]; + if (key == Keyword.TRAPS) { + boolean trap_overflow = false; + boolean trap_underflow = false; + while (value != NIL) { + LispObject car = value.car(); + if (car == Keyword.OVERFLOW) + trap_overflow = true; + else if (car == Keyword.UNDERFLOW) + trap_underflow = true; + else + error(new LispError("Unsupported floating point trap: " + + car.writeToString())); + value = value.cdr(); + } + TRAP_OVERFLOW = trap_overflow; + TRAP_UNDERFLOW = trap_underflow; + } else + error(new LispError("Unrecognized keyword: " + key.writeToString())); + } + return LispThread.currentThread().nothing(); + } + }; + + // ### get-floating-point-modes => modes + private static final Primitive GET_FLOATING_POINT_MODES = + new Primitive("get-floating-point-modes", PACKAGE_EXT, true, "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + LispObject traps = NIL; + if (TRAP_UNDERFLOW) + traps = traps.push(Keyword.UNDERFLOW); + if (TRAP_OVERFLOW) + traps = traps.push(Keyword.OVERFLOW); + return list2(Keyword.TRAPS, traps); + } + }; + + // ### integer-decode-float float => significand, exponent, integer-sign + private static final Primitive INTEGER_DECODE_FLOAT = + new Primitive("integer-decode-float", "float") + { +// (defun sane-integer-decode-float (float) +// (multiple-value-bind (mantissa exp sign) +// (integer-decode-float float) +// (let ((fixup (- (integer-length mantissa) (float-precision float)))) +// (values (ash mantissa (- fixup)) +// (+ exp fixup) +// sign)))) + + // See also: http://paste.lisp.org/display/10847 + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) { + int bits = + Float.floatToRawIntBits(((SingleFloat)arg).value); + int s = ((bits >> 31) == 0) ? 1 : -1; + int e = (int) ((bits >> 23) & 0xffL); + int m; + if (e == 0) + m = (bits & 0x7fffff) << 1; + else + m = (bits & 0x7fffff) | 0x800000; + LispObject significand = number(m); + Fixnum exponent = new Fixnum(e - 150); + Fixnum sign = new Fixnum(s); + return LispThread.currentThread().setValues(significand, + exponent, + sign); + } + if (arg instanceof DoubleFloat) { + long bits = + Double.doubleToRawLongBits((double)((DoubleFloat)arg).value); + int s = ((bits >> 63) == 0) ? 1 : -1; + int e = (int) ((bits >> 52) & 0x7ffL); + long m; + if (e == 0) + m = (bits & 0xfffffffffffffL) << 1; + else + m = (bits & 0xfffffffffffffL) | 0x10000000000000L; + LispObject significand = number(m); + Fixnum exponent = new Fixnum(e - 1075); + Fixnum sign = new Fixnum(s); + return LispThread.currentThread().setValues(significand, + exponent, + sign); + } + return type_error(arg, Symbol.FLOAT); + } + }; + + // ### %float-bits float => integer + private static final Primitive _FLOAT_BITS = + new Primitive("%float-bits", PACKAGE_SYS, true, "integer") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) { + int bits = Float.floatToIntBits(((SingleFloat)arg).value); + BigInteger big = BigInteger.valueOf(bits >> 1); + return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO)); + } + if (arg instanceof DoubleFloat) { + long bits = Double.doubleToLongBits(((DoubleFloat)arg).value); + BigInteger big = BigInteger.valueOf(bits >> 1); + return new Bignum(big.shiftLeft(1).add(((bits & 1) == 1) ? BigInteger.ONE : BigInteger.ZERO)); + } + return type_error(arg, Symbol.FLOAT); + } + }; + + // ### rational + private static final Primitive RATIONAL = + new Primitive("rational", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) + return ((SingleFloat)arg).rational(); + if (arg instanceof DoubleFloat) + return ((DoubleFloat)arg).rational(); + if (arg.rationalp()) + return arg; + return type_error(arg, Symbol.REAL); + } + }; + + // ### float-radix + // float-radix float => float-radix + private static final Primitive FLOAT_RADIX = + new Primitive("float-radix", "float") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat || arg instanceof DoubleFloat) + return Fixnum.TWO; + return type_error(arg, Symbol.FLOAT); + } + }; + + private static final Fixnum FIXNUM_24 = new Fixnum(24); + private static final Fixnum FIXNUM_53 = new Fixnum(53); + + // ### float-digits + // float-digits float => float-digits + private static final Primitive FLOAT_DIGITS = + new Primitive("float-digits", "float") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) + return FIXNUM_24; + if (arg instanceof DoubleFloat) + return FIXNUM_53; + return type_error(arg, Symbol.FLOAT); + } + }; + + // ### scale-float float integer => scaled-float + private static final Primitive SCALE_FLOAT = + new Primitive("scale-float", "float integer") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof SingleFloat) { + float f = ((SingleFloat)first).value; + int n = Fixnum.getValue(second); + return new SingleFloat(f * (float) Math.pow(2, n)); + } + if (first instanceof DoubleFloat) { + double d = ((DoubleFloat)first).value; + int n = Fixnum.getValue(second); + return new DoubleFloat(d * Math.pow(2, n)); + } + return type_error(first, Symbol.FLOAT); + } + }; + + // ### coerce-to-single-float + private static final Primitive COERCE_TO_SINGLE_FLOAT = + new Primitive("coerce-to-single-float", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return SingleFloat.coerceToFloat(arg); + } + }; + + // ### coerce-to-double-float + private static final Primitive COERCE_TO_DOUBLE_FLOAT = + new Primitive("coerce-to-double-float", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return DoubleFloat.coerceToFloat(arg); + } + }; + + // ### float + // float number &optional prototype => float + private static final Primitive FLOAT = + new Primitive("float", "number &optional prototype") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat || arg instanceof DoubleFloat) + return arg; + return SingleFloat.coerceToFloat(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (second instanceof SingleFloat) + return SingleFloat.coerceToFloat(first); + if (second instanceof DoubleFloat) + return DoubleFloat.coerceToFloat(first); + return type_error(second, Symbol.FLOAT); + } + }; + + // ### floatp + // floatp object => generalized-boolean + private static final Primitive FLOATP = new Primitive("floatp", "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) + return T; + if (arg instanceof DoubleFloat) + return T; + return NIL; + } + }; + + // ### single-float-bits + private static final Primitive SINGLE_FLOAT_BITS = + new Primitive("single-float-bits", PACKAGE_SYS, true, "float") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) { + SingleFloat f = (SingleFloat) arg; + return new Fixnum(Float.floatToIntBits(f.value)); + } + return type_error(arg, Symbol.FLOAT); + } + }; + + // ### double-float-high-bits + private static final Primitive DOUBLE_FLOAT_HIGH_BITS = + new Primitive("double-float-high-bits", PACKAGE_SYS, true, "float") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof DoubleFloat) { + DoubleFloat f = (DoubleFloat) arg; + return number(Double.doubleToLongBits(f.value) >>> 32); + } + return type_error(arg, Symbol.DOUBLE_FLOAT); + } + }; + + // ### double-float-low-bits + private static final Primitive DOUBLE_FLOAT_LOW_BITS = + new Primitive("double-float-low-bits", PACKAGE_SYS, true, "float") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof DoubleFloat) { + DoubleFloat f = (DoubleFloat) arg; + return number(Double.doubleToLongBits(f.value) & 0xffffffffL); + } + return type_error(arg, Symbol.DOUBLE_FLOAT); + } + }; + + // ### make-single-float bits => float + private static final Primitive MAKE_SINGLE_FLOAT = + new Primitive("make-single-float", PACKAGE_SYS, true, "bits") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof Fixnum) { + int bits = ((Fixnum)arg).value; + return new SingleFloat(Float.intBitsToFloat(bits)); + } + if (arg instanceof Bignum) { + long bits = ((Bignum)arg).value.longValue(); + return new SingleFloat(Float.intBitsToFloat((int)bits)); + } + return type_error(arg, Symbol.INTEGER); + } + }; + + // ### make-double-float bits => float + private static final Primitive MAKE_DOUBLE_FLOAT = + new Primitive("make-double-float", PACKAGE_SYS, true, "bits") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof Fixnum) { + long bits = (long) ((Fixnum)arg).value; + return new DoubleFloat(Double.longBitsToDouble(bits)); + } + if (arg instanceof Bignum) { + long bits = ((Bignum)arg).value.longValue(); + return new DoubleFloat(Double.longBitsToDouble(bits)); + } + return type_error(arg, Symbol.INTEGER); + } + }; + + // ### float-infinity-p + private static final Primitive FLOAT_INFINITY_P = + new Primitive("float-infinity-p", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof SingleFloat) + return Float.isInfinite(((SingleFloat)arg).value) ? T : NIL; + if (arg instanceof DoubleFloat) + return Double.isInfinite(((DoubleFloat)arg).value) ? T : NIL; + return type_error(arg, Symbol.FLOAT); + } + }; + + // ### float-nan-p + private static final Primitive FLOAT_NAN_P = + new Primitive("float-nan-p", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof SingleFloat) + return Float.isNaN(((SingleFloat)arg).value) ? T : NIL; + if (arg instanceof DoubleFloat) + return Double.isNaN(((DoubleFloat)arg).value) ? T : NIL; + return type_error(arg, Symbol.FLOAT); + } + }; + + // ### float-string + private static final Primitive FLOAT_STRING = + new Primitive("float-string", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final String s1; + if (arg instanceof SingleFloat) + s1 = String.valueOf(((SingleFloat)arg).value); + else if (arg instanceof DoubleFloat) + s1 = String.valueOf(((DoubleFloat)arg).value); + else + return type_error(arg, Symbol.FLOAT); + int i = s1.indexOf('E'); + if (i < 0) + return new SimpleString(s1); + String s2 = s1.substring(0, i); + int exponent = Integer.parseInt(s1.substring(i + 1)); + if (exponent == 0) + return new SimpleString(s2); + int index = s2.indexOf('.'); + if (index < 0) + return new SimpleString(s2); + StringBuffer sb = new StringBuffer(s2); + if (index >= 0) + sb.deleteCharAt(index); + // Now we've got just the digits in the StringBuffer. + if (exponent > 0) { + int newIndex = index + exponent; + if (newIndex < sb.length()) + sb.insert(newIndex, '.'); + else if (newIndex == sb.length()) + sb.append('.'); + else { + // We need to add some zeros. + while (newIndex > sb.length()) + sb.append('0'); + sb.append('.'); + } + } else { + Debug.assertTrue(exponent < 0); + int newIndex = index + exponent; + while (newIndex < 0) { + sb.insert(0, '0'); + ++newIndex; + } + sb.insert(0, '.'); + } + return new SimpleString(sb.toString()); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/FloatingPointInexact.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FloatingPointInexact.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,65 @@ +/* + * FloatingPointInexact.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: FloatingPointInexact.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FloatingPointInexact extends ArithmeticError +{ + public FloatingPointInexact(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.FLOATING_POINT_INEXACT); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.FLOATING_POINT_INEXACT; + } + + @Override + public LispObject classOf() + { + return StandardClass.FLOATING_POINT_INEXACT; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.FLOATING_POINT_INEXACT) + return T; + if (type == StandardClass.FLOATING_POINT_INEXACT) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/FloatingPointInvalidOperation.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FloatingPointInvalidOperation.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,66 @@ +/* + * FloatingPointInvalidOperation.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: FloatingPointInvalidOperation.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FloatingPointInvalidOperation extends ArithmeticError +{ + public FloatingPointInvalidOperation(LispObject initArgs) + throws ConditionThrowable + { + super(StandardClass.FLOATING_POINT_INVALID_OPERATION); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.FLOATING_POINT_INVALID_OPERATION; + } + + @Override + public LispObject classOf() + { + return StandardClass.FLOATING_POINT_INVALID_OPERATION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.FLOATING_POINT_INVALID_OPERATION) + return T; + if (type == StandardClass.FLOATING_POINT_INVALID_OPERATION) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/FloatingPointOverflow.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FloatingPointOverflow.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,66 @@ +/* + * FloatingPointOverflow.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: FloatingPointOverflow.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FloatingPointOverflow extends ArithmeticError +{ + public FloatingPointOverflow(LispObject initArgs) + throws ConditionThrowable + { + super(StandardClass.FLOATING_POINT_OVERFLOW); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.FLOATING_POINT_OVERFLOW; + } + + @Override + public LispObject classOf() + { + return StandardClass.FLOATING_POINT_OVERFLOW; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.FLOATING_POINT_OVERFLOW) + return T; + if (type == StandardClass.FLOATING_POINT_OVERFLOW) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/FloatingPointUnderflow.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FloatingPointUnderflow.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,66 @@ +/* + * FloatingPointUnderflow.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: FloatingPointUnderflow.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class FloatingPointUnderflow extends ArithmeticError +{ + public FloatingPointUnderflow(LispObject initArgs) + throws ConditionThrowable + { + super(StandardClass.FLOATING_POINT_UNDERFLOW); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.FLOATING_POINT_UNDERFLOW; + } + + @Override + public LispObject classOf() + { + return StandardClass.FLOATING_POINT_UNDERFLOW; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.FLOATING_POINT_UNDERFLOW) + return T; + if (type == StandardClass.FLOATING_POINT_UNDERFLOW) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/ForwardReferencedClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ForwardReferencedClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,97 @@ +/* + * ForwardReferencedClass.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: ForwardReferencedClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class ForwardReferencedClass extends LispClass +{ + public ForwardReferencedClass(Symbol name) + { + super(name); + } + + @Override + public LispObject typeOf() + { + return Symbol.FORWARD_REFERENCED_CLASS; + } + + @Override + public LispObject classOf() + { + return StandardClass.FORWARD_REFERENCED_CLASS; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.FORWARD_REFERENCED_CLASS) + return T; + if (type == StandardClass.FORWARD_REFERENCED_CLASS) + return T; + return super.typep(type); + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = + new StringBuffer(Symbol.FORWARD_REFERENCED_CLASS.writeToString()); + if (symbol != null) { + sb.append(' '); + sb.append(symbol.writeToString()); + } + return unreadableString(sb.toString()); + } + + // ### make-forward-referenced-class + private static final Primitive MAKE_FORWARD_REFERENCED_CLASS = + new Primitive("make-forward-referenced-class", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + try { + Symbol name = (Symbol) arg; + ForwardReferencedClass c = new ForwardReferencedClass(name); + LispClass.addClass(name, c); + return c; + } + catch (ClassCastException e) { + return error(new TypeError(arg.writeToString() + + " is not a valid class name.")); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Function.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Function.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,343 @@ +/* + * Function.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Function.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class Function extends Operator +{ + private LispObject propertyList = NIL; + private int callCount; + + protected Function() {} + + public Function(String name) + { + if (name != null) { + Symbol symbol = Symbol.addFunction(name.toUpperCase(), this); + if (cold) + symbol.setBuiltInFunction(true); + setLambdaName(symbol); + } + } + + public Function(Symbol symbol, String arglist) + { + symbol.setSymbolFunction(this); + if (cold) + symbol.setBuiltInFunction(true); + setLambdaName(symbol); + setLambdaList(new SimpleString(arglist)); + } + + public Function(Symbol symbol, String arglist, String docstring) + { + symbol.setSymbolFunction(this); + if (cold) + symbol.setBuiltInFunction(true); + setLambdaName(symbol); + setLambdaList(new SimpleString(arglist)); + if (docstring != null) { + try { + symbol.setDocumentation(Symbol.FUNCTION, + new SimpleString(docstring)); + } + catch (ConditionThrowable t) { + Debug.assertTrue(false); + } + } + } + + public Function(String name, String arglist) + { + this(name); + setLambdaList(new SimpleString(arglist)); + } + + public Function(String name, Package pkg) + { + this(name, pkg, false); + } + + public Function(String name, Package pkg, boolean exported) + { + this(name, pkg, exported, null, null); + } + + public Function(String name, Package pkg, boolean exported, + String arglist) + { + this(name, pkg, exported, arglist, null); + } + + public Function(String name, Package pkg, boolean exported, + String arglist, String docstring) + { + if (arglist instanceof String) + setLambdaList(new SimpleString(arglist)); + if (name != null) { + try { + Symbol symbol; + if (exported) + symbol = pkg.internAndExport(name.toUpperCase()); + else + symbol = pkg.intern(name.toUpperCase()); + symbol.setSymbolFunction(this); + if (cold) + symbol.setBuiltInFunction(true); + setLambdaName(symbol); + if (docstring != null) + symbol.setDocumentation(Symbol.FUNCTION, + new SimpleString(docstring)); + } + catch (ConditionThrowable t) { + Debug.assertTrue(false); + } + } + } + + public Function(LispObject name) + { + setLambdaName(name); + } + + public Function(LispObject name, LispObject lambdaList) + { + setLambdaName(name); + setLambdaList(lambdaList); + } + + @Override + public LispObject typeOf() + { + return Symbol.FUNCTION; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.FUNCTION; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.FUNCTION) + return T; + if (typeSpecifier == Symbol.COMPILED_FUNCTION) + return T; + if (typeSpecifier == BuiltInClass.FUNCTION) + return T; + return super.typep(typeSpecifier); + } + + @Override + public final LispObject getPropertyList() + { + if (propertyList == null) + propertyList = NIL; + return propertyList; + } + + @Override + public final void setPropertyList(LispObject obj) + { + if (obj == null) + throw new NullPointerException(); + propertyList = obj; + } + + public final void setClassBytes(byte[] bytes) throws ConditionThrowable + { + propertyList = putf(propertyList, Symbol.CLASS_BYTES, + new JavaObject(bytes)); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + + @Override + public String writeToString() throws ConditionThrowable + { + LispObject name = getLambdaName(); + if (name != null && name != NIL) { + StringBuffer sb = new StringBuffer("#"); + return sb.toString(); + } + // No name. + LispObject lambdaList = getLambdaList(); + if (lambdaList != null) { + StringBuffer sb = new StringBuffer("#"); + return sb.toString(); + } + return unreadableString("FUNCTION"); + } + + // Used by the JVM compiler. + public final void argCountError() throws ConditionThrowable + { + error(new WrongNumberOfArgumentsException(this)); + } + + @Override + // Profiling. + public final int getCallCount() + { + return callCount; + } + + @Override + public void setCallCount(int n) + { + callCount = n; + } + + @Override + public final void incrementCallCount() + { + ++callCount; + } + + protected Object writeReplace() throws java.io.ObjectStreamException { + if(getClass().getSimpleName().contains("ABCL_GENERATED_")) { + try { + return new ExternalizedCompiledFunction((byte[] ) getf(propertyList, Symbol.CLASS_BYTES, + new JavaObject(new byte[0])).javaInstance(), + lambdaName.writeToString(), + getClass().getName()); + } catch(ConditionThrowable c) { + throw new java.io.InvalidClassException(getClass().getName()); + } + } else { + return this; + } + } + +} Added: branches/save-image/src/org/armedbear/lisp/FunctionBinding.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/FunctionBinding.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,54 @@ +/* + * FunctionBinding.java + * + * Copyright (C) 2005 Peter Graves + * $Id: FunctionBinding.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// Package accessibility. +final class FunctionBinding +{ + LispObject name; + LispObject value; + final FunctionBinding next; + + FunctionBinding() + { + next = null; + } + + FunctionBinding(LispObject name, LispObject value, FunctionBinding next) + { + this.name = name; + this.value = value; + this.next = next; + } +} Added: branches/save-image/src/org/armedbear/lisp/GenericFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/GenericFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * GenericFunction.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: GenericFunction.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class GenericFunction extends StandardObject +{ + protected GenericFunction(LispClass cls, int length) + { + super(cls, length); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.GENERIC_FUNCTION) + return T; + if (type == StandardClass.GENERIC_FUNCTION) + return T; + if (type == Symbol.FUNCTION) + return T; + if (type == BuiltInClass.FUNCTION) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Go.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Go.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +/* + * Go.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Go.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Go extends ConditionThrowable +{ + public final LispObject tag; + + public Go(LispObject tag) + { + this.tag = tag; + } + + public LispObject getTag() + { + return tag; + } + + @Override + public LispObject getCondition() throws ConditionThrowable + { + try { + StringBuffer sb = new StringBuffer("No tag named "); + sb.append(tag.writeToString()); + sb.append(" is currently visible"); + return new ControlError(sb.toString()); + } + catch (Throwable t) { + Debug.trace(t); + return new Condition(); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/HashTable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/HashTable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,311 @@ +/* + * HashTable.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: HashTable.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class HashTable extends LispObject +{ + private static final int DEFAULT_SIZE = 16; + + protected static final float loadFactor = 0.75f; + + protected final LispObject rehashSize; + protected final LispObject rehashThreshold; + + // The rounded product of the capacity and the load factor. When the number + // of elements exceeds the threshold, the implementation calls rehash(). + protected int threshold; + + // Array containing the actual key-value mappings. + protected HashEntry[] buckets; + + // The number of key-value pairs. + protected int count; + + protected HashTable() + { + rehashSize = new SingleFloat(1.5f); // FIXME + rehashThreshold = new SingleFloat(0.75f); // FIXME + buckets = new HashEntry[DEFAULT_SIZE]; + threshold = (int) (DEFAULT_SIZE * loadFactor); + } + + protected HashTable(int size, LispObject rehashSize, + LispObject rehashThreshold) + { + this.rehashSize = rehashSize; + this.rehashThreshold = rehashThreshold; + buckets = new HashEntry[size]; + threshold = (int) (size * loadFactor); + } + + protected static int calculateInitialCapacity(int size) + { + int capacity = 1; + while (capacity < size) + capacity <<= 1; + return capacity; + } + + public final LispObject getRehashSize() + { + return rehashSize; + } + + public final LispObject getRehashThreshold() + { + return rehashThreshold; + } + + public int getSize() + { + return buckets.length; + } + + public int getCount() + { + return count; + } + + public abstract Symbol getTest(); + + @Override + public LispObject typeOf() + { + return Symbol.HASH_TABLE; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.HASH_TABLE; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.HASH_TABLE) + return T; + if (type == BuiltInClass.HASH_TABLE) + return T; + return super.typep(type); + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof HashTable) + { + HashTable ht = (HashTable) obj; + if (count != ht.count) + return false; + if (getTest() != ht.getTest()) + return false; + LispObject entries = ENTRIES(); + while (entries != NIL) + { + LispObject entry = entries.car(); + LispObject key = entry.car(); + LispObject value = entry.cdr(); + if (!value.equalp(ht.get(key))) + return false; + entries = entries.cdr(); + } + return true; + } + return false; + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject parts = NIL; + for (int i = 0; i < buckets.length; i++) + { + HashEntry e = buckets[i]; + while (e != null) + { + parts = parts.push(new Cons("KEY [bucket " + i + "]", e.key)); + parts = parts.push(new Cons("VALUE", e.value)); + e = e.next; + } + } + return parts.nreverse(); + } + + public synchronized void clear() + { + for (int i = buckets.length; i-- > 0;) + buckets[i] = null; + count = 0; + } + + // gethash key hash-table &optional default => value, present-p + public synchronized LispObject gethash(LispObject key) + throws ConditionThrowable + { + LispObject value = get(key); + final LispObject presentp; + if (value == null) + value = presentp = NIL; + else + presentp = T; + return LispThread.currentThread().setValues(value, presentp); + } + + // gethash key hash-table &optional default => value, present-p + public synchronized LispObject gethash(LispObject key, + LispObject defaultValue) + throws ConditionThrowable + { + LispObject value = get(key); + final LispObject presentp; + if (value == null) + { + value = defaultValue; + presentp = NIL; + } + else + presentp = T; + return LispThread.currentThread().setValues(value, presentp); + } + + public synchronized LispObject gethash1(LispObject key) + throws ConditionThrowable + { + final LispObject value = get(key); + return value != null ? value : NIL; + } + + public synchronized LispObject puthash(LispObject key, LispObject newValue) + throws ConditionThrowable + { + put(key, newValue); + return newValue; + } + + // remhash key hash-table => generalized-boolean + public synchronized LispObject remhash(LispObject key) + throws ConditionThrowable + { + // A value in a Lisp hash table can never be null, so... + return remove(key) != null ? T : NIL; + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (Symbol.PRINT_READABLY.symbolValue(LispThread.currentThread()) != NIL) + { + error(new PrintNotReadable(list2(Keyword.OBJECT, this))); + return null; // Not reached. + } + FastStringBuffer sb = new FastStringBuffer(getTest().writeToString()); + sb.append(' '); + sb.append(Symbol.HASH_TABLE.writeToString()); + sb.append(' '); + sb.append(count); + if (count == 1) + sb.append(" entry"); + else + sb.append(" entries"); + sb.append(", "); + sb.append(buckets.length); + sb.append(" buckets"); + return unreadableString(sb.toString()); + } + + public abstract LispObject get(LispObject key); + + public abstract void put(LispObject key, LispObject value) + throws ConditionThrowable; + + public abstract LispObject remove(LispObject key) throws ConditionThrowable; + + protected abstract void rehash(); + + // Returns a list of (key . value) pairs. + public LispObject ENTRIES() + { + LispObject list = NIL; + for (int i = buckets.length; i-- > 0;) + { + HashEntry e = buckets[i]; + while (e != null) + { + list = new Cons(new Cons(e.key, e.value), list); + e = e.next; + } + } + return list; + } + + public LispObject MAPHASH(LispObject function) throws ConditionThrowable + { + for (int i = buckets.length; i-- > 0;) + { + HashEntry e = buckets[i]; + while (e != null) + { + function.execute(e.key, e.value); + e = e.next; + } + } + return NIL; + } + + protected static class HashEntry implements java.io.Serializable + { + LispObject key; + LispObject value; + HashEntry next; + + HashEntry(LispObject key, LispObject value) + { + this.key = key; + this.value = value; + } + } + + // For EQUALP hash tables. + @Override + public int psxhash() + { + long result = 2062775257; // Chosen at random. + result = mix(result, count); + result = mix(result, getTest().sxhash()); + return (int) (result & 0x7fffffff); + } +} Added: branches/save-image/src/org/armedbear/lisp/HashTableFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/HashTableFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,371 @@ +/* + * HashTableFunctions.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: HashTableFunctions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class HashTableFunctions extends Lisp +{ + private static final LispObject FUNCTION_EQ = + Symbol.EQ.getSymbolFunction(); + private static final LispObject FUNCTION_EQL = + Symbol.EQL.getSymbolFunction(); + private static final LispObject FUNCTION_EQUAL = + Symbol.EQUAL.getSymbolFunction(); + private static final LispObject FUNCTION_EQUALP = + Symbol.EQUALP.getSymbolFunction(); + + // ### %make-hash-table + private static final Primitive _MAKE_HASH_TABLE = + new Primitive("%make-hash-table", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject test, LispObject size, + LispObject rehashSize, LispObject rehashThreshold) + throws ConditionThrowable + { + final int n; + try + { + n = ((Fixnum)size).value; + } + catch (ClassCastException e) + { + return type_error(size, Symbol.FIXNUM); + } + if (test == FUNCTION_EQL || test == NIL) + return new EqlHashTable(n, rehashSize, rehashThreshold); + if (test == FUNCTION_EQ) + return new EqHashTable(n, rehashSize, rehashThreshold); + if (test == FUNCTION_EQUAL) + return new EqualHashTable(n, rehashSize, rehashThreshold); + if (test == FUNCTION_EQUALP) + return new EqualpHashTable(n, rehashSize, rehashThreshold); + return error(new LispError("Unsupported test for MAKE-HASH-TABLE: " + + test.writeToString())); + } + }; + + // ### gethash key hash-table &optional default => value, present-p + private static final Primitive GETHASH = + new Primitive(Symbol.GETHASH, "key hash-table &optional default") + { + @Override + public LispObject execute(LispObject key, LispObject ht) + throws ConditionThrowable + { + try + { + return ((HashTable)ht).gethash(key); + } + catch (ClassCastException e) + { + return type_error(ht, Symbol.HASH_TABLE); + } + } + @Override + public LispObject execute(LispObject key, LispObject ht, + LispObject defaultValue) + throws ConditionThrowable + { + try + { + return ((HashTable)ht).gethash(key, defaultValue); + } + catch (ClassCastException e) + { + return type_error(ht, Symbol.HASH_TABLE); + } + } + }; + + // ### gethash1 key hash-table => value + private static final Primitive GETHASH1 = + new Primitive(Symbol.GETHASH1, "key hash-table") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final HashTable ht; + try + { + ht = (HashTable) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.HASH_TABLE); + } + synchronized (ht) + { + final LispObject value = ht.get(first); + return value != null ? value : NIL; + } + } + }; + + // ### puthash key hash-table new-value &optional default => value + private static final Primitive PUTHASH = + new Primitive(Symbol.PUTHASH, + "key hash-table new-value &optional default") + { + @Override + public LispObject execute(LispObject key, LispObject ht, + LispObject value) + throws ConditionThrowable + { + try + { + return ((HashTable)ht).puthash(key, value); + } + catch (ClassCastException e) + { + return type_error(ht, Symbol.HASH_TABLE); + } + } + @Override + public LispObject execute(LispObject key, LispObject ht, + LispObject ignored, LispObject value) + throws ConditionThrowable + { + try + { + return ((HashTable)ht).puthash(key, value); + } + catch (ClassCastException e) + { + return type_error(ht, Symbol.HASH_TABLE); + } + } + }; + + // remhash key hash-table => generalized-boolean + private static final Primitive REMHASH = + new Primitive(Symbol.REMHASH, "key hash-table") + { + @Override + public LispObject execute(LispObject key, LispObject ht) + throws ConditionThrowable + { + try + { + return ((HashTable)ht).remhash(key); + } + catch (ClassCastException e) + { + return type_error(ht, Symbol.HASH_TABLE); + } + } + }; + + // ### clrhash hash-table => hash-table + private static final Primitive CLRHASH = + new Primitive(Symbol.CLRHASH, "hash-table") + { + @Override + public LispObject execute(LispObject ht) throws ConditionThrowable + { + try + { + ((HashTable)ht).clear(); + return ht; + } + catch (ClassCastException e) + { + return type_error(ht, Symbol.HASH_TABLE); + } + } + }; + + // ### hash-table-count + private static final Primitive HASH_TABLE_COUNT = + new Primitive(Symbol.HASH_TABLE_COUNT, "hash-table") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new Fixnum(((HashTable)arg).getCount()); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.HASH_TABLE); + } + } + }; + + // ### sxhash object => hash-code + private static final Primitive SXHASH = + new Primitive(Symbol.SXHASH, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new Fixnum(arg.sxhash()); + } + }; + + // ### psxhash object => hash-code + // For EQUALP hash tables. + private static final Primitive PSXHASH = + new Primitive("psxhash", PACKAGE_SYS, true, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new Fixnum(arg.psxhash()); + } + }; + + // ### hash-table-p + private static final Primitive HASH_TABLE_P = + new Primitive(Symbol.HASH_TABLE_P,"object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof HashTable ? T : NIL; + } + }; + + // ### hash-table-entries + private static final Primitive HASH_TABLE_ENTRIES = + new Primitive("hash-table-entries", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((HashTable)arg).ENTRIES(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.HASH_TABLE); + } + } + }; + + // ### hash-table-test + private static final Primitive HASH_TABLE_TEST = + new Primitive(Symbol.HASH_TABLE_TEST, "hash-table") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((HashTable)arg).getTest(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.HASH_TABLE); + } + } + }; + + // ### hash-table-size + private static final Primitive HASH_TABLE_SIZE = + new Primitive(Symbol.HASH_TABLE_SIZE, "hash-table") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new Fixnum(((HashTable)arg).getSize()); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.HASH_TABLE); + } + } + }; + + // ### hash-table-rehash-size + private static final Primitive HASH_TABLE_REHASH_SIZE = + new Primitive(Symbol.HASH_TABLE_REHASH_SIZE, "hash-table") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((HashTable)arg).getRehashSize(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.HASH_TABLE); + } + } + }; + + // ### hash-table-rehash-threshold + private static final Primitive HASH_TABLE_REHASH_THRESHOLD = + new Primitive(Symbol.HASH_TABLE_REHASH_THRESHOLD, "hash-table") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((HashTable)arg).getRehashThreshold(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.HASH_TABLE); + } + } + }; + + // ### maphash + private static final Primitive MAPHASH = + new Primitive(Symbol.MAPHASH, "function hash-table") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + HashTable ht; + try + { + ht = (HashTable) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.HASH_TABLE); + } + return ht.MAPHASH(first); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Interpreter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,612 @@ +/* + * Interpreter.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: Interpreter.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.BufferedReader; +import java.io.File; +import java.io.IOException; +import java.io.InputStream; +import java.io.InputStreamReader; +import java.io.OutputStream; +import java.lang.reflect.Method; +import java.security.*; + +public final class Interpreter extends Lisp +{ + // There can only be one interpreter. + public static Interpreter interpreter; + + private final boolean jlisp; + private final InputStream inputStream; + private final OutputStream outputStream; + + private static boolean noinit; + private static boolean noinform; + + public static synchronized Interpreter getInstance() + { + return interpreter; + } + + // Interface. + public static synchronized Interpreter createInstance() + { + if (interpreter != null) + return null; + interpreter = new Interpreter(); + _NOINFORM_.setSymbolValue(T); + initializeLisp(); + return interpreter; + } + + public static synchronized Interpreter createDefaultInstance(String[] args) + { + if (interpreter != null) + return null; + interpreter = new Interpreter(); + try { + if (args != null) + preprocessCommandLineArguments(args); + if (!noinform) { + Stream out = getStandardOutput(); + out._writeString(banner()); + out._finishOutput(); + } + if (Utilities.isPlatformUnix) { + try { + System.loadLibrary("abcl"); + Class c = Class.forName("org.armedbear.lisp.Native"); + Method m = c.getMethod("initialize", (Class[]) null); + m.invoke((Object) null, (Object[]) null); + if (!noinform) + getStandardOutput()._writeString("Control-C handler installed.\n"); + } + catch (Throwable t) {} + } + if (noinform) + _NOINFORM_.setSymbolValue(T); + else { + double uptime = (System.currentTimeMillis() - Main.startTimeMillis) / 1000.0; + getStandardOutput()._writeString("Low-level initialization completed in " + + uptime + " seconds.\n"); + } + initializeLisp(); + initializeTopLevel(); + if (!noinit) + processInitializationFile(); + if (args != null) + postprocessCommandLineArguments(args); + } + catch (Throwable t) { + t.printStackTrace(); + } + return interpreter; + } + + public static synchronized Interpreter createJLispInstance( + InputStream in, + OutputStream out, + String initialDirectory, + String version) + { + if (interpreter != null) + return null; + interpreter = new Interpreter(in, out, initialDirectory); + try { + Stream stdout = getStandardOutput(); + stdout._writeLine(version); + stdout._writeString(banner()); + stdout._finishOutput(); + } + catch (Throwable t) { + t.printStackTrace(); + } + initializeJLisp(); + initializeTopLevel(); + processInitializationFile(); + return interpreter; + } + + private Interpreter() + { + Policy.setPolicy( + new Policy() { + public PermissionCollection getPermissions(CodeSource codesource) { + Permissions perms = new Permissions(); + perms.add(new AllPermission()); + return (perms); + } + }); + jlisp = false; + inputStream = null; + outputStream = null; + } + + private Interpreter(InputStream inputStream, OutputStream outputStream, + String initialDirectory) + { + jlisp = true; + this.inputStream = inputStream; + this.outputStream = outputStream; + resetIO(new Stream(inputStream, Symbol.CHARACTER), + new Stream(outputStream, Symbol.CHARACTER)); + if (!initialDirectory.endsWith(File.separator)) + initialDirectory = initialDirectory.concat(File.separator); + try { + Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(new Pathname(initialDirectory)); + } + catch (Throwable t) { + Debug.trace(t); + } + } + + // Interface. + public LispObject eval(String s) throws ConditionThrowable + { + return eval(new StringInputStream(s).read(true, NIL, false, + LispThread.currentThread())); + } + + public static synchronized void initializeLisp() + { + if (!initialized) { + try { + Load.loadSystemFile("boot.lisp", false, false, false); + } + catch (ConditionThrowable c) { + reportError(c, LispThread.currentThread()); + } + catch (Throwable t) { + t.printStackTrace(); + } + initialized = true; + } + } + + public static synchronized void initializeJLisp() + { + if (!initialized) { + try { + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.J, + Symbol.FEATURES.getSymbolValue())); + Load.loadSystemFile("boot.lisp", false, false, false); + Class.forName("org.armedbear.j.LispAPI"); + Load.loadSystemFile("j.lisp"); + } + catch (ConditionThrowable c) { + reportError(c, LispThread.currentThread()); + } + catch (Throwable t) { + t.printStackTrace(); + } + initialized = true; + } + } + + private static boolean topLevelInitialized; + + private static synchronized void initializeTopLevel() + { + if (!topLevelInitialized) { + try { + // Resolve top-level-loop autoload. + Symbol TOP_LEVEL_LOOP = intern("TOP-LEVEL-LOOP", PACKAGE_TPL); + LispObject tplFun = TOP_LEVEL_LOOP.getSymbolFunction(); + if (tplFun instanceof Autoload) { + Autoload autoload = (Autoload) tplFun; + autoload.load(); + } + } + catch (Throwable t) { + t.printStackTrace(); + } + topLevelInitialized = true; + } + } + + private static synchronized void processInitializationFile() + { + try { + String userHome = System.getProperty("user.home"); + File file = new File(userHome, ".abclrc"); + if (file.isFile()) { + Load.load(file.getCanonicalPath()); + return; + } + if (Utilities.isPlatformWindows) { + file = new File("C:\\.abclrc"); + if (file.isFile()) { + Load.load(file.getCanonicalPath()); + return; + } + } + file = new File(userHome, ".ablrc"); + if (file.isFile()) { + String message = + "Warning: use of .ablrc is deprecated; use .abclrc instead."; + getStandardOutput()._writeLine(message); + Load.load(file.getCanonicalPath()); + return; + } + file = new File(userHome, ".ablisprc"); + if (file.isFile()) { + String message = + "Warning: use of .ablisprc is deprecated; use .abclrc instead."; + getStandardOutput()._writeLine(message); + Load.load(file.getCanonicalPath()); + return; + } + } + catch (Throwable t) { + t.printStackTrace(); + } + } + + // Check for --noinit; verify that arguments are supplied for --load and + // --eval options. + private static void preprocessCommandLineArguments(String[] args) + throws ConditionThrowable + { + if (args != null) { + for (int i = 0; i < args.length; ++i) { + String arg = args[i]; + if (arg.equals("--noinit")) { + noinit = true; + } else if (arg.equals("--noinform")) { + noinform = true; + } else if (arg.equals("--batch")) { + _BATCH_MODE_.setSymbolValue(T); + } else if (arg.equals("--eval")) { + if (i + 1 < args.length) { + ++i; + } else { + System.err.println("No argument supplied to --eval"); + System.exit(1); + } + } else if (arg.equals("--load") || + arg.equals("--load-system-file")) { + if (i + 1 < args.length) { + ++i; + } else { + System.err.println("No argument supplied to --load"); + System.exit(1); + } + } + } + } + } + + // Do the --load and --eval actions. + private static void postprocessCommandLineArguments(String[] args) + throws ConditionThrowable + { + if (args != null) { + for (int i = 0; i < args.length; ++i) { + String arg = args[i]; + if (arg.equals("--eval")) { + if (i + 1 < args.length) { + try { + evaluate(args[i + 1]); + } + catch (ConditionThrowable c) { + final String separator = + System.getProperty("line.separator"); + FastStringBuffer sb = new FastStringBuffer(); + sb.append(separator); + sb.append("Caught "); + sb.append(c.getCondition().typeOf().writeToString()); + sb.append(" while processing --eval option \"" + + args[i + 1] + "\":"); + sb.append(separator); + sb.append(" "); + final LispThread thread = LispThread.currentThread(); + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + sb.append(c.getCondition().writeToString()); + sb.append(separator); + System.err.print(sb.toString()); + System.exit(2); + } + ++i; + } else { + // Shouldn't happen. + System.err.println("No argument supplied to --eval"); + System.exit(1); + } + } else if (arg.equals("--load") || + arg.equals("--load-system-file")) { + if (i + 1 < args.length) { + try { + if (arg.equals("--load")) + Load.load(new Pathname(args[i + 1]), + args[i + 1], + false, false, true); + else + Load.loadSystemFile(args[i + 1]); + } + catch (ConditionThrowable c) { + System.err.println("Caught condition: " + + c.getCondition().writeToString() + + " while loading: " + + args[i+1]); + System.exit(2); + } + ++i; + } else { + // Shouldn't happen. + System.err.println("No argument supplied to --load"); + System.exit(1); + } + } + } + } + } + + public void run() + { + final LispThread thread = LispThread.currentThread(); + try { + Symbol TOP_LEVEL_LOOP = intern("TOP-LEVEL-LOOP", PACKAGE_TPL); + LispObject tplFun = TOP_LEVEL_LOOP.getSymbolFunction(); + if (tplFun instanceof Function) { + thread.execute(tplFun); + return; + } + // We only arrive here if something went wrong and we weren't able + // to load top-level.lisp and run the normal top-level loop. + Stream out = getStandardOutput(); + while (true) { + try { + thread.resetStack(); + thread.lastSpecialBinding = null; + out._writeString("* "); + out._finishOutput(); + LispObject object = + getStandardInput().read(false, EOF, false, thread); + if (object == EOF) + break; + out.setCharPos(0); + Symbol.MINUS.setSymbolValue(object); + LispObject result = eval(object, new Environment(), thread); + Debug.assertTrue(result != null); + Symbol.STAR_STAR_STAR.setSymbolValue(Symbol.STAR_STAR.getSymbolValue()); + Symbol.STAR_STAR.setSymbolValue(Symbol.STAR.getSymbolValue()); + Symbol.STAR.setSymbolValue(result); + Symbol.PLUS_PLUS_PLUS.setSymbolValue(Symbol.PLUS_PLUS.getSymbolValue()); + Symbol.PLUS_PLUS.setSymbolValue(Symbol.PLUS.getSymbolValue()); + Symbol.PLUS.setSymbolValue(Symbol.MINUS.getSymbolValue()); + out = getStandardOutput(); + out.freshLine(); + LispObject[] values = thread.getValues(); + Symbol.SLASH_SLASH_SLASH.setSymbolValue(Symbol.SLASH_SLASH.getSymbolValue()); + Symbol.SLASH_SLASH.setSymbolValue(Symbol.SLASH.getSymbolValue()); + if (values != null) { + LispObject slash = NIL; + for (int i = values.length; i-- > 0;) + slash = new Cons(values[i], slash); + Symbol.SLASH.setSymbolValue(slash); + for (int i = 0; i < values.length; i++) + out._writeLine(values[i].writeToString()); + } else { + Symbol.SLASH.setSymbolValue(new Cons(result)); + out._writeLine(result.writeToString()); + } + out._finishOutput(); + } + catch (StackOverflowError e) { + getStandardInput().clearInput(); + out._writeLine("Stack overflow"); + } + catch (ConditionThrowable c) { + reportError(c, thread); + } + catch (Throwable t) { + getStandardInput().clearInput(); + out.printStackTrace(t); + thread.backtrace(); + } + } + } + catch (Throwable t) { + t.printStackTrace(); + } + } + + private static void reportError(ConditionThrowable c, LispThread thread) + { + try { + getStandardInput().clearInput(); + Stream out = getStandardOutput(); + out.freshLine(); + Condition condition = (Condition) c.getCondition(); + out._writeLine("Error: unhandled condition: " + + condition.writeToString()); + if (thread != null) + thread.backtrace(); + } + catch (Throwable t) { + + } + } + + public void kill() + { + kill(0); + } + + public void kill(int status) + { + if (jlisp) { + try { + inputStream.close(); + } + catch (IOException e) { + Debug.trace(e); + } + try { + outputStream.close(); + } + catch (IOException e) { + Debug.trace(e); + } + } else + System.exit(status); + } + + public synchronized void dispose() + { + Debug.trace("Interpreter.dispose"); + Debug.assertTrue(interpreter == this); + interpreter = null; + } + + @Override + protected void finalize() throws Throwable + { + System.err.println("Interpreter.finalize"); + } + + private static final Primitive _DEBUGGER_HOOK_FUNCTION = + new Primitive("%debugger-hook-function", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Condition condition = (Condition) first; + if (interpreter == null) { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + try { + final LispObject truename = + Symbol.LOAD_TRUENAME.symbolValue(thread); + if (truename != NIL) { + final LispObject stream = + _LOAD_STREAM_.symbolValue(thread); + if (stream instanceof Stream) { + final int lineNumber = + ((Stream)stream).getLineNumber() + 1; + final int offset = + ((Stream)stream).getOffset(); + Debug.trace("Error loading " + + truename.writeToString() + + " at line " + lineNumber + + " (offset " + offset + ")"); + } + } + Debug.trace("Encountered unhandled condition of type " + + condition.typeOf().writeToString() + ':'); + Debug.trace(" " + condition.writeToString()); + } + catch (Throwable t) {} + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + throw new ConditionThrowable(condition); + } + }; + + public static final LispObject readFromString(String s) + { + try { + return new StringInputStream(s).read(true, NIL, false, + LispThread.currentThread()); + } + catch (Throwable t) { + return null; + } + } + + // For j. + public static LispObject evaluate(String s) throws ConditionThrowable + { + if (!initialized) + initializeJLisp(); + StringInputStream stream = new StringInputStream(s); + final LispThread thread = LispThread.currentThread(); + LispObject obj = stream.read(false, EOF, false, thread); + if (obj == EOF) + return error(new EndOfFile(stream)); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.DEBUGGER_HOOK, _DEBUGGER_HOOK_FUNCTION); + try { + return eval(obj, new Environment(), thread); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + private static final String build; + + static { + String s = null; + InputStream in = Interpreter.class.getResourceAsStream("build"); + if (in != null) { + try { + BufferedReader reader = + new BufferedReader(new InputStreamReader(in)); + s = reader.readLine(); + reader.close(); + } + catch (IOException e) {} + } + build = s; + } + + private static String banner() + { + final String sep = System.getProperty("line.separator"); + FastStringBuffer sb = new FastStringBuffer("Armed Bear Common Lisp "); + sb.append(Version.getVersion()); + if (build != null) { + sb.append(" (built "); + sb.append(build); + sb.append(')'); + } + sb.append(sep); + sb.append("Java "); + sb.append(System.getProperty("java.version")); + sb.append(' '); + sb.append(System.getProperty("java.vendor")); + sb.append(sep); + String vm = System.getProperty("java.vm.name"); + if (vm != null) { + sb.append(vm); + sb.append(sep); + } + return sb.toString(); + } +} Added: branches/save-image/src/org/armedbear/lisp/JHandler.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/JHandler.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,164 @@ +/* + * JHandler.java + * + * Copyright (C) 2003-2005 Andras Simon, Peter Graves + * $Id: JHandler.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.HashMap; +import java.util.Map; +import java.util.WeakHashMap; + +public final class JHandler extends Lisp +{ + private static final Map> table = + new WeakHashMap>(); + + public static void callLisp (String s, Object o) + { + callLisp(s, o, ""); + } + + public static void callLisp (String s, Object o, String s1) + { + callLisp(s, o, s1, new int[] {}); + } + + public static void callLisp (String s, Object o, String s1, int ai[]) { + callLisp(s, o, new String[] { s1 }, ai); + } + + public static void callLisp (String s, Object o, String as[]) + { + callLisp(s, o, as, new int[] {}); + } + + public static void callLisp (String s, Object o, String as[], int ai[]) + { + if (table.containsKey(o)) { + Map entryTable = (Map)table.get(o); + if (entryTable.containsKey(s)) { + Function f = ((Entry)entryTable.get(s)).getHandler(); + LispObject data = ((Entry)entryTable.get(s)).getData(); + Fixnum count = ((Entry)entryTable.get(s)).getCount(); + Fixnum[] lispAi = new Fixnum[ai.length]; + for (int i = 0; i < ai.length; i++) { + lispAi[i] = new Fixnum(ai[i]); + } + LispObject lispAiVector = new SimpleVector(lispAi); + SimpleString[] lispAs = new SimpleString[as.length]; + for (int i = 0; i < as.length; i++) { + lispAs[i] = new SimpleString(as[i]); + } + LispObject lispAsVector = new SimpleVector(lispAs); + LispObject[] args = new LispObject[] //FIXME: count -> seq_num + { data, new JavaObject(o), lispAiVector, lispAsVector, Keyword.internKeyword(s), count }; + try { + f.execute(args); + } + catch (ConditionThrowable t) { + t.printStackTrace(); + } + } + } + } + + // jregister-handler1 object event handler data count + private static final Primitive _JREGISTER_HANDLER = + new Primitive("%jregister-handler", PACKAGE_JAVA) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 5) + return error(new WrongNumberOfArgumentsException(this)); + Map entryTable = null; + Object object = args[0].javaInstance(); + String event = ((Symbol)args[1]).getName(); + if (!table.containsKey(object)) { + entryTable = new HashMap(); + table.put(object,entryTable); + } else { + entryTable = (Map)table.get(object); + } + Entry entry = new Entry((Function) args[2], args[3], event, entryTable); + if (args[4] != NIL) + entry.addCount(((Fixnum)args[4]).value); + entryTable.put(event,entry); + return T; + } + }; + + private static class Entry + { + Function handler; + LispObject data; + int count = -1; + Map entryTable; + String event; + + public Entry (Function handler, LispObject data, String event, + Map entryTable) + { + this.entryTable = entryTable; + this.event = event; + this.handler = handler; + this.data = data; + } + + public Function getHandler () + { + return handler; + } + + public void addData (LispObject data) + { + this.data = data; + } + + public LispObject getData () + { + return data; + } + + public void addCount (int count) + { + this.count = count; + } + + public Fixnum getCount () + { + if (count == 0) + entryTable.remove(event); + return (new Fixnum (count--)); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/JProxy.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/JProxy.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,247 @@ +/* + * JProxy.java + * + * Copyright (C) 2002-2005 Peter Graves, Andras Simon + * $Id: JProxy.java 11590 2009-01-25 23:34:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.lang.reflect.InvocationHandler; +import java.lang.reflect.Method; +import java.lang.reflect.Proxy; +import java.util.HashMap; +import java.util.Map; +import java.util.WeakHashMap; + +public final class JProxy extends Lisp +{ + private static final Map table = new WeakHashMap(); + + // ### %jnew-proxy interface &rest method-names-and-defs + private static final Primitive _JNEW_PROXY = + new Primitive("%jnew-proxy", PACKAGE_JAVA, false, + "interface &rest method-names-and-defs") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length < 3 || length % 2 != 1) + return error(new WrongNumberOfArgumentsException(this)); + Map lispDefinedMethods = new HashMap(); + for (int i = 1; i < length; i += 2) + lispDefinedMethods.put(args[i].getStringValue(), + (Function) args[i + 1]); + Class iface = (Class) args[0].javaInstance(); + Object proxy = Proxy.newProxyInstance(iface.getClassLoader(), + new Class[] { iface }, + new LispHandler(table)); + table.put(proxy, new Entry(iface, lispDefinedMethods)); + return new JavaObject(proxy); + } + }; + + private static class LispHandler implements InvocationHandler + { + Map table; + + LispHandler (Map table) + { + this.table = table; + } + + public Object invoke(Object proxy, Method method, Object[] args) + { + String methodName = method.getName(); + + if (methodName.equals("hashCode")) + return new Integer(System.identityHashCode(proxy)); + if (methodName.equals("equals")) + return (proxy == args[0] ? Boolean.TRUE : Boolean.FALSE); + if (methodName.equals("toString")) + return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode()); + + if (table.containsKey(proxy)) + { + Entry entry = (Entry) table.get(proxy); + Function f = entry.getLispMethod(methodName); + if (f != null) + { + try + { + LispObject lispArgs = NIL; + if (args != null) + { + for (int i = args.length - 1 ; 0 <= i ; i--) + lispArgs = lispArgs.push(new JavaObject(args[i])); + } + LispObject result = evalCall(f, lispArgs, new Environment(), + LispThread.currentThread()); + return (method.getReturnType() == void.class ? null : result.javaInstance()); + } + catch (ConditionThrowable t) + { + t.printStackTrace(); + } + } + } + return null; + } + } + + private static class Entry + { + Class iface; + Map lispDefinedMethods; + + public Entry (Class iface, Map lispDefinedMethods) + { + this.iface = iface; + this.lispDefinedMethods = lispDefinedMethods; + } + + public Function getLispMethod(String methodName) + { + if (lispDefinedMethods.containsKey(methodName)) + return (Function)lispDefinedMethods.get(methodName); + return null; + } + } + + //NEW IMPLEMENTATION by Alessio Stalla + + /** + * A weak map associating each proxy instance with a "Lisp-this" object. + */ + private static final Map proxyMap = new WeakHashMap(); + + public static class LispInvocationHandler implements InvocationHandler { + + private Function function; + private static Method hashCodeMethod; + private static Method equalsMethod; + private static Method toStringMethod; + + static { + try { + hashCodeMethod = Object.class.getMethod("hashCode", new Class[] {}); + equalsMethod = Object.class.getMethod("equals", new Class[] { Object.class }); + toStringMethod = Object.class.getMethod("toString", new Class[] {}); + } catch (Exception e) { + throw new Error("Something got horribly wrong - can't get a method from Object.class", e); + } + } + + public LispInvocationHandler(Function function) { + this.function = function; + } + + public Object invoke(Object proxy, Method method, Object[] args) throws Throwable { + if(hashCodeMethod.equals(method)) { + return System.identityHashCode(proxy); + } + if(equalsMethod.equals(method)) { + return proxy == args[0]; + } + if(toStringMethod.equals(method)) { + return proxy.getClass().getName() + '@' + Integer.toHexString(proxy.hashCode()); + } + + if(args == null) { + args = new Object[0]; + } + LispObject[] lispArgs = new LispObject[args.length + 2]; + synchronized(proxyMap) { + lispArgs[0] = toLispObject(proxyMap.get(proxy)); + } + lispArgs[1] = new SimpleString(method.getName()); + for(int i = 0; i < args.length; i++) { + lispArgs[i + 2] = toLispObject(args[i]); + } + Object retVal = (function.execute(lispArgs)).javaInstance(); + /* DOES NOT WORK due to autoboxing! + if(retVal != null && !method.getReturnType().isAssignableFrom(retVal.getClass())) { + return error(new TypeError(new JavaObject(retVal), new JavaObject(method.getReturnType()))); + }*/ + return retVal; + } + } + + private static final Primitive _JMAKE_INVOCATION_HANDLER = + new Primitive("%jmake-invocation-handler", PACKAGE_JAVA, false, + "function") { + + public LispObject execute(LispObject[] args) throws ConditionThrowable { + int length = args.length; + if (length != 1) { + return error(new WrongNumberOfArgumentsException(this)); + } + if(!(args[0] instanceof Function)) { + return error(new TypeError(args[0], Symbol.FUNCTION)); + } + return new JavaObject(new LispInvocationHandler((Function) args[0])); + } + }; + + private static final Primitive _JMAKE_PROXY = + new Primitive("%jmake-proxy", PACKAGE_JAVA, false, + "interface invocation-handler") { + + public LispObject execute(final LispObject[] args) throws ConditionThrowable { + int length = args.length; + if (length != 3) { + return error(new WrongNumberOfArgumentsException(this)); + } + if(!(args[0] instanceof JavaObject) || + !(((JavaObject) args[0]).javaInstance() instanceof Class)) { + return error(new TypeError(args[0], new SimpleString(Class.class.getName()))); + } + if(!(args[1] instanceof JavaObject) || + !(((JavaObject) args[1]).javaInstance() instanceof InvocationHandler)) { + return error(new TypeError(args[1], new SimpleString(InvocationHandler.class.getName()))); + } + Class iface = (Class) ((JavaObject) args[0]).javaInstance(); + InvocationHandler invocationHandler = (InvocationHandler) ((JavaObject) args[1]).javaInstance(); + Object proxy = Proxy.newProxyInstance( + iface.getClassLoader(), + new Class[] { iface }, + invocationHandler); + synchronized(proxyMap) { + proxyMap.put(proxy, args[2]); + } + return new JavaObject(proxy); + } + }; + + private static LispObject toLispObject(Object obj) { + return (obj instanceof LispObject) ? (LispObject) obj : new JavaObject(obj); + } + +} Added: branches/save-image/src/org/armedbear/lisp/Java.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Java.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,880 @@ +/* + * Java.java + * + * Copyright (C) 2002-2006 Peter Graves, Andras Simon + * $Id: Java.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.beans.BeanInfo; +import java.beans.IntrospectionException; +import java.beans.Introspector; +import java.beans.PropertyDescriptor; +import java.lang.reflect.Array; +import java.lang.reflect.Constructor; +import java.lang.reflect.Field; +import java.lang.reflect.InvocationTargetException; +import java.lang.reflect.Method; +import java.lang.reflect.Modifier; +import java.util.HashMap; +import java.util.Map; + +public final class Java extends Lisp +{ + private static final Map registeredExceptions = + new HashMap(); + + private static final LispClass java_exception = LispClass.findClass(Symbol.JAVA_EXCEPTION); + + private static boolean isJavaException(LispClass lc) throws ConditionThrowable + { + return lc.subclassp(java_exception); + } + + // ### register-java-exception exception-name condition-symbol => T + private static final Primitive REGISTER_JAVA_EXCEPTION = + new Primitive("register-java-exception", PACKAGE_JAVA, true, + "exception-name condition-symbol") + { + @Override + public LispObject execute(LispObject className, LispObject symbol) + throws ConditionThrowable + { + // FIXME Verify that CONDITION-SYMBOL is a symbol that names a condition. + // FIXME Signal a continuable error if the exception is already registered. + if ((symbol instanceof Symbol) && isJavaException(LispClass.findClass((Symbol) symbol))) { + registeredExceptions.put(classForName(className.getStringValue()), + (Symbol)symbol); + return T; + } + return NIL; + } + }; + + // ### unregister-java-exception exception-name => T or NIL + private static final Primitive UNREGISTER_JAVA_EXCEPTION = + new Primitive("unregister-java-exception", PACKAGE_JAVA, true, + "exception-name") + { + @Override + public LispObject execute(LispObject className) + throws ConditionThrowable + { + // FIXME Verify that EXCEPTION-NAME designates a subclass of Throwable. + return registeredExceptions.remove(classForName(className.getStringValue())) == null ? NIL : T; + } + }; + + private static Symbol getCondition(Class cl) throws ConditionThrowable + { + Class o = classForName("java.lang.Object"); + for (Class c = cl ; c != o ; c = c.getSuperclass()) { + Object object = registeredExceptions.get(c); + if (object != null && isJavaException(LispClass.findClass((Symbol) object))) { + return (Symbol) object; + } + } + return null; + } + + // ### jclass name-or-class-ref => class-ref + private static final Primitive JCLASS = + new Primitive(Symbol.JCLASS, "name-or-class-ref", +"Returns a reference to the Java class designated by NAME-OR-CLASS-REF.") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return JavaObject.getInstance(javaClass(arg)); + } + }; + + // ### jfield - retrieve or modify a field in a Java class or instance. + // + // Supported argument patterns: + // + // Case 1: class-ref field-name: + // to retrieve the value of a static field. + // + // Case 2: class-ref field-name instance-ref: + // to retrieve the value of a class field of the instance. + // + // Case 3: class-ref field-name primitive-value: + // to store primitive-value in a static field. + // + // Case 4: class-ref field-name instance-ref value: + // to store value in a class field of the instance. + // + // Case 5: class-ref field-name nil value: + // to store value in a static field (when value may be + // confused with an instance-ref). + // + // Case 6: field-name instance: + // to retrieve the value of a field of the instance. The + // class is derived from the instance. + // + // Case 7: field-name instance value: + // to store value in a field of the instance. The class is + // derived from the instance. + // + + private static final LispObject jfield(Primitive fun, LispObject[] args, boolean translate) + throws ConditionThrowable + { + if (args.length < 2 || args.length > 4) + error(new WrongNumberOfArgumentsException(fun)); + String fieldName = null; + Class c; + Field f; + Class fieldType; + Object instance = null; + try { + if (args[1] instanceof AbstractString) { + // Cases 1-5. + fieldName = args[1].getStringValue(); + c = javaClass(args[0]); + } else { + // Cases 6 and 7. + fieldName = args[0].getStringValue(); + instance = JavaObject.getObject(args[1]); + c = instance.getClass(); + } + f = c.getField(fieldName); + fieldType = f.getType(); + switch (args.length) { + case 2: + // Cases 1 and 6. + break; + case 3: + // Cases 2,3, and 7. + if (instance == null) { + // Cases 2 and 3. + if (args[2] instanceof JavaObject) { + // Case 2. + instance = JavaObject.getObject(args[2]); + break; + } else { + // Case 3. + f.set(null,args[2].javaInstance(fieldType)); + return args[2]; + } + } else { + // Case 7. + f.set(instance,args[2].javaInstance(fieldType)); + return args[2]; + } + case 4: + // Cases 4 and 5. + if (args[2] != NIL) { + // Case 4. + instance = JavaObject.getObject(args[2]); + } + f.set(instance,args[3].javaInstance(fieldType)); + return args[3]; + } + return JavaObject.getInstance(f.get(instance), translate); + } + catch (NoSuchFieldException e) { + error(new LispError("no such field")); + } + catch (SecurityException e) { + error(new LispError("inaccessible field")); + } + catch (IllegalAccessException e) { + error(new LispError("illegal access")); + } + catch (IllegalArgumentException e) { + error(new LispError("illegal argument")); + } + catch (Throwable t) { + error(new LispError(getMessage(t))); + } + // Not reached. + return NIL; + } + + private static final Primitive JFIELD = + new Primitive("jfield", PACKAGE_JAVA, true, + "class-ref-or-field field-or-instance &optional instance value") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return jfield(this, args, true); + } + }; + + // ### jfield-raw - retrieve or modify a field in a Java class or instance. + private static final Primitive JFIELD_RAW = + new Primitive("jfield-raw", PACKAGE_JAVA, true, + "class-ref-or-field field-or-instance &optional instance value") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return jfield(this, args, false); + } + }; + + // ### jconstructor class-ref &rest parameter-class-refs + private static final Primitive JCONSTRUCTOR = + new Primitive("jconstructor", PACKAGE_JAVA, true, + "class-ref &rest parameter-class-refs") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1) + error(new WrongNumberOfArgumentsException(this)); + try { + final Class c = javaClass(args[0]); + int argCount = 0; + if (args.length == 2 && args[1] instanceof Fixnum) { + argCount = Fixnum.getValue(args[1]); + } else { + Class[] parameterTypes = new Class[args.length-1]; + for (int i = 1; i < args.length; i++) { + parameterTypes[i-1] = javaClass(args[i]); + } + return JavaObject.getInstance(c.getConstructor(parameterTypes)); + } + // Parameter types not explicitly specified. + Constructor[] constructors = c.getConstructors(); + for (int i = 0; i < constructors.length; i++) { + Constructor constructor = constructors[i]; + if (constructor.getParameterTypes().length == argCount) + return JavaObject.getInstance(constructor); + } + throw new NoSuchMethodException(); + } + catch (NoSuchMethodException e) { + error(new LispError("no such constructor")); + } + catch (ConditionThrowable e) { + throw e; + } + catch (Throwable t) { + error(new LispError(getMessage(t))); + } + // Not reached. + return NIL; + } + }; + + // ### jmethod class-ref name &rest parameter-class-refs + private static final Primitive JMETHOD = + new Primitive("jmethod", PACKAGE_JAVA, true, + "class-ref name &rest parameter-class-refs") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2) + error(new WrongNumberOfArgumentsException(this)); + final Class c = javaClass(args[0]); + String methodName = args[1].getStringValue(); + try { + int argCount = 0; + if (args.length == 3 && args[2] instanceof Fixnum) { + argCount = ((Fixnum)args[2]).value; + } else { + Class[] parameterTypes = new Class[args.length-2]; + for (int i = 2; i < args.length; i++) + parameterTypes[i-2] = javaClass(args[i]); + return JavaObject.getInstance(c.getMethod(methodName, + parameterTypes)); + } + // Parameter types were not explicitly specified. + Method[] methods = c.getMethods(); + for (int i = 0; i < methods.length; i++) { + Method method = methods[i]; + if (method.getName().equals(methodName) && + method.getParameterTypes().length == argCount) + return JavaObject.getInstance(method); + } + throw new NoSuchMethodException(); + } + catch (NoSuchMethodException e) { + FastStringBuffer sb = new FastStringBuffer("No such method: "); + sb.append(c.getName()); + sb.append('.'); + sb.append(methodName); + sb.append('('); + for (int i = 2; i < args.length; i++) { + sb.append(args[i].writeToString()); + if (i < args.length - 1) + sb.append(','); + } + sb.append(')'); + error(new LispError(sb.toString())); + } + catch (ConditionThrowable e) { + throw e; + } + catch (Throwable t) { + error(new LispError(getMessage(t))); + } + // Not reached. + return NIL; + } + }; + + private static final LispObject jstatic(Primitive fun, LispObject[] args, boolean translate) + throws ConditionThrowable + { + if (args.length < 2) + error(new WrongNumberOfArgumentsException(fun)); + try { + Method m = null; + LispObject methodRef = args[0]; + if (methodRef instanceof JavaObject) { + Object obj = ((JavaObject)methodRef).getObject(); + if (obj instanceof Method) + m = (Method) obj; + } else if (methodRef instanceof AbstractString) { + Class c = javaClass(args[1]); + if (c != null) { + String methodName = methodRef.getStringValue(); + Method[] methods = c.getMethods(); + int argCount = args.length - 2; + for (int i = 0; i < methods.length; i++) { + Method method = methods[i]; + if (!Modifier.isStatic(method.getModifiers()) + || method.getParameterTypes().length != argCount) + continue; + if (method.getName().equals(methodName)) { + m = method; + break; + } + } + if (m == null) + error(new LispError("no such method")); + } + } else + error(new TypeError("wrong type: " + methodRef)); + Object[] methodArgs = new Object[args.length-2]; + Class[] argTypes = m.getParameterTypes(); + for (int i = 2; i < args.length; i++) { + LispObject arg = args[i]; + if (arg == NIL) + methodArgs[i-2] = null; + else + methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); + } + Object result = m.invoke(null, methodArgs); + return JavaObject.getInstance(result, translate); + } + catch (Throwable t) { + if (t instanceof InvocationTargetException) + t = t.getCause(); + Symbol condition = getCondition(t.getClass()); + if (condition == null) + error(new JavaException(t)); + else + Symbol.SIGNAL.execute( + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t))); + } + // Not reached. + return NIL; + } + + // ### jstatic method class &rest args + private static final Primitive JSTATIC = + new Primitive("jstatic", PACKAGE_JAVA, true, "method class &rest args") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return jstatic(this, args, true); + } + }; + + // ### jstatic-raw method class &rest args + private static final Primitive JSTATIC_RAW = + new Primitive("jstatic-raw", PACKAGE_JAVA, true, + "method class &rest args") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return jstatic(this, args, false); + } + }; + + // ### jnew constructor &rest args + private static final Primitive JNEW = + new Primitive("jnew", PACKAGE_JAVA, true, "constructor &rest args") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1) + error(new WrongNumberOfArgumentsException(this)); + LispObject classRef = args[0]; + try { + Constructor constructor = (Constructor) JavaObject.getObject(classRef); + Class[] argTypes = constructor.getParameterTypes(); + Object[] initargs = new Object[args.length-1]; + for (int i = 1; i < args.length; i++) { + LispObject arg = args[i]; + if (arg == NIL) + initargs[i-1] = null; + else { + initargs[i-1] = arg.javaInstance(argTypes[i-1]); + } + } + return JavaObject.getInstance(constructor.newInstance(initargs)); + } + catch (Throwable t) { + if (t instanceof InvocationTargetException) + t = t.getCause(); + Symbol condition = getCondition(t.getClass()); + if (condition == null) + error(new JavaException(t)); + else + Symbol.SIGNAL.execute( + condition, + Keyword.CAUSE, + JavaObject.getInstance(t), + Keyword.FORMAT_CONTROL, + new SimpleString(getMessage(t))); + } + // Not reached. + return NIL; + } + }; + + // ### jnew-array element-type &rest dimensions + private static final Primitive JNEW_ARRAY = + new Primitive("jnew-array", PACKAGE_JAVA, true, + "element-type &rest dimensions") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2) + error(new WrongNumberOfArgumentsException(this)); + try { + Class c = javaClass(args[0]); + int[] dimensions = new int[args.length - 1]; + for (int i = 1; i < args.length; i++) + dimensions[i-1] = ((Integer)args[i].javaInstance()).intValue(); + return JavaObject.getInstance(Array.newInstance(c, dimensions)); + } + catch (Throwable t) { + error(new JavaException(t)); + } + // Not reached. + return NIL; + } + }; + + private static final LispObject jarray_ref(Primitive fun, LispObject[] args, boolean translate) + throws ConditionThrowable + { + if (args.length < 2) + error(new WrongNumberOfArgumentsException(fun)); + try { + Object a = args[0].javaInstance(); + for (int i = 1; i 0;) { + Method method = methods[i]; + if (method.getName().equals(methodName)) + if (method.getParameterTypes().length == argCount) + return method; + } + return null; + } + + // ### make-immediate-object object &optional type + private static final Primitive MAKE_IMMEDIATE_OBJECT = + new Primitive("make-immediate-object", PACKAGE_JAVA, true, + "object &optional type") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1) + error(new WrongNumberOfArgumentsException(this)); + LispObject object = args[0]; + try { + if (args.length > 1) { + LispObject type = args[1]; + if (type == Keyword.BOOLEAN) { + if (object == NIL) + return JavaObject.getInstance(Boolean.FALSE); + else + return JavaObject.getInstance(Boolean.TRUE); + } + if (type == Keyword.REF) { + if (object == NIL) + return JavaObject.getInstance(null); + else + throw new Error(); + } + // other special cases come here + } + return JavaObject.getInstance(object.javaInstance()); + } + catch (Throwable t) { + error(new LispError("MAKE-IMMEDIATE-OBJECT: not implemented")); + } + // Not reached. + return NIL; + } + }; + + // ### java-object-p + private static final Primitive JAVA_OBJECT_P = + new Primitive("java-object-p", PACKAGE_JAVA, true, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return (arg instanceof JavaObject) ? T : NIL; + } + }; + + // ### jobject-lisp-value java-object + private static final Primitive JOBJECT_LISP_VALUE = + new Primitive("jobject-lisp-value", PACKAGE_JAVA, true, "java-object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return JavaObject.getInstance(arg.javaInstance(), true); + } + }; + + private static final Primitive JGET_PROPERTY_VALUE = + new Primitive("%jget-property-value", PACKAGE_JAVA, true, + "java-object property-name") { + + @Override + public LispObject execute(LispObject javaObject, LispObject propertyName) throws ConditionThrowable { + try { + Object obj = javaObject.javaInstance(); + PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName); + Object value = pd.getReadMethod().invoke(obj); + if(value instanceof LispObject) { + return (LispObject) value; + } else if(value != null) { + return JavaObject.getInstance(value); + } else { + return NIL; + } + } catch (Exception e) { + ConditionThrowable t = new ConditionThrowable("Exception reading property"); + t.initCause(e); + throw t; + } + } + }; + + private static final Primitive JSET_PROPERTY_VALUE = + new Primitive("%jset-property-value", PACKAGE_JAVA, true, + "java-object property-name value") { + + @Override + public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable { + Object obj = null; + try { + obj = javaObject.javaInstance(); + PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName); + Object jValue; + if(value == NIL) { + if(Boolean.TYPE.equals(pd.getPropertyType()) || + Boolean.class.equals(pd.getPropertyType())) { + jValue = false; + } else { + jValue = null; + } + } else { + jValue = value.javaInstance(); + } + pd.getWriteMethod().invoke(obj, jValue); + return value; + } catch (Exception e) { + ConditionThrowable t = new ConditionThrowable("Exception writing property " + propertyName.writeToString() + " in object " + obj + " to " + value.writeToString()); + t.initCause(e); + throw t; + } + } + }; + + private static PropertyDescriptor getPropertyDescriptor(Object obj, LispObject propertyName) throws ConditionThrowable, IntrospectionException { + String prop = ((AbstractString) propertyName).getStringValue(); + BeanInfo beanInfo = Introspector.getBeanInfo(obj.getClass()); + for(PropertyDescriptor pd : beanInfo.getPropertyDescriptors()) { + if(pd.getName().equals(prop)) { + return pd; + } + } + throw new ConditionThrowable("Property " + prop + " not found in " + obj); + } + + private static Class classForName(String className) throws ConditionThrowable + { + try { + return Class.forName(className); + } + 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; + } + } + } + + // Supports Java primitive types too. + private static Class javaClass(LispObject obj) throws ConditionThrowable + { + if (obj instanceof AbstractString || obj instanceof Symbol) { + String s = javaString(obj); + if (s.equals("boolean")) + return Boolean.TYPE; + if (s.equals("byte")) + return Byte.TYPE; + if (s.equals("char")) + return Character.TYPE; + if (s.equals("short")) + return Short.TYPE; + if (s.equals("int")) + return Integer.TYPE; + if (s.equals("long")) + return Long.TYPE; + if (s.equals("float")) + return Float.TYPE; + if (s.equals("double")) + return Double.TYPE; + // Not a primitive Java type. + return classForName(s); + } + // It's not a string, so it must be a JavaObject. + final JavaObject javaObject; + try { + javaObject = (JavaObject) obj; + } + catch (ClassCastException e) { + type_error(obj, list3(Symbol.OR, Symbol.STRING, + Symbol.JAVA_OBJECT)); + // Not reached. + return null; + } + try { + return (Class) javaObject.getObject(); + } + catch (ClassCastException e) { + error(new LispError(obj.writeToString() + " does not designate a Java class.")); + return null; + } + } + + private static final String getMessage(Throwable t) + { + String message = t.getMessage(); + if (message == null || message.length() == 0) + message = t.getClass().getName(); + return message; + } +} Added: branches/save-image/src/org/armedbear/lisp/JavaClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/JavaClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,147 @@ +/* + * BuiltInClass.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: BuiltInClass.java 11297 2008-08-31 13:26:45Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp; + +import java.util.HashMap; +import java.util.HashSet; +import java.util.LinkedList; +import java.util.Map; +import java.util.Queue; +import java.util.Set; +import java.util.Stack; + +public class JavaClass extends LispClass { + + private Class javaClass; + //There is no point for this Map to be weak since values keep a reference to the corresponding + //key (the Java class). This should not be a problem since Java classes are limited in number - + //if they grew indefinitely, the JVM itself would crash. + private static final Map, JavaClass> cache = new HashMap, JavaClass>(); + + private JavaClass(Class javaClass) { + this.javaClass = javaClass; + setDirectSuperclass(BuiltInClass.JAVA_OBJECT); + } + + private void initCPL() { + LispObject cpl = Lisp.NIL; + try { + cpl = cpl.push(BuiltInClass.CLASS_T); + cpl = cpl.push(BuiltInClass.JAVA_OBJECT); + Set> alreadySeen = new HashSet>(); + Stack stack = new Stack(); + Class theClass = javaClass; + boolean stop = false; + while(!stop && theClass != null) { + stop = addClass(alreadySeen, stack, theClass); + for(Class c : theClass.getInterfaces()) { + stop = addClass(alreadySeen, stack, c) && stop; //watch out for short-circuiting! + } + theClass = theClass.getSuperclass(); + } + while(!stack.isEmpty()) { + cpl = cpl.push(stack.pop()); + } + } catch (ConditionThrowable e) { + throw new Error("Cannot push class in class precedence list", e); + } + setCPL(cpl); + } + + private static boolean addClass(Set> alreadySeen, Stack stack, Class theClass) { + if(!alreadySeen.contains(theClass)) { + alreadySeen.add(theClass); + stack.push(findJavaClass(theClass)); + return false; + } + return true; + } + + public LispObject typeOf() { + return Symbol.JAVA_CLASS; + } + + public LispObject classOf() { + return StandardClass.JAVA_CLASS; + } + + public LispObject typep(LispObject type) throws ConditionThrowable { + if (type == Symbol.JAVA_CLASS) + return T; + if (type == StandardClass.JAVA_CLASS) + return T; + return super.typep(type); + } + + public LispObject getDescription() throws ConditionThrowable { + return new SimpleString(writeToString()); + } + + public String writeToString() throws ConditionThrowable { + FastStringBuffer sb = new FastStringBuffer("#'); + return sb.toString(); + } + + public static JavaClass findJavaClass(Class javaClass) { + synchronized (cache) { + JavaClass c = cache.get(javaClass); + if (c == null) { + c = new JavaClass(javaClass); + cache.put(javaClass, c); + c.initCPL(); + } + return c; + } + } + + public Class getJavaClass() { + return javaClass; + } + + public boolean subclassp(LispObject obj) throws ConditionThrowable { + if(obj == BuiltInClass.CLASS_T) { + return true; + } + if(obj == BuiltInClass.JAVA_OBJECT) { + return true; + } + if(obj instanceof JavaClass) { + return ((JavaClass) obj).getJavaClass().isAssignableFrom(javaClass); + } + return false; + } + + private static final Primitive _FIND_JAVA_CLASS = new Primitive( + "%find-java-class", PACKAGE_JAVA, false, "string") { + public LispObject execute(LispObject arg) throws ConditionThrowable { + try { + return findJavaClass(Class.forName((String) arg.getStringValue())); + } catch (ClassNotFoundException e) { + throw new ConditionThrowable("Cannot find Java class " + arg.getStringValue()); + } + } + + }; + +} Added: branches/save-image/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/JavaClassLoader.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,118 @@ +/* + * JavaClassLoader.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: JavaClassLoader.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.Collections; +import java.util.HashSet; +import java.util.Set; + +public class JavaClassLoader extends ClassLoader +{ + private static final boolean isSableVM; + + static { + String vm = System.getProperty("java.vm.name"); + if (vm != null && vm.equals("SableVM")) + isSableVM = true; + else + isSableVM = false; + } + + private static JavaClassLoader persistentInstance; + + private static Set packages = Collections.synchronizedSet(new HashSet()); + + public JavaClassLoader() + { + super(JavaClassLoader.class.getClassLoader()); + } + + public static JavaClassLoader getPersistentInstance() + { + return getPersistentInstance(null); + } + + public static JavaClassLoader getPersistentInstance(String packageName) + { + if (persistentInstance == null) + persistentInstance = new JavaClassLoader(); + definePackage(packageName); + return persistentInstance; + } + + private static void definePackage(String packageName) + { + if (packageName != null && !packages.contains(packageName)) { + persistentInstance.definePackage(packageName,"","1.0","","","1.0","",null); + packages.add(packageName); + } + } + + public Class loadClassFromByteArray(String className, byte[] classbytes) + { + try { + long length = classbytes.length; + if (length < Integer.MAX_VALUE) { + Class c = defineClass(className, classbytes, 0, (int) length); + if (c != null) { + resolveClass(c); + return c; + } + } + } + catch (LinkageError e) { + throw e; + } + catch (Throwable t) { + Debug.trace(t); + } + return null; + } + + public Class loadClassFromByteArray(String className, byte[] bytes, + int offset, int length) + { + try { + Class c = defineClass(className, bytes, offset, length); + if (c != null) { + resolveClass(c); + return c; + } + } + catch (Throwable t) { + Debug.trace(t); + } + return null; + } +} Added: branches/save-image/src/org/armedbear/lisp/JavaException.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/JavaException.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,99 @@ +/* + * JavaException.java + * + * Copyright (C) 2005 Peter Graves + * $Id: JavaException.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.PrintWriter; +import java.io.StringWriter; + +public class JavaException extends LispError +{ + private final Throwable throwable; + + public JavaException(Throwable throwable) throws ConditionThrowable + { + super(StandardClass.JAVA_EXCEPTION); + Debug.assertTrue(slots.length == 3); + Debug.assertTrue(throwable != null); + this.throwable = throwable; + setInstanceSlotValue(Symbol.CAUSE, new JavaObject(throwable)); + } + + @Override + public LispObject typeOf() + { + return Symbol.JAVA_EXCEPTION; + } + + @Override + public LispObject classOf() + { + return StandardClass.JAVA_EXCEPTION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.JAVA_EXCEPTION) + return T; + if (type == StandardClass.JAVA_EXCEPTION) + return T; + return super.typep(type); + } + + @Override + public String getMessage() + { + StringWriter sw = new StringWriter(); + PrintWriter pw = new PrintWriter(sw); + throwable.printStackTrace(pw); + String s = sw.toString(); + final String separator = System.getProperty("line.separator"); + if (s.endsWith(separator)) + s = s.substring(0, s.length() - separator.length()); + return s; + } + + // ### java-exception-cause java-exception => cause + private static final Primitive JAVA_EXCEPTION_CAUSE = + new Primitive(Symbol.JAVA_EXCEPTION_CAUSE, "java-exception", +"Returns the cause of JAVA-EXCEPTION. (The cause is the Java Throwable\n" + +" object that caused JAVA-EXCEPTION to be signalled.)") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Symbol.STD_SLOT_VALUE.execute(arg, Symbol.CAUSE); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/JavaObject.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,302 @@ +/* + * JavaObject.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: JavaObject.java 11691 2009-03-01 20:11:40Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class JavaObject extends LispObject +{ + private final Object obj; + + public JavaObject(Object obj) + { + this.obj = obj; + } + + @Override + public LispObject typeOf() + { + return Symbol.JAVA_OBJECT; + } + + @Override + public LispObject classOf() + { + if(obj == null) { + return BuiltInClass.JAVA_OBJECT; + } else { + return JavaClass.findJavaClass(obj.getClass()); + } + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.JAVA_OBJECT) + return T; + if (type == BuiltInClass.JAVA_OBJECT) + return T; + if(type instanceof JavaClass && obj != null) { + return ((JavaClass) type).getJavaClass().isAssignableFrom(obj.getClass()) ? T : NIL; + } + return super.typep(type); + } + + public final Object getObject() + { + return obj; + } + + /** Encapsulates obj, if required. + * If obj is a {@link LispObject}, it's returned as-is. + * + * @param obj Any java object + * @return obj or a new JavaObject encapsulating obj + */ + public final static LispObject getInstance(Object obj) { + if (obj == null) + return new JavaObject(null); + + if (obj instanceof LispObject) + return (LispObject)obj; + + return new JavaObject(obj); + } + + /** Encapsulates obj, if required. + * If obj is a {@link LispObject}, it's returned as-is. + * If obj is of a type which can be mapped to a lisp type, + * an object of the mapped type is returned, if translated is true. + * + * @param obj + * @param translated + * @return a LispObject representing or encapsulating obj + */ + public final static LispObject getInstance(Object obj, boolean translated) + throws ConditionThrowable + { + if (! translated) + return getInstance(obj); + + if (obj == null) return NIL; + + if (obj instanceof LispObject) + return (LispObject)obj; + + if (obj instanceof String) + return new SimpleString((String)obj); + + if (obj instanceof Number) { + // Number types ordered according to decreasing + // estimated chances of occurrance + + if (obj instanceof Integer) + return Fixnum.getInstance(((Integer)obj).intValue()); + + if (obj instanceof Float) + return new SingleFloat((Float)obj); + + if (obj instanceof Double) + return new DoubleFloat((Double)obj); + + if (obj instanceof Long) + return LispInteger.getInstance(((Long)obj).longValue()); + + if (obj instanceof BigInteger) + return new Bignum((BigInteger)obj); + + if (obj instanceof Short) + return Fixnum.getInstance(((Short)obj).shortValue()); + + if (obj instanceof Byte) + return Fixnum.getInstance(((Byte)obj).byteValue()); + // We don't handle BigDecimal: it doesn't map to a Lisp type + } + + if (obj instanceof Boolean) + return ((Boolean)obj).booleanValue() ? T : NIL; + + if (obj instanceof Character) + return new LispCharacter((Character)obj); + + if (obj instanceof Object[]) { + Object[] array = (Object[]) obj; + SimpleVector v = new SimpleVector(array.length); + for (int i = array.length; i-- > 0;) + v.aset(i, JavaObject.getInstance(array[i])); + return v; + } + // TODO + // We might want to handle: + // - streams + // - others? + return new JavaObject(obj); + } + + @Override + public Object javaInstance() + { + return obj; + } + + @Override + public Object javaInstance(Class c) + { + return javaInstance(); + } + + public static final Object getObject(LispObject o) + throws ConditionThrowable + { + try { + return ((JavaObject)o).obj; + } + catch (ClassCastException e) { + type_error(o, Symbol.JAVA_OBJECT); + // Not reached. + return null; + } + } + + @Override + public final boolean equal(LispObject other) + { + if (this == other) + return true; + if (other instanceof JavaObject) + return (obj == ((JavaObject)other).obj); + return false; + } + + @Override + public final boolean equalp(LispObject other) + { + return equal(other); + } + + @Override + public int sxhash() + { + return obj == null ? 0 : (obj.hashCode() & 0x7ffffff); + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (obj instanceof ConditionThrowable) + return obj.toString(); + final FastStringBuffer sb = + new FastStringBuffer(Symbol.JAVA_OBJECT.writeToString()); + sb.append(' '); + sb.append(obj == null ? "null" : obj.getClass().getName()); + return unreadableString(sb.toString()); + } + + // ### describe-java-object + private static final Primitive DESCRIBE_JAVA_OBJECT = + new Primitive("describe-java-object", PACKAGE_JAVA, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (!(first instanceof JavaObject)) + return type_error(first, Symbol.JAVA_OBJECT); + final Stream stream; + try { + stream = (Stream) second; + } + catch (ClassCastException e) { + return type_error(second, Symbol.STREAM); + } + final JavaObject javaObject = (JavaObject) first; + final Object obj = javaObject.getObject(); + final FastStringBuffer sb = + new FastStringBuffer(javaObject.writeToString()); + sb.append(" is an object of type "); + sb.append(Symbol.JAVA_OBJECT.writeToString()); + sb.append("."); + sb.append(System.getProperty("line.separator")); + sb.append("The wrapped Java object is "); + if (obj == null) { + sb.append("null."); + } else { + sb.append("an "); + final Class c = obj.getClass(); + String className = c.getName(); + if (c.isArray()) { + sb.append("array of "); + if (className.startsWith("[L") && className.endsWith(";")) { + className = className.substring(1, className.length() - 1); + sb.append(className); + sb.append(" objects"); + } else if (className.startsWith("[") && className.length() > 1) { + char descriptor = className.charAt(1); + final String type; + switch (descriptor) { + case 'B': type = "bytes"; break; + case 'C': type = "chars"; break; + case 'D': type = "doubles"; break; + case 'F': type = "floats"; break; + case 'I': type = "ints"; break; + case 'J': type = "longs"; break; + case 'S': type = "shorts"; break; + case 'Z': type = "booleans"; break; + default: + type = "unknown type"; + } + sb.append(type); + } + sb.append(" with "); + final int length = java.lang.reflect.Array.getLength(obj); + sb.append(length); + sb.append(" element"); + if (length != 1) + sb.append('s'); + sb.append('.'); + } else { + sb.append("instance of "); + sb.append(className); + sb.append(':'); + sb.append(System.getProperty("line.separator")); + sb.append(" \""); + sb.append(obj.toString()); + sb.append('"'); + } + } + stream._writeString(sb.toString()); + return LispThread.currentThread().nothing(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Keyword.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Keyword.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,149 @@ +/* + * Keyword.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Keyword.java 11490 2008-12-27 14:59:26Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Keyword extends Lisp +{ + public static final Symbol + ABCL = internKeyword("ABCL"), + ABORT = internKeyword("ABORT"), + ABSOLUTE = internKeyword("ABSOLUTE"), + ADJUSTABLE = internKeyword("ADJUSTABLE"), + ALLOW_OTHER_KEYS = internKeyword("ALLOW-OTHER-KEYS"), + ANSI_CL = internKeyword("ANSI-CL"), + APPEND = internKeyword("APPEND"), + ARMEDBEAR = internKeyword("ARMEDBEAR"), + BACK = internKeyword("BACK"), + BOOLEAN = internKeyword("BOOLEAN"), + CAPITALIZE = internKeyword("CAPITALIZE"), + CAPITALIZE_FIRST = internKeyword("CAPITALIZE-FIRST"), + CASE = internKeyword("CASE"), + CAUSE = internKeyword("CAUSE"), + CHAR = internKeyword("CHAR"), + COMMON = internKeyword("COMMON"), + COMMON_LISP = internKeyword("COMMON-LISP"), + COMPILE_TOPLEVEL = internKeyword("COMPILE-TOPLEVEL"), + COUNT_ONLY = internKeyword("COUNT-ONLY"), + CREATE = internKeyword("CREATE"), + DARWIN = internKeyword("DARWIN"), + DATUM = internKeyword("DATUM"), + DECLARED = internKeyword("DECLARED"), + DEFAULT = internKeyword("DEFAULT"), + DEFAULTS = internKeyword("DEFAULTS"), + DEVICE = internKeyword("DEVICE"), + DIRECTION = internKeyword("DIRECTION"), + DIRECTORY = internKeyword("DIRECTORY"), + DIRECT_SUPERCLASSES = internKeyword("DIRECT-SUPERCLASSES"), + DOWNCASE = internKeyword("DOWNCASE"), + ELEMENT_TYPE = internKeyword("ELEMENT-TYPE"), + END = internKeyword("END"), + ERROR = internKeyword("ERROR"), + EXECUTE = internKeyword("EXECUTE"), + EXPECTED_TYPE = internKeyword("EXPECTED-TYPE"), + EXTERNAL = internKeyword("EXTERNAL"), + EXTERNAL_FORMAT = internKeyword("EXTERNAL-FORMAT"), + FILL_POINTER = internKeyword("FILL-POINTER"), + FORMAT_ARGUMENTS = internKeyword("FORMAT-ARGUMENTS"), + FORMAT_CONTROL = internKeyword("FORMAT-CONTROL"), + FROM_END = internKeyword("FROM-END"), + FREEBSD = internKeyword("FREEBSD"), + HOST = internKeyword("HOST"), + IF_DOES_NOT_EXIST = internKeyword("IF-DOES-NOT-EXIST"), + IF_EXISTS = internKeyword("IF-EXISTS"), + INHERITED = internKeyword("INHERITED"), + INITIAL_CONTENTS = internKeyword("INITIAL-CONTENTS"), + INITIAL_ELEMENT = internKeyword("INITIAL-ELEMENT"), + INPUT = internKeyword("INPUT"), + INSTANCE = internKeyword("INSTANCE"), + INT = internKeyword("INT"), + INTERNAL = internKeyword("INTERNAL"), + INVERT = internKeyword("INVERT"), + IO = internKeyword("IO"), + J = internKeyword("J"), + JAVA_1_4 = internKeyword("JAVA-1.4"), + JAVA_1_5 = internKeyword("JAVA-1.5"), + JAVA_1_6 = internKeyword("JAVA-1.6"), + JAVA_1_7 = internKeyword("JAVA-1.7"), + KEY = internKeyword("KEY"), + LINUX = internKeyword("LINUX"), + LOAD_TOPLEVEL = internKeyword("LOAD-TOPLEVEL"), + LOCAL = internKeyword("LOCAL"), + LONG = internKeyword("LONG"), + NAME = internKeyword("NAME"), + NEW_VERSION = internKeyword("NEW"), + NEWEST = internKeyword("NEWEST"), + NICKNAMES = internKeyword("NICKNAMES"), + NONE = internKeyword("NONE"), + NO_ERROR = internKeyword("NO-ERROR"), + OBJECT = internKeyword("OBJECT"), + OPERANDS = internKeyword("OPERANDS"), + OPERATION = internKeyword("OPERATION"), + OUTPUT = internKeyword("OUTPUT"), + OVERFLOW = internKeyword("OVERFLOW"), + OVERWRITE = internKeyword("OVERWRITE"), + PACKAGE = internKeyword("PACKAGE"), + PATHNAME = internKeyword("PATHNAME"), + PROBE = internKeyword("PROBE"), + PUBLIC = internKeyword("PUBLIC"), + PRESERVE = internKeyword("PRESERVE"), + REF = internKeyword("REF"), + RELATIVE = internKeyword("RELATIVE"), + RENAME = internKeyword("RENAME"), + RENAME_AND_DELETE = internKeyword("RENAME-AND-DELETE"), + SIZE = internKeyword("SIZE"), + START = internKeyword("START"), + STATUS = internKeyword("STATUS"), + STREAM = internKeyword("STREAM"), + SUNOS = internKeyword("SUNOS"), + SUPERSEDE = internKeyword("SUPERSEDE"), + TEST = internKeyword("TEST"), + TEST_NOT = internKeyword("TEST-NOT"), + TIME = internKeyword("TIME"), + TOP_LEVEL = internKeyword("TOP-LEVEL"), + TRAPS = internKeyword("TRAPS"), + TYPE = internKeyword("TYPE"), + UNDERFLOW = internKeyword("UNDERFLOW"), + UNIX = internKeyword("UNIX"), + UNSPECIFIC = internKeyword("UNSPECIFIC"), + UP = internKeyword("UP"), + UPCASE = internKeyword("UPCASE"), + USE = internKeyword("USE"), + VERSION = internKeyword("VERSION"), + WILD = internKeyword("WILD"), + WILD_INFERIORS = internKeyword("WILD-INFERIORS"), + WINDOWS = internKeyword("WINDOWS"), + X86 = internKeyword("X86"), + X86_64 = internKeyword("X86-64"), + CDR6 = internKeyword("CDR6"); +} Added: branches/save-image/src/org/armedbear/lisp/LICENSE ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LICENSE Fri Mar 6 00:01:48 2009 @@ -0,0 +1,20 @@ +The software in this package is distributed under the GNU General Public +License (with a special exception described below). + +A copy of GNU General Public License (GPL) is included in this distribution, in +the file COPYING. + +Linking this software statically or dynamically with other modules is making a +combined work based on this software. Thus, the terms and conditions of the GNU +General Public License cover the whole combination. + +As a special exception, the copyright holders of this software give you +permission to link this software with independent modules to produce an +executable, regardless of the license terms of these independent modules, and +to copy and distribute the resulting executable under terms of your choice, +provided that you also meet, for each linked independent module, the terms and +conditions of the license of that module. An independent module is a module +which is not derived from or based on this software. If you modify this +software, you may extend this exception to your version of the software, but +you are not obligated to do so. If you do not wish to do so, delete this +exception statement from your version. Added: branches/save-image/src/org/armedbear/lisp/Layout.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Layout.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,331 @@ +/* + * Layout.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: Layout.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Layout extends LispObject +{ + public final LispClass lispClass; + public final EqHashTable slotTable; + + private final LispObject[] slotNames; + private final LispObject sharedSlots; + + private boolean invalid; + + public Layout(LispClass lispClass, LispObject instanceSlots, LispObject sharedSlots) + { + this.lispClass = lispClass; + Debug.assertTrue(instanceSlots.listp()); + int length = 0; + try + { + length = instanceSlots.length(); + } + catch (Throwable t) + { + // Shouldn't happen. + Debug.trace(t); + } + slotNames = new LispObject[length]; + int i = 0; + try + { + while (instanceSlots != NIL) + { + slotNames[i++] = instanceSlots.car(); + instanceSlots = instanceSlots.cdr(); + } + } + catch (Throwable t) + { + // Shouldn't happen. + Debug.trace(t); + } + Debug.assertTrue(i == length); + this.sharedSlots = sharedSlots; + slotTable = initializeSlotTable(slotNames); + } + + public Layout(LispClass lispClass, LispObject[] instanceSlotNames, + LispObject sharedSlots) + { + this.lispClass = lispClass; + this.slotNames = instanceSlotNames; + this.sharedSlots = sharedSlots; + slotTable = initializeSlotTable(slotNames); + } + + // Copy constructor. + private Layout(Layout oldLayout) + { + lispClass = oldLayout.lispClass; + slotNames = oldLayout.slotNames; + sharedSlots = oldLayout.sharedSlots; + slotTable = initializeSlotTable(slotNames); + } + + private EqHashTable initializeSlotTable(LispObject[] slotNames) + { + EqHashTable ht = new EqHashTable(slotNames.length, NIL, NIL); + for (int i = slotNames.length; i-- > 0;) + ht.put(slotNames[i], i < 256 ? Fixnum.constants[i] : new Fixnum(i)); + return ht; + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject result = NIL; + result = result.push(new Cons("class", lispClass)); + for (int i = 0; i < slotNames.length; i++) + { + result = result.push(new Cons("slot " + i, slotNames[i])); + } + result = result.push(new Cons("shared slots", sharedSlots)); + return result.nreverse(); + } + + public boolean isInvalid() + { + return invalid; + } + + public void invalidate() + { + invalid = true; + } + + public LispObject[] getSlotNames() + { + return slotNames; + } + + public int getLength() + { + return slotNames.length; + } + + public LispObject getSharedSlots() + { + return sharedSlots; + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.LAYOUT); + } + + // Generates a list of slot definitions for the slot names in this layout. + protected LispObject generateSlotDefinitions() + { + LispObject list = NIL; + try + { + for (int i = slotNames.length; i-- > 0;) + list = list.push(new SlotDefinition(slotNames[i], NIL)); + } + catch (Throwable t) + { + // Shouldn't happen. + Debug.trace(t); + } + return list; + } + + // ### make-layout + private static final Primitive MAKE_LAYOUT = + new Primitive("make-layout", PACKAGE_SYS, true, + "class instance-slots class-slots") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try + { + return new Layout((LispClass)first, checkList(second), + checkList(third)); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + + }; + + // ### layout-class + private static final Primitive LAYOUT_CLASS = + new Primitive("layout-class", PACKAGE_SYS, true, "layout") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Layout)arg).lispClass; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.LAYOUT); + } + } + }; + + // ### layout-length + private static final Primitive LAYOUT_LENGTH = + new Primitive("layout-length", PACKAGE_SYS, true, "layout") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new Fixnum(((Layout)arg).slotNames.length); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.LAYOUT); + } + } + }; + + public int getSlotIndex(LispObject slotName) + { + LispObject index = slotTable.get(slotName); + if (index != null) + return ((Fixnum)index).value; + return -1; + } + + public LispObject getSharedSlotLocation(LispObject slotName) + throws ConditionThrowable + { + LispObject rest = sharedSlots; + while (rest != NIL) + { + LispObject location = rest.car(); + if (location.car() == slotName) + return location; + rest = rest.cdr(); + } + return null; + } + + // ### layout-slot-index layout slot-name => index + private static final Primitive LAYOUT_SLOT_INDEX = + new Primitive("layout-slot-index", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + final LispObject slotNames[] = ((Layout)first).slotNames; + for (int i = slotNames.length; i-- > 0;) + { + if (slotNames[i] == second) + return new Fixnum(i); + } + return NIL; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.LAYOUT); + } + } + }; + + // ### layout-slot-location layout slot-name => location + private static final Primitive LAYOUT_SLOT_LOCATION = + new Primitive("layout-slot-location", PACKAGE_SYS, true, "layout slot-name") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + final LispObject slotNames[] = ((Layout)first).slotNames; + final int limit = slotNames.length; + for (int i = 0; i < limit; i++) + { + if (slotNames[i] == second) + return new Fixnum(i); + } + // Reaching here, it's not an instance slot. + LispObject rest = ((Layout)first).sharedSlots; + while (rest != NIL) + { + LispObject location = rest.car(); + if (location.car() == second) + return location; + rest = rest.cdr(); + } + return NIL; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.LAYOUT); + } + } + }; + + // ### %make-instances-obsolete class => class + private static final Primitive _MAKE_INSTANCES_OBSOLETE = + new Primitive("%make-instances-obsolete", PACKAGE_SYS, true, "class") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispClass lispClass; + try + { + lispClass = (LispClass) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + Layout oldLayout = lispClass.getClassLayout(); + Layout newLayout = new Layout(oldLayout); + lispClass.setClassLayout(newLayout); + oldLayout.invalidate(); + return arg; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Lisp.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Lisp.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,2544 @@ +/* + * Lisp.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Lisp.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.*; +import java.lang.reflect.Constructor; +import java.math.BigInteger; +import java.net.URL; +import java.net.URLDecoder; +import java.util.Hashtable; +import java.util.zip.ZipEntry; +import java.util.zip.ZipFile; + +public abstract class Lisp +{ + public static final boolean debug = true; + + public static boolean cold = true; + + public static boolean initialized; + + // Packages. + public static final Package PACKAGE_CL = + Packages.createPackage("COMMON-LISP", 1024); + public static final Package PACKAGE_CL_USER = + Packages.createPackage("COMMON-LISP-USER", 1024); + public static final Package PACKAGE_KEYWORD = + Packages.createPackage("KEYWORD", 1024); + public static final Package PACKAGE_SYS = + Packages.createPackage("SYSTEM"); + public static final Package PACKAGE_MOP = + Packages.createPackage("MOP"); + public static final Package PACKAGE_TPL = + Packages.createPackage("TOP-LEVEL"); + public static final Package PACKAGE_EXT = + Packages.createPackage("EXTENSIONS"); + public static final Package PACKAGE_JVM = + Packages.createPackage("JVM"); + public static final Package PACKAGE_LOOP = + Packages.createPackage("LOOP"); + public static final Package PACKAGE_PROF = + Packages.createPackage("PROFILER"); + public static final Package PACKAGE_JAVA = + Packages.createPackage("JAVA"); + + // ### nil + // Constructing NIL forces the Symbol class to be loaded (since Nil extends + // Symbol). + public static final LispObject NIL = new Nil(PACKAGE_CL); + + // We need NIL before we can call usePackage(). + static + { + try + { + PACKAGE_CL.addNickname("CL"); + PACKAGE_CL_USER.addNickname("CL-USER"); + PACKAGE_CL_USER.usePackage(PACKAGE_CL); + PACKAGE_CL_USER.usePackage(PACKAGE_EXT); + PACKAGE_CL_USER.usePackage(PACKAGE_JAVA); + PACKAGE_SYS.addNickname("SYS"); + PACKAGE_SYS.usePackage(PACKAGE_CL); + PACKAGE_SYS.usePackage(PACKAGE_EXT); + PACKAGE_MOP.usePackage(PACKAGE_CL); + PACKAGE_MOP.usePackage(PACKAGE_EXT); + PACKAGE_MOP.usePackage(PACKAGE_SYS); + PACKAGE_TPL.addNickname("TPL"); + PACKAGE_TPL.usePackage(PACKAGE_CL); + PACKAGE_TPL.usePackage(PACKAGE_EXT); + PACKAGE_EXT.addNickname("EXT"); + PACKAGE_EXT.usePackage(PACKAGE_CL); + PACKAGE_JVM.usePackage(PACKAGE_CL); + PACKAGE_JVM.usePackage(PACKAGE_EXT); + PACKAGE_JVM.usePackage(PACKAGE_SYS); + PACKAGE_LOOP.usePackage(PACKAGE_CL); + PACKAGE_PROF.addNickname("PROF"); + PACKAGE_PROF.usePackage(PACKAGE_CL); + PACKAGE_PROF.usePackage(PACKAGE_EXT); + PACKAGE_JAVA.usePackage(PACKAGE_CL); + PACKAGE_JAVA.usePackage(PACKAGE_EXT); + } + catch (Throwable t) + { + t.printStackTrace(); + } + } + + // End-of-file marker. + public static final LispObject EOF = new LispObject(); + + public static boolean profiling; + + public static boolean sampling; + + public static volatile boolean sampleNow; + + // args must not be null! + public static final LispObject funcall(LispObject fun, LispObject[] args, + LispThread thread) + throws ConditionThrowable + { + LispObject stack = thread.getStack(); + thread.pushStackFrame(fun, args); + thread._values = null; + LispObject result; + if (profiling) + if (!sampling) + fun.incrementCallCount(); + try + { + switch (args.length) + { + case 0: + result = fun.execute(); + break; + case 1: + result = fun.execute(args[0]); + break; + case 2: + result = fun.execute(args[0], args[1]); + break; + case 3: + result = fun.execute(args[0], args[1], args[2]); + break; + case 4: + result = fun.execute(args[0], args[1], args[2], args[3]); + break; + case 5: + result = fun.execute(args[0], args[1], args[2], args[3], + args[4]); + break; + case 6: + result = fun.execute(args[0], args[1], args[2], args[3], + args[4], args[5]); + break; + case 7: + result = fun.execute(args[0], args[1], args[2], args[3], + args[4], args[5], args[6]); + break; + case 8: + result = fun.execute(args[0], args[1], args[2], args[3], + args[4], args[5], args[6], args[7]); + break; + default: + result = fun.execute(args); + break; + } + } + finally + { + thread.setStack(stack); + } + return result; + } + + public static final LispObject macroexpand(LispObject form, + final Environment env, + final LispThread thread) + throws ConditionThrowable + { + LispObject expanded = NIL; + while (true) + { + form = macroexpand_1(form, env, thread); + LispObject[] values = thread._values; + if (values[1] == NIL) + { + values[1] = expanded; + return form; + } + expanded = T; + } + } + + public static final LispObject macroexpand_1(final LispObject form, + final Environment env, + final LispThread thread) + throws ConditionThrowable + { + if (form instanceof Cons) + { + form.length(); // Force an error if form is not a proper list. + LispObject car = ((Cons)form).car; + if (car instanceof Symbol) + { + LispObject obj = env.lookupFunction(car); + if (obj instanceof Autoload) + { + Autoload autoload = (Autoload) obj; + autoload.load(); + obj = car.getSymbolFunction(); + } + if (obj instanceof SpecialOperator) + { + obj = get(car, Symbol.MACROEXPAND_MACRO, null); + if (obj instanceof Autoload) + { + Autoload autoload = (Autoload) obj; + autoload.load(); + obj = get(car, Symbol.MACROEXPAND_MACRO, null); + } + } + if (obj instanceof MacroObject) + { + LispObject expander = ((MacroObject)obj).expander; + if (profiling) + if (!sampling) + expander.incrementCallCount(); + LispObject hook = + coerceToFunction(Symbol.MACROEXPAND_HOOK.symbolValue(thread)); + return thread.setValues(hook.execute(expander, form, env), + T); + } + } + } + else if (form instanceof Symbol) + { + Symbol symbol = (Symbol) form; + LispObject obj = null; + if (symbol.isSpecialVariable()) + obj = thread.lookupSpecial(symbol); + else + obj = env.lookup(symbol); + if (obj == null) + obj = symbol.getSymbolValue(); + if (obj instanceof SymbolMacro) + return thread.setValues(((SymbolMacro)obj).getExpansion(), T); + } + // Not a macro. + return thread.setValues(form, NIL); + } + + // ### interactive-eval + private static final Primitive INTERACTIVE_EVAL = + new Primitive("interactive-eval", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject object) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + thread.setSpecialVariable(Symbol.MINUS, object); + LispObject result; + try + { + result = thread.execute(Symbol.EVAL.getSymbolFunction(), object); + } + catch (OutOfMemoryError e) + { + return error(new LispError("Out of memory.")); + } + catch (StackOverflowError e) + { + thread.setSpecialVariable(_SAVED_BACKTRACE_, + thread.backtraceAsList(0)); + return error(new StorageCondition("Stack overflow.")); + } + catch (Go go) + { + throw go; + } + catch (Throw t) + { + return error(new ControlError("Attempt to throw to the nonexistent tag " + + t.tag.writeToString() + ".")); + } + catch (Throwable t) + { + Debug.trace(t); + thread.setSpecialVariable(_SAVED_BACKTRACE_, + thread.backtraceAsList(0)); + return error(new LispError("Caught " + t + ".")); + } + Debug.assertTrue(result != null); + thread.setSpecialVariable(Symbol.STAR_STAR_STAR, + thread.safeSymbolValue(Symbol.STAR_STAR)); + thread.setSpecialVariable(Symbol.STAR_STAR, + thread.safeSymbolValue(Symbol.STAR)); + thread.setSpecialVariable(Symbol.STAR, result); + thread.setSpecialVariable(Symbol.PLUS_PLUS_PLUS, + thread.safeSymbolValue(Symbol.PLUS_PLUS)); + thread.setSpecialVariable(Symbol.PLUS_PLUS, + thread.safeSymbolValue(Symbol.PLUS)); + thread.setSpecialVariable(Symbol.PLUS, + thread.safeSymbolValue(Symbol.MINUS)); + LispObject[] values = thread._values; + thread.setSpecialVariable(Symbol.SLASH_SLASH_SLASH, + thread.safeSymbolValue(Symbol.SLASH_SLASH)); + thread.setSpecialVariable(Symbol.SLASH_SLASH, + thread.safeSymbolValue(Symbol.SLASH)); + if (values != null) + { + LispObject slash = NIL; + for (int i = values.length; i-- > 0;) + slash = new Cons(values[i], slash); + thread.setSpecialVariable(Symbol.SLASH, slash); + } + else + thread.setSpecialVariable(Symbol.SLASH, new Cons(result)); + return result; + } + }; + + public static final LispObject error(LispObject condition) + throws ConditionThrowable + { + return Symbol.ERROR.execute(condition); + } + + public static final LispObject error(LispObject condition, LispObject message) + throws ConditionThrowable + { + return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message); + } + + public static final LispObject type_error(LispObject datum, + LispObject expectedType) + throws ConditionThrowable + { + return error(new TypeError(datum, expectedType)); + } + + protected static volatile boolean interrupted; + + public static synchronized final void setInterrupted(boolean b) + { + interrupted = b; + } + + public static final void handleInterrupt() throws ConditionThrowable + { + setInterrupted(false); + Symbol.BREAK.getSymbolFunction().execute(); + setInterrupted(false); + } + + // Used by the compiler. + public static final LispObject loadTimeValue(LispObject obj) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (Symbol.LOAD_TRUENAME.symbolValue(thread) != NIL) + return eval(obj, new Environment(), thread); + else + return NIL; + } + + public static final LispObject eval(LispObject obj) + throws ConditionThrowable + { + return eval(obj, new Environment(), LispThread.currentThread()); + } + + public static final LispObject eval(final LispObject obj, + final Environment env, + final LispThread thread) + throws ConditionThrowable + { + thread._values = null; + if (interrupted) + handleInterrupt(); + if (thread.isDestroyed()) + throw new ThreadDestroyed(); + if (obj instanceof Symbol) + { + LispObject result; + if (obj.isSpecialVariable()) + { + if (obj.constantp()) + return obj.getSymbolValue(); + else + result = thread.lookupSpecial(obj); + } + else if (env.isDeclaredSpecial(obj)) + result = thread.lookupSpecial(obj); + else + result = env.lookup(obj); + if (result == null) + { + result = obj.getSymbolValue(); + if (result == null) + return error(new UnboundVariable(obj)); + } + if (result instanceof SymbolMacro) + return eval(((SymbolMacro)result).getExpansion(), env, thread); + return result; + } + else if (obj instanceof Cons) + { + LispObject first = ((Cons)obj).car; + if (first instanceof Symbol) + { + LispObject fun = env.lookupFunction(first); + if (fun instanceof SpecialOperator) + { + if (profiling) + if (!sampling) + fun.incrementCallCount(); + // Don't eval args! + return fun.execute(((Cons)obj).cdr, env); + } + if (fun instanceof MacroObject) + return eval(macroexpand(obj, env, thread), env, thread); + if (fun instanceof Autoload) + { + Autoload autoload = (Autoload) fun; + autoload.load(); + return eval(obj, env, thread); + } + return evalCall(fun != null ? fun : first, + ((Cons)obj).cdr, env, thread); + } + else + { + if (first.car() == Symbol.LAMBDA) + { + Closure closure = new Closure(first, env); + return evalCall(closure, ((Cons)obj).cdr, env, thread); + } + else + return error(new ProgramError("Illegal function object: " + + first.writeToString())); + } + } + else + return obj; + } + + public static final int CALL_REGISTERS_MAX = 8; + + // Also used in JProxy.java. + protected static final LispObject evalCall(LispObject function, + LispObject args, + Environment env, + LispThread thread) + throws ConditionThrowable + { + if (args == NIL) + return thread.execute(function); + LispObject first = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first); + } + LispObject second = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second); + } + LispObject third = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second, third); + } + LispObject fourth = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second, third, fourth); + } + LispObject fifth = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second, third, fourth, fifth); + } + LispObject sixth = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second, third, fourth, fifth, + sixth); + } + LispObject seventh = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second, third, fourth, fifth, + sixth, seventh); + } + LispObject eighth = eval(args.car(), env, thread); + args = ((Cons)args).cdr; + if (args == NIL) + { + thread._values = null; + return thread.execute(function, first, second, third, fourth, fifth, + sixth, seventh, eighth); + } + // More than CALL_REGISTERS_MAX arguments. + final int length = args.length() + CALL_REGISTERS_MAX; + LispObject[] array = new LispObject[length]; + array[0] = first; + array[1] = second; + array[2] = third; + array[3] = fourth; + array[4] = fifth; + array[5] = sixth; + array[6] = seventh; + array[7] = eighth; + for (int i = CALL_REGISTERS_MAX; i < length; i++) + { + array[i] = eval(args.car(), env, thread); + args = args.cdr(); + } + thread._values = null; + return thread.execute(function, array); + } + + public static final LispObject progn(LispObject body, Environment env, + LispThread thread) + throws ConditionThrowable + { + LispObject result = NIL; + while (body != NIL) + { + result = eval(body.car(), env, thread); + body = ((Cons)body).cdr; + } + return result; + } + + // Environment wrappers. + private static final boolean isSpecial(Symbol sym, Symbol[] ownSpecials, + Environment env) + { + if (ownSpecials != null) + { + if (sym.isSpecialVariable()) + return true; + for (Symbol special : ownSpecials) + { + if (sym == special) + return true; + } + } + return false; + } + protected static final void bindArg(Symbol[] ownSpecials, + Symbol sym, LispObject value, + Environment env, LispThread thread) + throws ConditionThrowable + { + if (isSpecial(sym, ownSpecials, env)) { + env.declareSpecial(sym); + thread.bindSpecial(sym, value); + } + else + env.bind(sym, value); + } + + public static final Cons list(LispObject... objects) + { + Cons theList = new Cons(objects[objects.length-1]); + for (int i = objects.length - 2; i >= 0; i--) + theList = new Cons(objects[i], theList); + return theList; + } + + public static final Cons list1(LispObject obj1) + { + return new Cons(obj1); + } + + public static final Cons list2(LispObject obj1, LispObject obj2) + { + return new Cons(obj1, new Cons(obj2)); + } + + public static final Cons list3(LispObject obj1, LispObject obj2, + LispObject obj3) + { + return new Cons(obj1, new Cons(obj2, new Cons(obj3))); + } + + public static final Cons list4(LispObject obj1, LispObject obj2, + LispObject obj3, LispObject obj4) + { + return new Cons(obj1, + new Cons(obj2, + new Cons(obj3, + new Cons(obj4)))); + } + + public static final Cons list5(LispObject obj1, LispObject obj2, + LispObject obj3, LispObject obj4, + LispObject obj5) + { + return new Cons(obj1, + new Cons(obj2, + new Cons(obj3, + new Cons(obj4, + new Cons(obj5))))); + } + + public static final Cons list6(LispObject obj1, LispObject obj2, + LispObject obj3, LispObject obj4, + LispObject obj5, LispObject obj6) + { + return new Cons(obj1, + new Cons(obj2, + new Cons(obj3, + new Cons(obj4, + new Cons(obj5, + new Cons(obj6)))))); + } + + public static final Cons list7(LispObject obj1, LispObject obj2, + LispObject obj3, LispObject obj4, + LispObject obj5, LispObject obj6, + LispObject obj7) + { + return new Cons(obj1, + new Cons(obj2, + new Cons(obj3, + new Cons(obj4, + new Cons(obj5, + new Cons(obj6, + new Cons(obj7))))))); + } + + public static final Cons list8(LispObject obj1, LispObject obj2, + LispObject obj3, LispObject obj4, + LispObject obj5, LispObject obj6, + LispObject obj7, LispObject obj8) + { + return new Cons(obj1, + new Cons(obj2, + new Cons(obj3, + new Cons(obj4, + new Cons(obj5, + new Cons(obj6, + new Cons(obj7, + new Cons(obj8)))))))); + } + + public static final Cons list9(LispObject obj1, LispObject obj2, + LispObject obj3, LispObject obj4, + LispObject obj5, LispObject obj6, + LispObject obj7, LispObject obj8, + LispObject obj9) + { + return new Cons(obj1, + new Cons(obj2, + new Cons(obj3, + new Cons(obj4, + new Cons(obj5, + new Cons(obj6, + new Cons(obj7, + new Cons(obj8, + new Cons(obj9))))))))); + } + + // Used by the compiler. + public static final LispObject multipleValueList(LispObject result) + throws ConditionThrowable + { + LispThread thread = LispThread.currentThread(); + LispObject[] values = thread._values; + if (values == null) + return new Cons(result); + thread._values = null; + LispObject list = NIL; + for (int i = values.length; i-- > 0;) + list = new Cons(values[i], list); + return list; + } + + // Used by the compiler for MULTIPLE-VALUE-CALLs with a single values form. + public static final LispObject multipleValueCall1(LispObject result, + LispObject function, + LispThread thread) + throws ConditionThrowable + { + LispObject[] values = thread._values; + thread._values = null; + if (values == null) + return thread.execute(coerceToFunction(function), result); + else + return funcall(coerceToFunction(function), values, thread); + } + + public static final void progvBindVars(LispObject symbols, + LispObject values, + LispThread thread) + throws ConditionThrowable + { + for (LispObject list = symbols; list != NIL; list = list.cdr()) + { + Symbol symbol = checkSymbol(list.car()); + LispObject value; + if (values != NIL) + { + value = values.car(); + values = values.cdr(); + } + else + { + // "If too few values are supplied, the remaining symbols are + // bound and then made to have no value." + value = null; + } + thread.bindSpecial(symbol, value); + } + } + + public static Symbol checkSymbol(LispObject obj) throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (Symbol) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.SYMBOL); + // Not reached. + return null; + } + } + + public static final LispObject checkList(LispObject obj) + throws ConditionThrowable + { + if (obj.listp()) + return obj; + return type_error(obj, Symbol.LIST); + } + + public static final AbstractArray checkArray(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (AbstractArray) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.ARRAY); + // Not reached. + return null; + } + } + + public static final AbstractVector checkVector(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (AbstractVector) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.VECTOR); + // Not reached. + return null; + } + } + + static + { + // ### *gensym-counter* + Symbol.GENSYM_COUNTER.initializeSpecial(Fixnum.ZERO); + } + + public static final Symbol gensym(LispThread thread) + throws ConditionThrowable + { + return gensym("G", thread); + } + + public static final Symbol gensym(String prefix, LispThread thread) + throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(prefix); + SpecialBinding binding = thread.getSpecialBinding(Symbol.GENSYM_COUNTER); + final LispObject oldValue; + if (binding != null) + oldValue = binding.value; + else + oldValue = Symbol.GENSYM_COUNTER.getSymbolValue(); + // Decimal representation. + if (oldValue instanceof Fixnum) + sb.append(((Fixnum)oldValue).value); + else if (oldValue instanceof Bignum) + sb.append(((Bignum)oldValue).value.toString()); + else + { + // Restore sanity. + if (binding != null) + binding.value = Fixnum.ZERO; + else + Symbol.GENSYM_COUNTER.setSymbolValue(Fixnum.ZERO); + error(new TypeError("The value of *GENSYM-COUNTER* was not a nonnegative integer. Old value: " + + oldValue.writeToString() + " New value: 0")); + } + if (binding != null) + binding.value = oldValue.incr(); + else + Symbol.GENSYM_COUNTER.setSymbolValue(oldValue.incr()); + return new Symbol(new SimpleString(sb)); + } + + public static final String javaString(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof AbstractString) + return arg.getStringValue(); + if (arg instanceof Symbol) + return ((Symbol)arg).getName(); + if (arg instanceof LispCharacter) + return String.valueOf(new char[] {((LispCharacter)arg).value}); + type_error(arg, list4(Symbol.OR, Symbol.STRING, Symbol.SYMBOL, + Symbol.CHARACTER)); + // Not reached. + return null; + } + + public static final LispObject number(long n) + { + if (n >= Integer.MIN_VALUE && n <= Integer.MAX_VALUE) + return new Fixnum((int)n); + else + return new Bignum(n); + } + + private static final BigInteger INT_MIN = BigInteger.valueOf(Integer.MIN_VALUE); + private static final BigInteger INT_MAX = BigInteger.valueOf(Integer.MAX_VALUE); + + public static final LispObject number(BigInteger numerator, + BigInteger denominator) + throws ConditionThrowable + { + if (denominator.signum() == 0) + error(new DivisionByZero()); + if (denominator.signum() < 0) + { + numerator = numerator.negate(); + denominator = denominator.negate(); + } + BigInteger gcd = numerator.gcd(denominator); + if (!gcd.equals(BigInteger.ONE)) + { + numerator = numerator.divide(gcd); + denominator = denominator.divide(gcd); + } + if (denominator.equals(BigInteger.ONE)) + return number(numerator); + else + return new Ratio(numerator, denominator); + } + + public static final LispObject number(BigInteger n) + { + if (n.compareTo(INT_MIN) >= 0 && n.compareTo(INT_MAX) <= 0) + return new Fixnum(n.intValue()); + else + return new Bignum(n); + } + + public static final int mod(int number, int divisor) + throws ConditionThrowable + { + final int r; + try + { + r = number % divisor; + } + catch (ArithmeticException e) + { + error(new ArithmeticError("Division by zero.")); + // Not reached. + return 0; + } + if (r == 0) + return r; + if (divisor < 0) + { + if (number > 0) + return r + divisor; + } + else + { + if (number < 0) + return r + divisor; + } + return r; + } + + // Adapted from SBCL. + public static final int mix(long x, long y) + { + long xy = x * 3 + y; + return (int) (536870911L & (441516657L ^ xy ^ (xy >> 5))); + } + + // Used by the compiler. + public static final LispObject readObjectFromString(String s) + { + try + { + return new StringInputStream(s).faslRead(true, NIL, false, + LispThread.currentThread()); + } + catch (Throwable t) + { + return null; + } + } + + public static final LispObject loadCompiledFunction(final String namestring) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final boolean absolute = Utilities.isFilenameAbsolute(namestring); + LispObject device = NIL; + final Pathname defaultPathname; + if (absolute) + { + defaultPathname = + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue(thread)); + } + else + { + LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValue(thread); + if (loadTruename instanceof Pathname) + { + defaultPathname = (Pathname) loadTruename; + // We're loading a file. + device = ((Pathname)loadTruename).getDevice(); + } + else + { + defaultPathname = + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue(thread)); + } + } + if (device instanceof Pathname) + { + // We're loading a fasl from a jar. + URL url = Lisp.class.getResource(namestring); + if (url != null) { + try { + String s = url.toString(); + InputStream input = url.openStream(); + ByteArrayOutputStream baos = new ByteArrayOutputStream(); + + byte[] bytes = new byte[4096]; + int n = 0; + while (n >= 0) { + n = input.read(bytes, 0, 4096); + if(n >= 0) { + baos.write(bytes, 0, n); + } + } + input.close(); + bytes = baos.toByteArray(); + baos.close(); + JavaClassLoader loader = new JavaClassLoader(); + Class c = + loader.loadClassFromByteArray(null, bytes, 0, bytes.length); + if (c != null) { + Class[] parameterTypes = new Class[0]; + Constructor constructor = + c.getConstructor(parameterTypes); + Object[] initargs = new Object[0]; + LispObject obj = + (LispObject) constructor.newInstance(initargs); + if (obj instanceof Function) + ((Function)obj).setClassBytes(bytes); + else { + System.out.println("obj: " + obj); + } + return obj != null ? obj : NIL; + } + } + catch (VerifyError e) + { + return error(new LispError("Class verification failed: " + + e.getMessage())); + } + catch (IOException e) + { + Debug.trace(e); + } + catch (Throwable t) + { + Debug.trace(t); + } + } + return error(new LispError("Unable to load " + namestring)); + } + Pathname pathname = new Pathname(namestring); + final File file = Utilities.getFile(pathname, defaultPathname); + if (file != null && file.isFile()) + { + // The .cls file exists. + try + { + LispObject obj = loadCompiledFunction(new FileInputStream(file), + (int) file.length()); + // FIXME close stream! + if (obj != null) + return obj; + } + catch (VerifyError e) + { + return error(new LispError("Class verification failed: " + + e.getMessage())); + } + catch (Throwable t) + { + Debug.trace(t); + } + return error(new LispError("Unable to load " + + pathname.writeToString())); + } + try + { + LispObject loadTruename = Symbol.LOAD_TRUENAME.symbolValue(thread); + String zipFileName = ((Pathname)loadTruename).getNamestring(); + ZipFile zipFile = new ZipFile(zipFileName); + try + { + ZipEntry entry = zipFile.getEntry(namestring); + if (entry != null) + { + LispObject obj = loadCompiledFunction(zipFile.getInputStream(entry), + (int) entry.getSize()); + if (obj != null) + return obj; + Debug.trace("Unable to load " + namestring); + return error(new LispError("Unable to load " + namestring)); + } + } + finally + { + zipFile.close(); + } + } + catch (Throwable t) + { + Debug.trace(t); + } + return error(new FileError("File not found: " + namestring, + new Pathname(namestring))); + } + + protected static final LispObject loadCompiledFunction(InputStream in, int size) + { + try + { + byte[] bytes = new byte[size]; + int bytesRemaining = size; + int bytesRead = 0; + while (bytesRemaining > 0) + { + int n = in.read(bytes, bytesRead, bytesRemaining); + if (n < 0) + break; + bytesRead += n; + bytesRemaining -= n; + } + in.close(); + if (bytesRemaining > 0) + Debug.trace("bytesRemaining = " + bytesRemaining); + + //JavaClassLoader loader = new JavaClassLoader(); + return loadCompiledFunction(bytes); + } + catch (Throwable t) + { + Debug.trace(t); + } + return null; + } + + protected static final LispObject loadCompiledFunction(byte[] bytes) throws Throwable { + Class c = (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); + if (c != null) { + Class sc = c.getSuperclass(); + Constructor constructor = c.getConstructor((Class[])null); + LispObject obj = (LispObject) constructor.newInstance((Object[])null); + if (obj instanceof Function) { + ((Function)obj).setClassBytes(bytes); + } + return obj; + } else { + return null; + } + } + + public static final LispObject makeCompiledClosure(LispObject template, + LispObject[] context) + throws ConditionThrowable + { + ClosureTemplateFunction ctf = ((ClosureTemplateFunction) template).dup(); + ctf.setContext(context); + CompiledClosure result = new CompiledClosure(ctf, context); + LispObject classBytes = + getf(ctf.getPropertyList(), Symbol.CLASS_BYTES, NIL); + if (classBytes != NIL) + result.setPropertyList(list2(Symbol.CLASS_BYTES, classBytes)); + return result; + } + + public static final String safeWriteToString(LispObject obj) + { + try + { + return obj.writeToString(); + } + catch (ConditionThrowable t) + { + return obj.toString(); + } + catch (NullPointerException e) + { + Debug.trace(e); + return "null"; + } + } + + public static final boolean isValidSetfFunctionName(LispObject obj) + { + if (obj instanceof Cons) + { + Cons cons = (Cons) obj; + if (cons.car == Symbol.SETF && cons.cdr instanceof Cons) + { + Cons cdr = (Cons) cons.cdr; + return (cdr.car instanceof Symbol && cdr.cdr == NIL); + } + } + return false; + } + + public static final LispObject FUNCTION_NAME = + list3(Symbol.OR, + Symbol.SYMBOL, + list3(Symbol.CONS, + list2(Symbol.EQL, Symbol.SETF), + list3(Symbol.CONS, Symbol.SYMBOL, Symbol.NULL))); + + public static final LispObject UNSIGNED_BYTE_8 = + list2(Symbol.UNSIGNED_BYTE, Fixnum.constants[8]); + + public static final LispObject UNSIGNED_BYTE_16 = + list2(Symbol.UNSIGNED_BYTE, Fixnum.constants[16]); + + public static final LispObject UNSIGNED_BYTE_32 = + list2(Symbol.UNSIGNED_BYTE, Fixnum.constants[32]); + + public static final LispObject UNSIGNED_BYTE_32_MAX_VALUE = + new Bignum(4294967296L); + + public static final LispObject getUpgradedArrayElementType(LispObject type) + throws ConditionThrowable + { + if (type instanceof Symbol) + { + if (type == Symbol.CHARACTER || type == Symbol.BASE_CHAR || + type == Symbol.STANDARD_CHAR) + return Symbol.CHARACTER; + if (type == Symbol.BIT) + return Symbol.BIT; + if (type == NIL) + return NIL; + } + if (type == BuiltInClass.CHARACTER) + return Symbol.CHARACTER; + if (type instanceof Cons) + { + if (type.equal(UNSIGNED_BYTE_8)) + return type; + if (type.equal(UNSIGNED_BYTE_16)) + return type; + if (type.equal(UNSIGNED_BYTE_32)) + return type; + LispObject car = type.car(); + if (car == Symbol.INTEGER) + { + LispObject lower = type.cadr(); + LispObject upper = type.cdr().cadr(); + // Convert to inclusive bounds. + if (lower instanceof Cons) + lower = lower.car().incr(); + if (upper instanceof Cons) + upper = upper.car().decr(); + if (lower.integerp() && upper.integerp()) + { + if (lower instanceof Fixnum && upper instanceof Fixnum) + { + int l = ((Fixnum)lower).value; + if (l >= 0) + { + int u = ((Fixnum)upper).value; + if (u <= 1) + return Symbol.BIT; + if (u <= 255) + return UNSIGNED_BYTE_8; + if (u <= 65535) + return UNSIGNED_BYTE_16; + return UNSIGNED_BYTE_32; + } + } + if (lower.isGreaterThanOrEqualTo(Fixnum.ZERO)) + { + if (lower.isLessThan(UNSIGNED_BYTE_32_MAX_VALUE)) + { + if (upper.isLessThan(UNSIGNED_BYTE_32_MAX_VALUE)) + return UNSIGNED_BYTE_32; + } + } + } + } + else if (car == Symbol.EQL) + { + LispObject obj = type.cadr(); + if (obj instanceof Fixnum) + { + int val = ((Fixnum)obj).value; + if (val >= 0) + { + if (val <= 1) + return Symbol.BIT; + if (val <= 255) + return UNSIGNED_BYTE_8; + if (val <= 65535) + return UNSIGNED_BYTE_16; + return UNSIGNED_BYTE_32; + } + } + else if (obj instanceof Bignum) + { + if (obj.isGreaterThanOrEqualTo(Fixnum.ZERO)) + { + if (obj.isLessThan(UNSIGNED_BYTE_32_MAX_VALUE)) + return UNSIGNED_BYTE_32; + } + } + } + else if (car == Symbol.MEMBER) + { + LispObject rest = type.cdr(); + while (rest != NIL) + { + LispObject obj = rest.car(); + if (obj instanceof LispCharacter) + rest = rest.cdr(); + else + return T; + } + return Symbol.CHARACTER; + } + } + return T; + } + + public static final byte coerceLispObjectToJavaByte(LispObject obj) + throws ConditionThrowable + { + try + { + return (byte) ((Fixnum)obj).value; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.FIXNUM); + // Not reached. + return 0; + } + } + + public static final LispObject coerceJavaByteToLispObject(byte b) + { + return Fixnum.constants[((int)b) & 0xff]; + } + + public static final LispCharacter checkCharacter(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (LispCharacter) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.CHARACTER); + // Not reached. + return null; + } + } + + public static final Package checkPackage(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (Package) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.PACKAGE); + // Not reached. + return null; + } + } + + public static final Function checkFunction(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (Function) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.FUNCTION); + // Not reached. + return null; + } + } + + public static final Stream checkStream(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (Stream) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.STREAM); + // Not reached. + return null; + } + } + + public static final Stream checkCharacterInputStream(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + final Stream stream = (Stream) obj; + if (stream.isCharacterInputStream()) + return stream; + error(new TypeError("The value " + obj.writeToString() + + " is not a character input stream.")); + // Not reached. + return null; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.STREAM); + // Not reached. + return null; + } + } + + public static final Stream checkCharacterOutputStream(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + final Stream stream = (Stream) obj; + if (stream.isCharacterOutputStream()) + return stream; + error(new TypeError("The value " + obj.writeToString() + + " is not a character output stream.")); + // Not reached. + return null; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.STREAM); + // Not reached. + return null; + } + } + + public static final Stream checkBinaryInputStream(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + final Stream stream = (Stream) obj; + if (stream.isBinaryInputStream()) + return stream; + error(new TypeError("The value " + obj.writeToString() + + " is not a binary input stream.")); + // Not reached. + return null; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.STREAM); + // Not reached. + return null; + } + } + + public static final Stream inSynonymOf(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof Stream) + return (Stream) obj; + if (obj == T) + return checkCharacterInputStream(Symbol.TERMINAL_IO.symbolValue()); + if (obj == NIL) + return checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()); + type_error(obj, Symbol.STREAM); + // Not reached. + return null; + } + + public static final void writeByte(int n, LispObject obj) + throws ConditionThrowable + { + if (n < 0 || n > 255) + type_error(new Fixnum(n), UNSIGNED_BYTE_8); + try + { + ((Stream)obj)._writeByte(n); + } + catch (ClassCastException e) + { + type_error(obj, Symbol.STREAM); + } + } + + public static final Readtable checkReadtable(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (Readtable) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.READTABLE); + // Not reached. + return null; + } + } + + public static final Readtable designator_readtable(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + if (obj == NIL) + obj = STANDARD_READTABLE.symbolValue(); + try + { + return (Readtable) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.READTABLE); + // Not reached. + return null; + } + } + + public static final Environment checkEnvironment(LispObject obj) + throws ConditionThrowable + { + if (obj == null) + throw new NullPointerException(); + try + { + return (Environment) obj; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.ENVIRONMENT); + // Not reached. + return null; + } + } + + public static final void checkBounds(int start, int end, int length) + throws ConditionThrowable + { + if (start < 0 || end < 0 || start > end || end > length) + { + FastStringBuffer sb = new FastStringBuffer("The bounding indices "); + sb.append(start); + sb.append(" and "); + sb.append(end); + sb.append(" are bad for a sequence of length "); + sb.append(length); + sb.append('.'); + error(new TypeError(sb.toString())); + } + } + + public static final LispObject coerceToFunction(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof Function) + return obj; + if (obj instanceof StandardGenericFunction) + return obj; + if (obj instanceof Symbol) + { + LispObject fun = obj.getSymbolFunction(); + if (fun instanceof Function) + return (Function) fun; + } + else if (obj instanceof Cons && obj.car() == Symbol.LAMBDA) + return new Closure(obj, new Environment()); + error(new UndefinedFunction(obj)); + // Not reached. + return null; + } + + // Returns package or throws exception. + public static final Package coerceToPackage(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof Package) + return (Package) obj; + Package pkg = Packages.findPackage(javaString(obj)); + if (pkg != null) + return pkg; + error(new PackageError(obj.writeToString() + " is not the name of a package.")); + // Not reached. + return null; + } + + public static Pathname coerceToPathname(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof Pathname) + return (Pathname) arg; + if (arg instanceof AbstractString) + return Pathname.parseNamestring((AbstractString)arg); + if (arg instanceof FileStream) + return ((FileStream)arg).getPathname(); + type_error(arg, list4(Symbol.OR, Symbol.PATHNAME, + Symbol.STRING, Symbol.FILE_STREAM)); + // Not reached. + return null; + } + + public LispObject assq(LispObject item, LispObject alist) + throws ConditionThrowable + { + while (alist instanceof Cons) + { + LispObject entry = ((Cons)alist).car; + if (entry instanceof Cons) + { + if (((Cons)entry).car == item) + return entry; + } + else if (entry != NIL) + return type_error(entry, Symbol.LIST); + alist = ((Cons)alist).cdr; + } + if (alist != NIL) + return type_error(alist, Symbol.LIST); + return NIL; + } + + public static final boolean memq(LispObject item, LispObject list) + throws ConditionThrowable + { + while (list instanceof Cons) + { + if (item == ((Cons)list).car) + return true; + list = ((Cons)list).cdr; + } + if (list != NIL) + type_error(list, Symbol.LIST); + return false; + } + + public static final boolean memql(LispObject item, LispObject list) + throws ConditionThrowable + { + while (list instanceof Cons) + { + if (item.eql(((Cons)list).car)) + return true; + list = ((Cons)list).cdr; + } + if (list != NIL) + type_error(list, Symbol.LIST); + return false; + } + + // Property lists. + public static final LispObject getf(LispObject plist, LispObject indicator, + LispObject defaultValue) + throws ConditionThrowable + { + LispObject list = plist; + while (list != NIL) + { + if (list.car() == indicator) + return list.cadr(); + if (list.cdr() instanceof Cons) + list = list.cddr(); + else + return error(new TypeError("Malformed property list: " + + plist.writeToString())); + } + return defaultValue; + } + + public static final LispObject get(LispObject symbol, LispObject indicator) + throws ConditionThrowable + { + LispObject list; + try + { + list = ((Symbol)symbol).getPropertyList(); + } + catch (ClassCastException e) + { + return type_error(symbol, Symbol.SYMBOL); + } + while (list != NIL) + { + if (list.car() == indicator) + return list.cadr(); + list = list.cddr(); + } + return NIL; + } + + public static final LispObject get(LispObject symbol, LispObject indicator, + LispObject defaultValue) + throws ConditionThrowable + { + LispObject list; + try + { + list = ((Symbol)symbol).getPropertyList(); + } + catch (ClassCastException e) + { + return type_error(symbol, Symbol.SYMBOL); + } + while (list != NIL) + { + if (list.car() == indicator) + return list.cadr(); + list = list.cddr(); + } + return defaultValue; + } + + public static final LispObject put(Symbol symbol, LispObject indicator, + LispObject value) + throws ConditionThrowable + { + LispObject list = symbol.getPropertyList(); + while (list != NIL) + { + if (list.car() == indicator) + { + // Found it! + LispObject rest = list.cdr(); + rest.setCar(value); + return value; + } + list = list.cddr(); + } + // Not found. + symbol.setPropertyList(new Cons(indicator, + new Cons(value, + symbol.getPropertyList()))); + return value; + } + + public static final LispObject putf(LispObject plist, LispObject indicator, + LispObject value) + throws ConditionThrowable + { + LispObject list = plist; + while (list != NIL) + { + if (list.car() == indicator) + { + // Found it! + LispObject rest = list.cdr(); + rest.setCar(value); + return plist; + } + list = list.cddr(); + } + // Not found. + return new Cons(indicator, new Cons(value, plist)); + } + + public static final LispObject remprop(Symbol symbol, LispObject indicator) + throws ConditionThrowable + { + LispObject list = checkList(symbol.getPropertyList()); + LispObject prev = null; + while (list != NIL) + { + if (!(list.cdr() instanceof Cons)) + error(new ProgramError("The symbol " + symbol.writeToString() + + " has an odd number of items in its property list.")); + if (list.car() == indicator) + { + // Found it! + if (prev != null) + prev.setCdr(list.cddr()); + else + symbol.setPropertyList(list.cddr()); + return T; + } + prev = list.cdr(); + list = list.cddr(); + } + // Not found. + return NIL; + } + + public static final String format(LispObject formatControl, + LispObject formatArguments) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + String control = formatControl.getStringValue(); + LispObject[] args = formatArguments.copyToArray(); + StringBuffer sb = new StringBuffer(); + if (control != null) + { + final int limit = control.length(); + int j = 0; + final int NEUTRAL = 0; + final int TILDE = 1; + int state = NEUTRAL; + for (int i = 0; i < limit; i++) + { + char c = control.charAt(i); + if (state == NEUTRAL) + { + if (c == '~') + state = TILDE; + else + sb.append(c); + } + else if (state == TILDE) + { + if (c == 'A' || c == 'a') + { + if (j < args.length) + { + LispObject obj = args[j++]; + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + thread.bindSpecial(Symbol.PRINT_READABLY, NIL); + sb.append(obj.writeToString()); + thread.lastSpecialBinding = lastSpecialBinding; + } + } + else if (c == 'S' || c == 's') + { + if (j < args.length) + { + LispObject obj = args[j++]; + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + sb.append(obj.writeToString()); + thread.lastSpecialBinding = lastSpecialBinding; + } + } + else if (c == 'D' || c == 'd') + { + if (j < args.length) + { + LispObject obj = args[j++]; + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + thread.bindSpecial(Symbol.PRINT_RADIX, NIL); + thread.bindSpecial(Symbol.PRINT_BASE, Fixnum.constants[10]); + sb.append(obj.writeToString()); + thread.lastSpecialBinding = lastSpecialBinding; + } + } + else if (c == 'X' || c == 'x') + { + if (j < args.length) + { + LispObject obj = args[j++]; + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + thread.bindSpecial(Symbol.PRINT_RADIX, NIL); + thread.bindSpecial(Symbol.PRINT_BASE, Fixnum.constants[16]); + sb.append(obj.writeToString()); + thread.lastSpecialBinding = lastSpecialBinding; + } + } + else if (c == '%') + { + sb.append('\n'); + } + state = NEUTRAL; + } + else + { + // There are no other valid states. + Debug.assertTrue(false); + } + } + } + return sb.toString(); + } + + public static final Symbol intern(String name, Package pkg) + { + return pkg.intern(name); + } + + // Used by the compiler. + public static final Symbol internInPackage(String name, String packageName) + throws ConditionThrowable + { + Package pkg = Packages.findPackage(packageName); + if (pkg == null) + error(new LispError(packageName + " is not the name of a package.")); + return pkg.intern(name); + } + + public static final Symbol internKeyword(String s) + { + return PACKAGE_KEYWORD.intern(s); + } + + // The compiler's object table. + private static final Hashtable objectTable = + new Hashtable(); + + public static final LispObject recall(SimpleString key) + { + return (LispObject) objectTable.remove(key.getStringValue()); + } + + // ### remember + public static final Primitive REMEMBER = + new Primitive("remember", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject key, LispObject value) + throws ConditionThrowable + { + objectTable.put(key.getStringValue(), value); + return NIL; + } + }; + + public static final Symbol internSpecial(String name, Package pkg, + LispObject value) + { + Symbol symbol = pkg.intern(name); + symbol.setSpecial(true); + symbol.setSymbolValue(value); + return symbol; + } + + public static final Symbol internConstant(String name, Package pkg, + LispObject value) + { + Symbol symbol = pkg.intern(name); + symbol.initializeConstant(value); + return symbol; + } + + public static final Symbol exportSpecial(String name, Package pkg, + LispObject value) + { + Symbol symbol = pkg.intern(name); + try + { + pkg.export(symbol); // FIXME Inefficient! + } + catch (ConditionThrowable t) + { + Debug.trace(t); + } + symbol.setSpecial(true); + symbol.setSymbolValue(value); + return symbol; + } + + public static final Symbol exportConstant(String name, Package pkg, + LispObject value) + { + Symbol symbol = pkg.intern(name); + try + { + pkg.export(symbol); // FIXME Inefficient! + } + catch (ConditionThrowable t) + { + Debug.trace(t); + } + symbol.initializeConstant(value); + return symbol; + } + + static + { + String userDir = System.getProperty("user.dir"); + if (userDir != null && userDir.length() > 0) + { + if (userDir.charAt(userDir.length() - 1) != File.separatorChar) + userDir = userDir.concat(File.separator); + } + // This string will be converted to a pathname when Pathname.java is loaded. + Symbol.DEFAULT_PATHNAME_DEFAULTS.initializeSpecial(new SimpleString(userDir)); + } + + static + { + Symbol._PACKAGE_.initializeSpecial(PACKAGE_CL_USER); + } + + public static final Package getCurrentPackage() + { + return (Package) Symbol._PACKAGE_.symbolValueNoThrow(); + } + + private static Stream stdin = new Stream(System.in, Symbol.CHARACTER, true); + + private static Stream stdout = new Stream(System.out, Symbol.CHARACTER, true); + + static + { + Symbol.STANDARD_INPUT.initializeSpecial(stdin); + Symbol.STANDARD_OUTPUT.initializeSpecial(stdout); + Symbol.ERROR_OUTPUT.initializeSpecial(stdout); + Symbol.TRACE_OUTPUT.initializeSpecial(stdout); + Symbol.TERMINAL_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true)); + Symbol.QUERY_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true)); + Symbol.DEBUG_IO.initializeSpecial(new TwoWayStream(stdin, stdout, true)); + } + + public static final void resetIO(Stream in, Stream out) + { + stdin = in; + stdout = out; + Symbol.STANDARD_INPUT.setSymbolValue(stdin); + Symbol.STANDARD_OUTPUT.setSymbolValue(stdout); + Symbol.ERROR_OUTPUT.setSymbolValue(stdout); + Symbol.TRACE_OUTPUT.setSymbolValue(stdout); + Symbol.TERMINAL_IO.setSymbolValue(new TwoWayStream(stdin, stdout, true)); + Symbol.QUERY_IO.setSymbolValue(new TwoWayStream(stdin, stdout, true)); + Symbol.DEBUG_IO.setSymbolValue(new TwoWayStream(stdin, stdout, true)); + } + + // Used in org/armedbear/j/JLisp.java. + public static final void resetIO() + { + resetIO(new Stream(System.in, Symbol.CHARACTER, true), + new Stream(System.out, Symbol.CHARACTER, true)); + } + + public static final TwoWayStream getTerminalIO() + { + return (TwoWayStream) Symbol.TERMINAL_IO.symbolValueNoThrow(); + } + + public static final Stream getStandardInput() + { + return (Stream) Symbol.STANDARD_INPUT.symbolValueNoThrow(); + } + + public static final Stream getStandardOutput() throws ConditionThrowable + { + return checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue()); + } + + static + { + Symbol.CURRENT_READTABLE.initializeSpecial(new Readtable()); + } + + // ### +standard-readtable+ + // internal symbol + public static final Symbol STANDARD_READTABLE = + internConstant("+STANDARD-READTABLE+", PACKAGE_SYS, new Readtable()); + + public static final Readtable currentReadtable() throws ConditionThrowable + { + return (Readtable) Symbol.CURRENT_READTABLE.symbolValue(); + } + + static + { + Symbol.READ_SUPPRESS.initializeSpecial(NIL); + Symbol.DEBUGGER_HOOK.initializeSpecial(NIL); + } + + static + { + Symbol.MOST_POSITIVE_FIXNUM.initializeConstant(new Fixnum(Integer.MAX_VALUE)); + Symbol.MOST_NEGATIVE_FIXNUM.initializeConstant(new Fixnum(Integer.MIN_VALUE)); + Symbol.MOST_POSITIVE_JAVA_LONG.initializeConstant(new Bignum(Long.MAX_VALUE)); + Symbol.MOST_NEGATIVE_JAVA_LONG.initializeConstant(new Bignum(Long.MIN_VALUE)); + } + + public static void exit(int status) + { + Interpreter interpreter = Interpreter.getInstance(); + if (interpreter != null) + interpreter.kill(status); + } + + // ### t + public static final Symbol T = Symbol.T; + static + { + T.initializeConstant(T); + } + + static + { + Symbol.READ_EVAL.initializeSpecial(T); + } + + // ### *features* + static + { + Symbol.FEATURES.initializeSpecial(NIL); + String osName = System.getProperty("os.name"); + if (osName.startsWith("Linux")) + { + Symbol.FEATURES.setSymbolValue(list7(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.UNIX, + Keyword.LINUX, + Keyword.CDR6)); + } + else if (osName.startsWith("SunOS")) + { + Symbol.FEATURES.setSymbolValue(list7(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.UNIX, + Keyword.SUNOS, + Keyword.CDR6)); + } + else if (osName.startsWith("Mac OS X")) + { + Symbol.FEATURES.setSymbolValue(list7(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.UNIX, + Keyword.DARWIN, + Keyword.CDR6)); + } + else if (osName.startsWith("FreeBSD")) + { + Symbol.FEATURES.setSymbolValue(list7(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.UNIX, + Keyword.FREEBSD, + Keyword.CDR6)); + } + else if (osName.startsWith("Windows")) + { + Symbol.FEATURES.setSymbolValue(list6(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.WINDOWS, + Keyword.CDR6)); + } + else + { + Symbol.FEATURES.setSymbolValue(list5(Keyword.ARMEDBEAR, + Keyword.ABCL, + Keyword.COMMON_LISP, + Keyword.ANSI_CL, + Keyword.CDR6)); + } + } + static + { + final String version = System.getProperty("java.version"); + if (version.startsWith("1.5")) + { + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.JAVA_1_5, + Symbol.FEATURES.getSymbolValue())); + } + else if (version.startsWith("1.6")) + { + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.JAVA_1_6, + Symbol.FEATURES.getSymbolValue())); + } + else if (version.startsWith("1.7")) + { + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.JAVA_1_7, + Symbol.FEATURES.getSymbolValue())); + } + } + static + { + String os_arch = System.getProperty("os.arch"); + if (os_arch.equals("amd64")) + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86_64, + Symbol.FEATURES.getSymbolValue())); + else if (os_arch.equals("x86")) + Symbol.FEATURES.setSymbolValue(new Cons(Keyword.X86, + Symbol.FEATURES.getSymbolValue())); + } + + static + { + Symbol.MODULES.initializeSpecial(NIL); + } + + static + { + Symbol.LOAD_VERBOSE.initializeSpecial(NIL); + Symbol.LOAD_PRINT.initializeSpecial(NIL); + Symbol.LOAD_PATHNAME.initializeSpecial(NIL); + Symbol.LOAD_TRUENAME.initializeSpecial(NIL); + Symbol.COMPILE_VERBOSE.initializeSpecial(T); + Symbol.COMPILE_PRINT.initializeSpecial(T); + Symbol._COMPILE_FILE_PATHNAME_.initializeSpecial(NIL); + Symbol.COMPILE_FILE_TRUENAME.initializeSpecial(NIL); + } + + // ### *load-depth* + // internal symbol + public static final Symbol _LOAD_DEPTH_ = + internSpecial("*LOAD-DEPTH*", PACKAGE_SYS, Fixnum.ZERO); + + // ### *load-stream* + // internal symbol + public static final Symbol _LOAD_STREAM_ = + internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL); + + // ### *source* + // internal symbol + public static final Symbol _SOURCE_ = + exportSpecial("*SOURCE*", PACKAGE_SYS, NIL); + + // ### *source-position* + // internal symbol + public static final Symbol _SOURCE_POSITION_ = + exportSpecial("*SOURCE-POSITION*", PACKAGE_SYS, NIL); + + // ### *autoload-verbose* + // internal symbol + public static final Symbol _AUTOLOAD_VERBOSE_ = + exportSpecial("*AUTOLOAD-VERBOSE*", PACKAGE_EXT, NIL); + + // ### *compile-file-type* + public static final String COMPILE_FILE_TYPE = "abcl"; + public static final Symbol _COMPILE_FILE_TYPE_ = + internConstant("*COMPILE-FILE-TYPE*", PACKAGE_SYS, + new SimpleString(COMPILE_FILE_TYPE)); + + // ### *compile-file-zip* + public static final Symbol _COMPILE_FILE_ZIP_ = + exportSpecial("*COMPILE-FILE-ZIP*", PACKAGE_SYS, T); + + static + { + Symbol.MACROEXPAND_HOOK.initializeSpecial(Symbol.FUNCALL); + } + + public static final int ARRAY_DIMENSION_MAX = Integer.MAX_VALUE; + static + { + // ### array-dimension-limit + Symbol.ARRAY_DIMENSION_LIMIT.initializeConstant(new Fixnum(ARRAY_DIMENSION_MAX)); + } + + // ### char-code-limit + // "The upper exclusive bound on the value returned by the function CHAR-CODE." + public static final int CHAR_MAX = 256; + static + { + Symbol.CHAR_CODE_LIMIT.initializeConstant(new Fixnum(CHAR_MAX)); + } + + static + { + Symbol.READ_BASE.initializeSpecial(Fixnum.constants[10]); + } + + static + { + Symbol.READ_DEFAULT_FLOAT_FORMAT.initializeSpecial(Symbol.SINGLE_FLOAT); + } + + // Printer control variables. + static + { + Symbol.PRINT_ARRAY.initializeSpecial(T); + Symbol.PRINT_BASE.initializeSpecial(Fixnum.constants[10]); + Symbol.PRINT_CASE.initializeSpecial(Keyword.UPCASE); + Symbol.PRINT_CIRCLE.initializeSpecial(NIL); + Symbol.PRINT_ESCAPE.initializeSpecial(T); + Symbol.PRINT_GENSYM.initializeSpecial(T); + Symbol.PRINT_LENGTH.initializeSpecial(NIL); + Symbol.PRINT_LEVEL.initializeSpecial(NIL); + Symbol.PRINT_LINES.initializeSpecial(NIL); + Symbol.PRINT_MISER_WIDTH.initializeSpecial(NIL); + Symbol.PRINT_PPRINT_DISPATCH.initializeSpecial(NIL); + Symbol.PRINT_PRETTY.initializeSpecial(NIL); + Symbol.PRINT_RADIX.initializeSpecial(NIL); + Symbol.PRINT_READABLY.initializeSpecial(NIL); + Symbol.PRINT_RIGHT_MARGIN.initializeSpecial(NIL); + } + + public static final Symbol _PRINT_STRUCTURE_ = + exportSpecial("*PRINT-STRUCTURE*", PACKAGE_EXT, T); + + // ### *current-print-length* + public static final Symbol _CURRENT_PRINT_LENGTH_ = + exportSpecial("*CURRENT-PRINT-LENGTH*", PACKAGE_SYS, Fixnum.ZERO); + + // ### *current-print-level* + public static final Symbol _CURRENT_PRINT_LEVEL_ = + exportSpecial("*CURRENT-PRINT-LEVEL*", PACKAGE_SYS, Fixnum.ZERO); + + public static final Symbol _PRINT_FASL_ = + internSpecial("*PRINT-FASL*", PACKAGE_SYS, NIL); + + static + { + Symbol._RANDOM_STATE_.initializeSpecial(new RandomState()); + } + + static + { + Symbol.STAR.initializeSpecial(NIL); + Symbol.STAR_STAR.initializeSpecial(NIL); + Symbol.STAR_STAR_STAR.initializeSpecial(NIL); + Symbol.MINUS.initializeSpecial(NIL); + Symbol.PLUS.initializeSpecial(NIL); + Symbol.PLUS_PLUS.initializeSpecial(NIL); + Symbol.PLUS_PLUS_PLUS.initializeSpecial(NIL); + Symbol.SLASH.initializeSpecial(NIL); + Symbol.SLASH_SLASH.initializeSpecial(NIL); + Symbol.SLASH_SLASH_SLASH.initializeSpecial(NIL); + } + + // Floating point constants. + static + { + Symbol.PI.initializeConstant(new DoubleFloat(Math.PI)); + Symbol.SHORT_FLOAT_EPSILON.initializeConstant(new SingleFloat((float)5.960465E-8)); + Symbol.SINGLE_FLOAT_EPSILON.initializeConstant(new SingleFloat((float)5.960465E-8)); + Symbol.DOUBLE_FLOAT_EPSILON.initializeConstant(new DoubleFloat((double)1.1102230246251568E-16)); + Symbol.LONG_FLOAT_EPSILON.initializeConstant(new DoubleFloat((double)1.1102230246251568E-16)); + Symbol.SHORT_FLOAT_NEGATIVE_EPSILON.initializeConstant(new SingleFloat(2.9802326e-8f)); + Symbol.SINGLE_FLOAT_NEGATIVE_EPSILON.initializeConstant(new SingleFloat(2.9802326e-8f)); + Symbol.DOUBLE_FLOAT_NEGATIVE_EPSILON.initializeConstant(new DoubleFloat((double)5.551115123125784E-17)); + Symbol.LONG_FLOAT_NEGATIVE_EPSILON.initializeConstant(new DoubleFloat((double)5.551115123125784E-17)); + Symbol.MOST_POSITIVE_SHORT_FLOAT.initializeConstant(new SingleFloat(Float.MAX_VALUE)); + Symbol.MOST_POSITIVE_SINGLE_FLOAT.initializeConstant(new SingleFloat(Float.MAX_VALUE)); + Symbol.MOST_POSITIVE_DOUBLE_FLOAT.initializeConstant(new DoubleFloat(Double.MAX_VALUE)); + Symbol.MOST_POSITIVE_LONG_FLOAT.initializeConstant(new DoubleFloat(Double.MAX_VALUE)); + Symbol.LEAST_POSITIVE_SHORT_FLOAT.initializeConstant(new SingleFloat(Float.MIN_VALUE)); + Symbol.LEAST_POSITIVE_SINGLE_FLOAT.initializeConstant(new SingleFloat(Float.MIN_VALUE)); + Symbol.LEAST_POSITIVE_DOUBLE_FLOAT.initializeConstant(new DoubleFloat(Double.MIN_VALUE)); + Symbol.LEAST_POSITIVE_LONG_FLOAT.initializeConstant(new DoubleFloat(Double.MIN_VALUE)); + Symbol.LEAST_POSITIVE_NORMALIZED_SHORT_FLOAT.initializeConstant(new SingleFloat(1.17549435e-38f)); + Symbol.LEAST_POSITIVE_NORMALIZED_SINGLE_FLOAT.initializeConstant(new SingleFloat(1.17549435e-38f)); + Symbol.LEAST_POSITIVE_NORMALIZED_DOUBLE_FLOAT.initializeConstant(new DoubleFloat(2.2250738585072014e-308d)); + Symbol.LEAST_POSITIVE_NORMALIZED_LONG_FLOAT.initializeConstant(new DoubleFloat(2.2250738585072014e-308d)); + Symbol.MOST_NEGATIVE_SHORT_FLOAT.initializeConstant(new SingleFloat(- Float.MAX_VALUE)); + Symbol.MOST_NEGATIVE_SINGLE_FLOAT.initializeConstant(new SingleFloat(- Float.MAX_VALUE)); + Symbol.MOST_NEGATIVE_DOUBLE_FLOAT.initializeConstant(new DoubleFloat(- Double.MAX_VALUE)); + Symbol.MOST_NEGATIVE_LONG_FLOAT.initializeConstant(new DoubleFloat(- Double.MAX_VALUE)); + Symbol.LEAST_NEGATIVE_SHORT_FLOAT.initializeConstant(new SingleFloat(- Float.MIN_VALUE)); + Symbol.LEAST_NEGATIVE_SINGLE_FLOAT.initializeConstant(new SingleFloat(- Float.MIN_VALUE)); + Symbol.LEAST_NEGATIVE_DOUBLE_FLOAT.initializeConstant(new DoubleFloat(- Double.MIN_VALUE)); + Symbol.LEAST_NEGATIVE_LONG_FLOAT.initializeConstant(new DoubleFloat(- Double.MIN_VALUE)); + Symbol.LEAST_NEGATIVE_NORMALIZED_SHORT_FLOAT.initializeConstant(new SingleFloat(-1.17549435e-38f)); + Symbol.LEAST_NEGATIVE_NORMALIZED_SINGLE_FLOAT.initializeConstant(new SingleFloat(-1.17549435e-38f)); + Symbol.LEAST_NEGATIVE_NORMALIZED_DOUBLE_FLOAT.initializeConstant(new DoubleFloat(-2.2250738585072014e-308d)); + Symbol.LEAST_NEGATIVE_NORMALIZED_LONG_FLOAT.initializeConstant(new DoubleFloat(-2.2250738585072014e-308d)); + } + + static + { + Symbol.BOOLE_CLR.initializeConstant(Fixnum.ZERO); + Symbol.BOOLE_SET.initializeConstant(Fixnum.ONE); + Symbol.BOOLE_1.initializeConstant(Fixnum.TWO); + Symbol.BOOLE_2.initializeConstant(Fixnum.constants[3]); + Symbol.BOOLE_C1.initializeConstant(Fixnum.constants[4]); + Symbol.BOOLE_C2.initializeConstant(Fixnum.constants[5]); + Symbol.BOOLE_AND.initializeConstant(Fixnum.constants[6]); + Symbol.BOOLE_IOR.initializeConstant(Fixnum.constants[7]); + Symbol.BOOLE_XOR.initializeConstant(Fixnum.constants[8]); + Symbol.BOOLE_EQV.initializeConstant(Fixnum.constants[9]); + Symbol.BOOLE_NAND.initializeConstant(Fixnum.constants[10]); + Symbol.BOOLE_NOR.initializeConstant(Fixnum.constants[11]); + Symbol.BOOLE_ANDC1.initializeConstant(Fixnum.constants[12]); + Symbol.BOOLE_ANDC2.initializeConstant(Fixnum.constants[13]); + Symbol.BOOLE_ORC1.initializeConstant(Fixnum.constants[14]); + Symbol.BOOLE_ORC2.initializeConstant(Fixnum.constants[15]); + } + + static + { + // ### call-arguments-limit + Symbol.CALL_ARGUMENTS_LIMIT.initializeConstant(Fixnum.constants[50]); + } + + static + { + // ### lambda-parameters-limit + Symbol.LAMBDA_PARAMETERS_LIMIT.initializeConstant(Fixnum.constants[50]); + } + + static + { + // ### multiple-values-limit + Symbol.MULTIPLE_VALUES_LIMIT.initializeConstant(Fixnum.constants[20]); + } + + static + { + // ### internal-time-units-per-second + Symbol.INTERNAL_TIME_UNITS_PER_SECOND.initializeConstant(new Fixnum(1000)); + } + + // ### call-registers-limit + public static final Symbol CALL_REGISTERS_LIMIT = + exportConstant("CALL-REGISTERS-LIMIT", PACKAGE_SYS, + Fixnum.constants[CALL_REGISTERS_MAX]); + + // ### *warn-on-redefinition* + public static final Symbol _WARN_ON_REDEFINITION_ = + exportSpecial("*WARN-ON-REDEFINITION*", PACKAGE_EXT, T); + + // ### *saved-backtrace* + public static final Symbol _SAVED_BACKTRACE_ = + exportSpecial("*SAVED-BACKTRACE*", PACKAGE_EXT, NIL); + + // ### *batch-mode* + public static final Symbol _BATCH_MODE_ = + exportSpecial("*BATCH-MODE*", PACKAGE_EXT, NIL); + + // ### *noinform* + public static final Symbol _NOINFORM_ = + exportSpecial("*NOINFORM*", PACKAGE_SYS, NIL); + + // ### *disassembler* + public static final Symbol _DISASSEMBLER_ = + exportSpecial("*DISASSEMBLER*", PACKAGE_EXT, + new SimpleString("jad -a -p")); // or "jad -dis -p" + + // ### *speed* compiler policy + public static final Symbol _SPEED_ = + exportSpecial("*SPEED*", PACKAGE_SYS, Fixnum.ONE); + + // ### *space* compiler policy + public static final Symbol _SPACE_ = + exportSpecial("*SPACE*", PACKAGE_SYS, Fixnum.ONE); + + // ### *safety* compiler policy + public static final Symbol _SAFETY_ = + exportSpecial("*SAFETY*", PACKAGE_SYS, Fixnum.ONE); + + // ### *debug* compiler policy + public static final Symbol _DEBUG_ = + exportSpecial("*DEBUG*", PACKAGE_SYS, Fixnum.ONE); + + // ### *explain* compiler policy + public static final Symbol _EXPLAIN_ = + exportSpecial("*EXPLAIN*", PACKAGE_SYS, NIL); + + // ### *enable-inline-expansion* + public static final Symbol _ENABLE_INLINE_EXPANSION_ = + exportSpecial("*ENABLE-INLINE-EXPANSION*", PACKAGE_EXT, T); + + // ### *require-stack-frame* + public static final Symbol _REQUIRE_STACK_FRAME_ = + exportSpecial("*REQUIRE-STACK-FRAME*", PACKAGE_EXT, NIL); + + static + { + Symbol.SUPPRESS_COMPILER_WARNINGS.initializeSpecial(NIL); + } + + public static final Symbol _COMPILE_FILE_ENVIRONMENT_ = + exportSpecial("*COMPILE-FILE-ENVIRONMENT*", PACKAGE_SYS, NIL); + + public static final LispObject UNBOUND_VALUE = new LispObject() + { + @Override + public String writeToString() + { + return "#"; + } + }; + + public static final LispObject NULL_VALUE = new LispObject() + { + @Override + public String writeToString() + { + return "null"; + } + }; + + public static final Symbol _SLOT_UNBOUND_ = + exportConstant("+SLOT-UNBOUND+", PACKAGE_SYS, UNBOUND_VALUE); + + public static final Symbol _CL_PACKAGE_ = + exportConstant("+CL-PACKAGE+", PACKAGE_SYS, PACKAGE_CL); + + public static final Symbol _KEYWORD_PACKAGE_ = + exportConstant("+KEYWORD-PACKAGE+", PACKAGE_SYS, PACKAGE_KEYWORD); + + // ### *backquote-count* + public static final Symbol _BACKQUOTE_COUNT_ = + internSpecial("*BACKQUOTE-COUNT*", PACKAGE_SYS, Fixnum.ZERO); + + // ### *bq-vector-flag* + public static final Symbol _BQ_VECTOR_FLAG_ = + internSpecial("*BQ-VECTOR-FLAG*", PACKAGE_SYS, list1(new Symbol("bqv"))); + + // ### *traced-names* + public static final Symbol _TRACED_NAMES_ = + exportSpecial("*TRACED-NAMES*", PACKAGE_SYS, NIL); + + // Floating point traps. + protected static boolean TRAP_OVERFLOW = true; + protected static boolean TRAP_UNDERFLOW = true; + + + // Extentions + static { + Symbol._INSPECTOR_HOOK_.initializeSpecial(NIL); + } + + private static final void loadClass(String className) + { + try + { + Class.forName(className); + } + catch (ClassNotFoundException e) + { + e.printStackTrace(); + } + } + + static + { + loadClass("org.armedbear.lisp.Primitives"); + loadClass("org.armedbear.lisp.SpecialOperators"); + loadClass("org.armedbear.lisp.Extensions"); + loadClass("org.armedbear.lisp.CompiledFunction"); + loadClass("org.armedbear.lisp.Autoload"); + loadClass("org.armedbear.lisp.AutoloadMacro"); + loadClass("org.armedbear.lisp.cxr"); + loadClass("org.armedbear.lisp.Do"); + loadClass("org.armedbear.lisp.dolist"); + loadClass("org.armedbear.lisp.dotimes"); + loadClass("org.armedbear.lisp.Pathname"); + loadClass("org.armedbear.lisp.LispClass"); + loadClass("org.armedbear.lisp.BuiltInClass"); + loadClass("org.armedbear.lisp.StructureObject"); + loadClass("org.armedbear.lisp.ash"); + loadClass("org.armedbear.lisp.Java"); + cold = false; + } +} Added: branches/save-image/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispCharacter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,753 @@ +/* + * LispCharacter.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: LispCharacter.java 11573 2009-01-21 22:14:47Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class LispCharacter extends LispObject +{ + public static final LispCharacter[] constants = new LispCharacter[CHAR_MAX]; + + static + { + for (int i = constants.length; i-- > 0;) + constants[i] = new LispCharacter((char)i); + } + + public final char value; + + public static LispCharacter getInstance(char c) + { + try + { + return constants[c]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return new LispCharacter(c); + } + } + + // This needs to be public for the compiler. + public LispCharacter(char c) + { + this.value = c; + } + + @Override + public LispObject typeOf() + { + if (isStandardChar()) + return Symbol.STANDARD_CHAR; + return Symbol.CHARACTER; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.CHARACTER; + } + + @Override + public LispObject getDescription() + { + FastStringBuffer sb = new FastStringBuffer("character #\\"); + sb.append(value); + sb.append(" char-code #x"); + sb.append(Integer.toHexString(value)); + return new SimpleString(sb); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.CHARACTER) + return T; + if (type == BuiltInClass.CHARACTER) + return T; + if (type == Symbol.BASE_CHAR) + return T; + if (type == Symbol.STANDARD_CHAR) + return isStandardChar() ? T : NIL; + return super.typep(type); + } + + @Override + public LispObject CHARACTERP() + { + return T; + } + + @Override + public boolean characterp() + { + return true; + } + + @Override + public LispObject STRING() + { + return new SimpleString(value); + } + + private boolean isStandardChar() + { + if (value >= ' ' && value < 127) + return true; + if (value == '\n') + return true; + return false; + } + + @Override + public boolean eql(char c) + { + return value == c; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof LispCharacter) + { + if (value == ((LispCharacter)obj).value) + return true; + } + return false; + } + + @Override + public boolean equal(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof LispCharacter) + { + if (value == ((LispCharacter)obj).value) + return true; + } + return false; + } + + @Override + public boolean equalp(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof LispCharacter) + { + if (value == ((LispCharacter)obj).value) + return true; + return LispCharacter.toLowerCase(value) == LispCharacter.toLowerCase(((LispCharacter)obj).value); + } + return false; + } + + public static char getValue(LispObject obj) throws ConditionThrowable + { + try + { + return ((LispCharacter)obj).value; + } + catch (ClassCastException e) + { + type_error(obj, Symbol.CHARACTER); + // Not reached. + return 0; + } + } + + public final char getValue() + { + return value; + } + + @Override + public Object javaInstance() + { + return Character.valueOf(value); + } + + @Override + public Object javaInstance(Class c) + { + return javaInstance(); + } + + @Override + public int sxhash() + { + return value; + } + + @Override + public int psxhash() + { + return Character.toUpperCase(value); + } + + @Override + public final String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + // "Specifically, if *PRINT-READABLY* is true, printing proceeds as if + // *PRINT-ESCAPE*, *PRINT-ARRAY*, and *PRINT-GENSYM* were also true, + // and as if *PRINT-LENGTH*, *PRINT-LEVEL*, and *PRINT-LINES* were + // false." + boolean printEscape = + printReadably || (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + FastStringBuffer sb = new FastStringBuffer(); + if (printEscape) + { + sb.append("#\\"); + switch (value) + { + case 0: + sb.append("Null"); + break; + case 7: + sb.append("Bell"); + break; + case '\b': + sb.append("Backspace"); + break; + case '\t': + sb.append("Tab"); + break; + case '\n': + sb.append("Newline"); + break; + case '\f': + sb.append("Page"); + break; + case '\r': + sb.append("Return"); + break; + case 127: + sb.append("Rubout"); + break; + default: + sb.append(value); + break; + } + } + else + { + sb.append(value); + } + return sb.toString(); + } + + // ### character + private static final Primitive CHARACTER = + new Primitive(Symbol.CHARACTER, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + return arg; + if (arg instanceof AbstractString) + { + if (arg.length() == 1) + return ((AbstractString)arg).AREF(0); + } + else if (arg instanceof Symbol) + { + String name = ((Symbol)arg).getName(); + if (name.length() == 1) + return LispCharacter.getInstance(name.charAt(0)); + } + return type_error(arg, Symbol.CHARACTER_DESIGNATOR); + } + }; + + // ### whitespacep + private static final Primitive WHITESPACEP = + new Primitive("whitespacep", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return Character.isWhitespace(((LispCharacter)arg).value) ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + // ### char-code + private static final Primitive CHAR_CODE = + new Primitive(Symbol.CHAR_CODE, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + int n = ((LispCharacter)arg).value; + return n < 256 ? Fixnum.constants[n] : new Fixnum(n); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + // ### char-int + private static final Primitive CHAR_INT = + new Primitive(Symbol.CHAR_INT, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + int n = ((LispCharacter)arg).value; + return n < 256 ? Fixnum.constants[n] : new Fixnum(n); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + // ### code-char + private static final Primitive CODE_CHAR = + new Primitive(Symbol.CODE_CHAR, "code") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + int n = ((Fixnum)arg).value; + if (n < CHAR_MAX) + return constants[n]; + else if (n <= Character.MAX_VALUE) + return new LispCharacter((char)n); + } + catch (ClassCastException e) + { + // SBCL signals a type-error here: "not of type (UNSIGNED-BYTE 8)" + } + return NIL; + } + }; + + // ### characterp + private static final Primitive CHARACTERP = + new Primitive(Symbol.CHARACTERP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof LispCharacter ? T : NIL; + } + }; + + // ### both-case-p + private static final Primitive BOTH_CASE_P = + new Primitive(Symbol.BOTH_CASE_P, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + char c = getValue(arg); + if (Character.isLowerCase(c) || Character.isUpperCase(c)) + return T; + return NIL; + } + }; + + // ### lower-case-p + private static final Primitive LOWER_CASE_P = + new Primitive(Symbol.LOWER_CASE_P, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Character.isLowerCase(getValue(arg)) ? T : NIL; + } + }; + + // ### upper-case-p + private static final Primitive UPPER_CASE_P = + new Primitive(Symbol.UPPER_CASE_P, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Character.isUpperCase(getValue(arg)) ? T : NIL; + } + }; + + // ### char-downcase + private static final Primitive CHAR_DOWNCASE = + new Primitive(Symbol.CHAR_DOWNCASE, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + char c; + try + { + c = ((LispCharacter)arg).value; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + if (c < 128) + return constants[LOWER_CASE_CHARS[c]]; + return LispCharacter.getInstance(toLowerCase(c)); + } + }; + + // ### char-upcase + private static final Primitive CHAR_UPCASE = + new Primitive(Symbol.CHAR_UPCASE, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final char c; + try + { + c = ((LispCharacter)arg).value; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + if (c < 128) + return constants[UPPER_CASE_CHARS[c]]; + return LispCharacter.getInstance(toUpperCase(c)); + } + }; + + // ### digit-char + private static final Primitive DIGIT_CHAR = + new Primitive(Symbol.DIGIT_CHAR, "weight &optional radix") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + int weight; + try + { + weight = ((Fixnum)arg).value; + } + catch (ClassCastException e) + { + if (arg instanceof Bignum) + return NIL; + return type_error(arg, Symbol.INTEGER); + } + if (weight < 10) + return constants['0' + weight]; + return NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + int radix; + try + { + radix = ((Fixnum)second).value; + } + catch (ClassCastException e) + { + radix = -1; + } + if (radix < 2 || radix > 36) + return type_error(second, + list3(Symbol.INTEGER, Fixnum.TWO, + Fixnum.constants[36])); + int weight; + try + { + weight = ((Fixnum)first).value; + } + catch (ClassCastException e) + { + if (first instanceof Bignum) + return NIL; + return type_error(first, Symbol.INTEGER); + } + if (weight >= radix) + return NIL; + if (weight < 10) + return constants['0' + weight]; + return constants['A' + weight - 10]; + } + }; + + // ### digit-char-p char &optional radix => weight + private static final Primitive DIGIT_CHAR_P = + new Primitive(Symbol.DIGIT_CHAR_P, "char &optional radix") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + int n = Character.digit(((LispCharacter)arg).value, 10); + return n < 0 ? NIL : Fixnum.constants[n]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char c; + try + { + c = ((LispCharacter)first).value; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CHARACTER); + } + try + { + int radix = ((Fixnum)second).value; + if (radix >= 2 && radix <= 36) + { + int n = Character.digit(c, radix); + return n < 0 ? NIL : Fixnum.constants[n]; + } + } + catch (ClassCastException e) {} + return type_error(second, + list3(Symbol.INTEGER, Fixnum.TWO, + Fixnum.constants[36])); + } + }; + + // ### standard-char-p + private static final Primitive STANDARD_CHAR_P = + new Primitive(Symbol.STANDARD_CHAR_P, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((LispCharacter)arg).isStandardChar() ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + // ### graphic-char-p + private static final Primitive GRAPHIC_CHAR_P = + new Primitive(Symbol.GRAPHIC_CHAR_P, "char") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + char c = ((LispCharacter)arg).value; + if (c >= ' ' && c < 127) + return T; + return Character.isISOControl(c) ? NIL : T; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + // ### alpha-char-p + private static final Primitive ALPHA_CHAR_P = + new Primitive(Symbol.ALPHA_CHAR_P, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return Character.isLetter(((LispCharacter)arg).value) ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + // ### alphanumericp + private static final Primitive ALPHANUMERICP = + new Primitive(Symbol.ALPHANUMERICP, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return Character.isLetterOrDigit(((LispCharacter)arg).value) ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + } + }; + + public static final int nameToChar(String s) + { + String lower = s.toLowerCase(); + if (lower.equals("null")) + return 0; + if (lower.equals("bell")) + return 7; + if (lower.equals("backspace")) + return '\b'; + if (lower.equals("tab")) + return '\t'; + if (lower.equals("linefeed")) + return '\n'; + if (lower.equals("newline")) + return '\n'; + if (lower.equals("page")) + return '\f'; + if (lower.equals("return")) + return '\r'; + if (lower.equals("space")) + return ' '; + if (lower.equals("rubout")) + return 127; + // Unknown. + return -1; + } + + // ### name-char + private static final Primitive NAME_CHAR = + new Primitive(Symbol.NAME_CHAR, "name") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + String s = arg.STRING().getStringValue(); + int n = nameToChar(s); + return n >= 0 ? LispCharacter.getInstance((char)n) : NIL; + } + }; + + public static final String charToName(char c) + { + switch (c) + { + case 0: + return "Null"; + case 7: + return "Bell"; + case '\b': + return "Backspace"; + case '\t': + return "Tab"; + case '\n': + return "Newline"; + case '\f': + return "Page"; + case '\r': + return "Return"; + case ' ': + return "Space"; + case 127: + return "Rubout"; + } + return null; + } + + // ### char-name + private static final Primitive CHAR_NAME = + new Primitive(Symbol.CHAR_NAME, "character") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + String name = charToName(LispCharacter.getValue(arg)); + return name != null ? new SimpleString(name) : NIL; + } + }; + + public static final char toUpperCase(char c) + { + if (c < 128) + return UPPER_CASE_CHARS[c]; + return Character.toUpperCase(c); + } + + private static final char[] UPPER_CASE_CHARS = new char[128]; + + static + { + for (int i = UPPER_CASE_CHARS.length; i-- > 0;) + UPPER_CASE_CHARS[i] = Character.toUpperCase((char)i); + } + + public static final char toLowerCase(char c) + { + if (c < 128) + return LOWER_CASE_CHARS[c]; + return Character.toLowerCase(c); + } + + private static final char[] LOWER_CASE_CHARS = new char[128]; + + static + { + for (int i = LOWER_CASE_CHARS.length; i-- > 0;) + LOWER_CASE_CHARS[i] = Character.toLowerCase((char)i); + } +} Added: branches/save-image/src/org/armedbear/lisp/LispClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,414 @@ +/* + * LispClass.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: LispClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class LispClass extends StandardObject +{ + private static final EqHashTable map = new EqHashTable(256, NIL, NIL); + + public static void addClass(Symbol symbol, LispClass c) + { + synchronized (map) + { + map.put(symbol, c); + } + } + + public static void removeClass(Symbol symbol) + { + synchronized (map) + { + map.remove(symbol); + } + } + + public static LispClass findClass(Symbol symbol) + { + synchronized (map) + { + return (LispClass) map.get(symbol); + } + } + + public static LispObject findClass(LispObject name, boolean errorp) + throws ConditionThrowable + { + final Symbol symbol; + try + { + symbol = (Symbol) name; + } + catch (ClassCastException e) + { + return type_error(name, Symbol.SYMBOL); + } + final LispClass c; + synchronized (map) + { + c = (LispClass) map.get(symbol); + } + if (c != null) + return c; + if (errorp) + { + FastStringBuffer sb = + new FastStringBuffer("There is no class named "); + sb.append(name.writeToString()); + sb.append('.'); + return error(new LispError(sb.toString())); + } + return NIL; + } + + private final int sxhash; + + protected Symbol symbol; + private LispObject propertyList; + private Layout classLayout; + private LispObject directSuperclasses = NIL; + private LispObject directSubclasses = NIL; + public LispObject classPrecedenceList = NIL; // FIXME! Should be private! + public LispObject directMethods = NIL; // FIXME! Should be private! + public LispObject documentation = NIL; // FIXME! Should be private! + private boolean finalized; + + protected LispClass() + { + sxhash = hashCode() & 0x7fffffff; + } + + protected LispClass(Symbol symbol) + { + sxhash = hashCode() & 0x7fffffff; + this.symbol = symbol; + this.directSuperclasses = NIL; + } + + protected LispClass(Symbol symbol, LispObject directSuperclasses) + { + sxhash = hashCode() & 0x7fffffff; + this.symbol = symbol; + this.directSuperclasses = directSuperclasses; + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject result = NIL; + result = result.push(new Cons("NAME", symbol != null ? symbol : NIL)); + result = result.push(new Cons("LAYOUT", classLayout != null ? classLayout : NIL)); + result = result.push(new Cons("DIRECT-SUPERCLASSES", directSuperclasses)); + result = result.push(new Cons("DIRECT-SUBCLASSES", directSubclasses)); + result = result.push(new Cons("CLASS-PRECEDENCE-LIST", classPrecedenceList)); + result = result.push(new Cons("DIRECT-METHODS", directMethods)); + result = result.push(new Cons("DOCUMENTATION", documentation)); + return result.nreverse(); + } + + @Override + public final int sxhash() + { + return sxhash; + } + + public final Symbol getSymbol() + { + return symbol; + } + + @Override + public final LispObject getPropertyList() + { + if (propertyList == null) + propertyList = NIL; + return propertyList; + } + + @Override + public final void setPropertyList(LispObject obj) + { + if (obj == null) + throw new NullPointerException(); + propertyList = obj; + } + + public final Layout getClassLayout() + { + return classLayout; + } + + public final void setClassLayout(Layout layout) + { + classLayout = layout; + } + + public final int getLayoutLength() + { + if (layout == null) + return 0; + return layout.getLength(); + } + + public final LispObject getDirectSuperclasses() + { + return directSuperclasses; + } + + public final void setDirectSuperclasses(LispObject directSuperclasses) + { + this.directSuperclasses = directSuperclasses; + } + + public final boolean isFinalized() + { + return finalized; + } + + public final void setFinalized(boolean b) + { + finalized = b; + } + + // When there's only one direct superclass... + public final void setDirectSuperclass(LispObject superclass) + { + directSuperclasses = new Cons(superclass); + } + + public final LispObject getDirectSubclasses() + { + return directSubclasses; + } + + public final void setDirectSubclasses(LispObject directSubclasses) + { + this.directSubclasses = directSubclasses; + } + + public final LispObject getCPL() + { + return classPrecedenceList; + } + + public final void setCPL(LispObject obj1) + { + if (obj1 instanceof Cons) + classPrecedenceList = obj1; + else + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = new Cons(obj1); + } + } + + public final void setCPL(LispObject obj1, LispObject obj2) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = list2(obj1, obj2); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = list3(obj1, obj2, obj3); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, + LispObject obj4) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = list4(obj1, obj2, obj3, obj4); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, + LispObject obj4, LispObject obj5) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = list5(obj1, obj2, obj3, obj4, obj5); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, + LispObject obj4, LispObject obj5, LispObject obj6) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = list6(obj1, obj2, obj3, obj4, obj5, obj6); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, + LispObject obj4, LispObject obj5, LispObject obj6, + LispObject obj7) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = list7(obj1, obj2, obj3, obj4, obj5, obj6, obj7); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, + LispObject obj4, LispObject obj5, LispObject obj6, + LispObject obj7, LispObject obj8) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = + list8(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8); + } + + public final void setCPL(LispObject obj1, LispObject obj2, LispObject obj3, + LispObject obj4, LispObject obj5, LispObject obj6, + LispObject obj7, LispObject obj8, LispObject obj9) + { + Debug.assertTrue(obj1 == this); + classPrecedenceList = + list9(obj1, obj2, obj3, obj4, obj5, obj6, obj7, obj8, obj9); + } + + public String getName() + { + return symbol.getName(); + } + + @Override + public LispObject typeOf() + { + return Symbol.CLASS; + } + + @Override + public LispObject classOf() + { + return StandardClass.CLASS; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.CLASS) + return T; + if (type == StandardClass.CLASS) + return T; + return super.typep(type); + } + + public boolean subclassp(LispObject obj) throws ConditionThrowable + { + LispObject cpl = classPrecedenceList; + while (cpl != NIL) + { + if (cpl.car() == obj) + return true; + cpl = ((Cons)cpl).cdr; + } + return false; + } + + // ### find-class symbol &optional errorp environment => class + private static final Primitive FIND_CLASS = + new Primitive(Symbol.FIND_CLASS, "symbol &optional errorp environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return findClass(arg, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return findClass(first, second != NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + // FIXME Use environment! + return findClass(first, second != NIL); + } + }; + + // ### %set-find-class + private static final Primitive _SET_FIND_CLASS = + new Primitive("%set-find-class", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Symbol name; + try + { + name = (Symbol) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + if (second == NIL) + { + removeClass(name); + return second; + } + final LispClass c; + try + { + c = (LispClass) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.CLASS); + } + addClass(name, c); + return second; + } + }; + + // ### subclassp + private static final Primitive SUBCLASSP = + new Primitive(Symbol.SUBCLASSP, "class") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final LispClass c; + try + { + c = (LispClass) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + return c.subclassp(second) ? T : NIL; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/LispError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,80 @@ +/* + * LispError.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: LispError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class LispError extends SeriousCondition +{ + public LispError() throws ConditionThrowable + { + } + + protected LispError(LispClass cls) throws ConditionThrowable + { + super(cls); + } + + public LispError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.ERROR); + initialize(initArgs); + } + + public LispError(String message) throws ConditionThrowable + { + super(StandardClass.ERROR); + setFormatControl(message); + } + + @Override + public LispObject typeOf() + { + return Symbol.ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.ERROR) + return T; + if (type == StandardClass.ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/LispInteger.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispInteger.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,54 @@ +/* + * LispInteger.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Bignum.java 11573 2009-01-21 22:14:47Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +/** This class merely serves as the super class for + * Fixnum and Bignum + */ +public class LispInteger extends LispObject +{ + + public static LispInteger getInstance(long l) { + if (Integer.MIN_VALUE <= l && l <= Integer.MAX_VALUE) + return Fixnum.getInstance((int)l); + else + return new Bignum(l); + } + + public static LispInteger getInstance(int i) { + return Fixnum.getInstance(i); + } + + +} Added: branches/save-image/src/org/armedbear/lisp/LispObject.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispObject.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1164 @@ +/* + * LispObject.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: LispObject.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class LispObject extends Lisp implements java.io.Serializable +{ + public LispObject typeOf() + { + return T; + } + + static public LispObject getInstance(boolean b) { + return b ? T : NIL; + } + + public LispObject classOf() + { + return BuiltInClass.CLASS_T; + } + + public LispObject getDescription() throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("An object of type "); + sb.append(typeOf().writeToString()); + sb.append(" at #x"); + sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); + return new SimpleString(sb); + } + + public LispObject getParts() throws ConditionThrowable + { + return NIL; + } + + public boolean getBooleanValue() + { + return true; + } + + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == T) + return T; + if (typeSpecifier == BuiltInClass.CLASS_T) + return T; + if (typeSpecifier == Symbol.ATOM) + return T; + return NIL; + } + + public boolean constantp() + { + return true; + } + + public LispObject CONSTANTP() + { + return constantp() ? T : NIL; + } + + public LispObject ATOM() + { + return T; + } + + public boolean atom() + { + return true; + } + + public Object javaInstance() throws ConditionThrowable + { + return this; + /*return error(new LispError("The value " + writeToString() + + " is not of primitive type."));*/ + } + + public Object javaInstance(Class c) throws ConditionThrowable + { + if (c.isAssignableFrom(this.getClass())) { + return this; + } + return error(new LispError("The value " + writeToString() + + " is not of type " + c.getName())); + } + + public LispObject car() throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public void setCar(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.CONS); + } + + public LispObject RPLACA(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.CONS); + } + + public LispObject cdr() throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public void setCdr(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.CONS); + } + + public LispObject RPLACD(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.CONS); + } + + public LispObject cadr() throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject cddr() throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject caddr() throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject nthcdr(int n) throws ConditionThrowable + { + if (n < 0) + return type_error(new Fixnum(n), + list2(Symbol.INTEGER, Fixnum.ZERO)); + return type_error(this, Symbol.LIST); + } + + public LispObject push(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject EQ(LispObject obj) + { + return this == obj ? T : NIL; + } + + public boolean eql(char c) + { + return false; + } + + public boolean eql(int n) + { + return false; + } + + public boolean eql(LispObject obj) + { + return this == obj; + } + + public final LispObject EQL(LispObject obj) + { + return eql(obj) ? T : NIL; + } + + public final LispObject EQUAL(LispObject obj) throws ConditionThrowable + { + return equal(obj) ? T : NIL; + } + + public boolean equal(int n) + { + return false; + } + + public boolean equal(LispObject obj) throws ConditionThrowable + { + return this == obj; + } + + public boolean equalp(int n) + { + return false; + } + + public boolean equalp(LispObject obj) throws ConditionThrowable + { + return this == obj; + } + + public LispObject ABS() throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public LispObject NUMERATOR() throws ConditionThrowable + { + return type_error(this, Symbol.RATIONAL); + } + + public LispObject DENOMINATOR() throws ConditionThrowable + { + return type_error(this, Symbol.RATIONAL); + } + + public LispObject EVENP() throws ConditionThrowable + { + return evenp() ? T : NIL; + } + + public boolean evenp() throws ConditionThrowable + { + type_error(this, Symbol.INTEGER); + // Not reached. + return false; + } + + public LispObject ODDP() throws ConditionThrowable + { + return oddp() ? T : NIL; + } + + public boolean oddp() throws ConditionThrowable + { + type_error(this, Symbol.INTEGER); + // Not reached. + return false; + } + + public LispObject PLUSP() throws ConditionThrowable + { + return plusp() ? T : NIL; + } + + public boolean plusp() throws ConditionThrowable + { + type_error(this, Symbol.REAL); + // Not reached. + return false; + } + + public LispObject MINUSP() throws ConditionThrowable + { + return minusp() ? T : NIL; + } + + public boolean minusp() throws ConditionThrowable + { + type_error(this, Symbol.REAL); + // Not reached. + return false; + } + + public LispObject NUMBERP() + { + return NIL; + } + + public boolean numberp() + { + return false; + } + + public LispObject ZEROP() throws ConditionThrowable + { + return zerop() ? T : NIL; + } + + public boolean zerop() throws ConditionThrowable + { + type_error(this, Symbol.NUMBER); + // Not reached. + return false; + } + + public LispObject COMPLEXP() + { + return NIL; + } + + public LispObject FLOATP() + { + return NIL; + } + + public boolean floatp() + { + return false; + } + + public LispObject INTEGERP() + { + return NIL; + } + + public boolean integerp() + { + return false; + } + + public LispObject RATIONALP() + { + return rationalp() ? T : NIL; + } + + public boolean rationalp() + { + return false; + } + + public LispObject REALP() + { + return realp() ? T : NIL; + } + + public boolean realp() + { + return false; + } + + public LispObject STRINGP() + { + return NIL; + } + + public boolean stringp() + { + return false; + } + + public LispObject SIMPLE_STRING_P() + { + return NIL; + } + + public LispObject VECTORP() + { + return NIL; + } + + public boolean vectorp() + { + return false; + } + + public LispObject CHARACTERP() + { + return NIL; + } + + public boolean characterp() + { + return false; + } + + public int length() throws ConditionThrowable + { + type_error(this, Symbol.SEQUENCE); + // Not reached. + return 0; + } + + public final LispObject LENGTH() throws ConditionThrowable + { + return new Fixnum(length()); + } + + public LispObject CHAR(int index) throws ConditionThrowable + { + return type_error(this, Symbol.STRING); + } + + public LispObject SCHAR(int index) throws ConditionThrowable + { + return type_error(this, Symbol.SIMPLE_STRING); + } + + public LispObject NTH(int index) throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject NTH(LispObject arg) throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject elt(int index) throws ConditionThrowable + { + return type_error(this, Symbol.SEQUENCE); + } + + public LispObject reverse() throws ConditionThrowable + { + return type_error(this, Symbol.SEQUENCE); + } + + public LispObject nreverse() throws ConditionThrowable + { + return type_error(this, Symbol.SEQUENCE); + } + + public long aref_long(int index) throws ConditionThrowable + { + return AREF(index).longValue(); + } + + public int aref(int index) throws ConditionThrowable + { + return AREF(index).intValue(); + } + + public LispObject AREF(int index) throws ConditionThrowable + { + return type_error(this, Symbol.ARRAY); + } + + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try + { + return AREF(((Fixnum)index).value); + } + catch (ClassCastException e) + { + return type_error(index, Symbol.FIXNUM); + } + } + + public void aset(int index, int n) + throws ConditionThrowable + { + aset(index, new Fixnum(n)); + } + + public void aset(int index, LispObject newValue) + throws ConditionThrowable + { + type_error(this, Symbol.ARRAY); + } + + public void aset(LispObject index, LispObject newValue) + throws ConditionThrowable + { + try + { + aset(((Fixnum)index).value, newValue); + } + catch (ClassCastException e) + { + type_error(index, Symbol.FIXNUM); + } + } + + public LispObject SVREF(int index) throws ConditionThrowable + { + return type_error(this, Symbol.SIMPLE_VECTOR); + } + + public void svset(int index, LispObject newValue) throws ConditionThrowable + { + type_error(this, Symbol.SIMPLE_VECTOR); + } + + public void vectorPushExtend(LispObject element) + throws ConditionThrowable + { + noFillPointer(); + } + + public LispObject VECTOR_PUSH_EXTEND(LispObject element) + throws ConditionThrowable + { + return noFillPointer(); + } + + public LispObject VECTOR_PUSH_EXTEND(LispObject element, LispObject extension) + throws ConditionThrowable + { + return noFillPointer(); + } + + public final LispObject noFillPointer() throws ConditionThrowable + { + return type_error(this, list3(Symbol.AND, Symbol.VECTOR, + list2(Symbol.SATISFIES, + Symbol.ARRAY_HAS_FILL_POINTER_P))); + } + + public LispObject[] copyToArray() throws ConditionThrowable + { + type_error(this, Symbol.LIST); + // Not reached. + return null; + } + + public LispObject SYMBOLP() + { + return NIL; + } + + public boolean listp() + { + return false; + } + + public LispObject LISTP() + { + return NIL; + } + + public boolean endp() throws ConditionThrowable + { + type_error(this, Symbol.LIST); + // Not reached. + return false; + } + + public LispObject ENDP() throws ConditionThrowable + { + return type_error(this, Symbol.LIST); + } + + public LispObject NOT() + { + return NIL; + } + + public boolean isSpecialOperator() throws ConditionThrowable + { + type_error(this, Symbol.SYMBOL); + // Not reached. + return false; + } + + public boolean isSpecialVariable() + { + return false; + } + + private static final EqHashTable documentationHashTable = + new EqHashTable(11, NIL, NIL); + + public LispObject getDocumentation(LispObject docType) + throws ConditionThrowable + { + LispObject alist = documentationHashTable.get(this); + if (alist != null) + { + LispObject entry = assq(docType, alist); + if (entry instanceof Cons) + return ((Cons)entry).cdr; + } + return NIL; + } + + public void setDocumentation(LispObject docType, LispObject documentation) + throws ConditionThrowable + { + LispObject alist = documentationHashTable.get(this); + if (alist == null) + alist = NIL; + LispObject entry = assq(docType, alist); + if (entry instanceof Cons) + { + ((Cons)entry).cdr = documentation; + } + else + { + alist = alist.push(new Cons(docType, documentation)); + documentationHashTable.put(this, alist); + } + } + + public LispObject getPropertyList() + { + return null; + } + + public void setPropertyList(LispObject obj) + { + } + + public LispObject getSymbolValue() throws ConditionThrowable + { + return type_error(this, Symbol.SYMBOL); + } + + public LispObject getSymbolFunction() throws ConditionThrowable + { + return type_error(this, Symbol.SYMBOL); + } + + public LispObject getSymbolFunctionOrDie() throws ConditionThrowable + { + return type_error(this, Symbol.SYMBOL); + } + + public String writeToString() throws ConditionThrowable + { + return toString(); + } + + public String unreadableString(String s) + { + FastStringBuffer sb = new FastStringBuffer("#<"); + sb.append(s); + sb.append(" {"); + sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); + sb.append("}>"); + return sb.toString(); + } + + public String unreadableString(Symbol symbol) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("#<"); + sb.append(symbol.writeToString()); + sb.append(" {"); + sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); + sb.append("}>"); + return sb.toString(); + } + + // Special operator + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + return error(new LispError()); + } + + public LispObject execute() throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return type_error(this, Symbol.FUNCTION); + } + + // Used by COMPILE-MULTIPLE-VALUE-CALL. + public LispObject dispatch(LispObject[] args) throws ConditionThrowable + { + switch (args.length) + { + case 0: + return execute(); + case 1: + return execute(args[0]); + case 2: + return execute(args[0], args[1]); + case 3: + return execute(args[0], args[1], args[2]); + case 4: + return execute(args[0], args[1], args[2], args[3]); + case 5: + return execute(args[0], args[1], args[2], args[3], args[4]); + case 6: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5]); + case 7: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5], args[6]); + case 8: + return execute(args[0], args[1], args[2], args[3], args[4], + args[5], args[6], args[7]); + default: + return type_error(this, Symbol.FUNCTION); + } + } + + public int intValue() throws ConditionThrowable + { + type_error(this, Symbol.INTEGER); + // Not reached. + return 0; + } + + public long longValue() throws ConditionThrowable + { + type_error(this, Symbol.INTEGER); + // Not reached. + return 0; + } + + public float floatValue() throws ConditionThrowable + { + type_error(this, Symbol.SINGLE_FLOAT); + // Not reached + return 0; + } + + public double doubleValue() throws ConditionThrowable + { + type_error(this, Symbol.DOUBLE_FLOAT); + // Not reached + return 0; + } + + public LispObject incr() throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public LispObject decr() throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public LispObject negate() throws ConditionThrowable + { + return Fixnum.ZERO.subtract(this); + } + + public LispObject add(int n) throws ConditionThrowable + { + return add(new Fixnum(n)); + } + + public LispObject add(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public LispObject subtract(int n) throws ConditionThrowable + { + return subtract(new Fixnum(n)); + } + + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public LispObject multiplyBy(int n) throws ConditionThrowable + { + return multiplyBy(new Fixnum(n)); + } + + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.NUMBER); + } + + public boolean isEqualTo(int n) throws ConditionThrowable + { + return isEqualTo(new Fixnum(n)); + } + + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.NUMBER); + // Not reached. + return false; + } + + public LispObject IS_E(LispObject obj) throws ConditionThrowable + { + return isEqualTo(obj) ? T : NIL; + } + + public boolean isNotEqualTo(int n) throws ConditionThrowable + { + return isNotEqualTo(new Fixnum(n)); + } + + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.NUMBER); + // Not reached. + return false; + } + + public LispObject IS_NE(LispObject obj) throws ConditionThrowable + { + return isNotEqualTo(obj) ? T : NIL; + } + + public boolean isLessThan(int n) throws ConditionThrowable + { + return isLessThan(new Fixnum(n)); + } + + public boolean isLessThan(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.REAL); + // Not reached. + return false; + } + + public LispObject IS_LT(LispObject obj) throws ConditionThrowable + { + return isLessThan(obj) ? T : NIL; + } + + public boolean isGreaterThan(int n) throws ConditionThrowable + { + return isGreaterThan(new Fixnum(n)); + } + + public boolean isGreaterThan(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.REAL); + // Not reached. + return false; + } + + public LispObject IS_GT(LispObject obj) throws ConditionThrowable + { + return isGreaterThan(obj) ? T : NIL; + } + + public boolean isLessThanOrEqualTo(int n) throws ConditionThrowable + { + return isLessThanOrEqualTo(new Fixnum(n)); + } + + public boolean isLessThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.REAL); + // Not reached. + return false; + } + + public LispObject IS_LE(LispObject obj) throws ConditionThrowable + { + return isLessThanOrEqualTo(obj) ? T : NIL; + } + + public boolean isGreaterThanOrEqualTo(int n) throws ConditionThrowable + { + return isGreaterThanOrEqualTo(new Fixnum(n)); + } + + public boolean isGreaterThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + type_error(this, Symbol.REAL); + // Not reached. + return false; + } + + public LispObject IS_GE(LispObject obj) throws ConditionThrowable + { + return isGreaterThanOrEqualTo(obj) ? T : NIL; + } + + public LispObject truncate(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.REAL); + } + + public LispObject MOD(LispObject divisor) throws ConditionThrowable + { + truncate(divisor); + final LispThread thread = LispThread.currentThread(); + LispObject remainder = thread._values[1]; + thread.clearValues(); + if (!remainder.zerop()) + { + if (divisor.minusp()) + { + if (plusp()) + return remainder.add(divisor); + } + else + { + if (minusp()) + return remainder.add(divisor); + } + } + return remainder; + } + + public LispObject MOD(int divisor) throws ConditionThrowable + { + return MOD(new Fixnum(divisor)); + } + + public LispObject ash(int shift) throws ConditionThrowable + { + return ash(new Fixnum(shift)); + } + + public LispObject ash(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.INTEGER); + } + + public LispObject LOGNOT() throws ConditionThrowable + { + return type_error(this, Symbol.INTEGER); + } + + public LispObject LOGAND(int n) throws ConditionThrowable + { + return LOGAND(new Fixnum(n)); + } + + public LispObject LOGAND(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.INTEGER); + } + + public LispObject LOGIOR(int n) throws ConditionThrowable + { + return LOGIOR(new Fixnum(n)); + } + + public LispObject LOGIOR(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.INTEGER); + } + + public LispObject LOGXOR(int n) throws ConditionThrowable + { + return LOGXOR(new Fixnum(n)); + } + + public LispObject LOGXOR(LispObject obj) throws ConditionThrowable + { + return type_error(this, Symbol.INTEGER); + } + + public LispObject LDB(int size, int position) throws ConditionThrowable + { + return type_error(this, Symbol.INTEGER); + } + + public int sxhash() + { + return hashCode() & 0x7fffffff; + } + + // For EQUALP hash tables. + public int psxhash() + { + return sxhash(); + } + + public int psxhash(int depth) + { + return psxhash(); + } + + public LispObject STRING() throws ConditionThrowable + { + return error(new TypeError(writeToString() + " cannot be coerced to a string.")); + } + + public char[] chars() throws ConditionThrowable + { + type_error(this, Symbol.STRING); + // Not reached. + return null; + } + + public char[] getStringChars() throws ConditionThrowable + { + type_error(this, Symbol.STRING); + // Not reached. + return null; + } + + public String getStringValue() throws ConditionThrowable + { + type_error(this, Symbol.STRING); + // Not reached. + return null; + } + + public LispObject getSlotValue_0() throws ConditionThrowable + { + return type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public LispObject getSlotValue_1() throws ConditionThrowable + { + return type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public LispObject getSlotValue_2() throws ConditionThrowable + { + return type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public LispObject getSlotValue_3() throws ConditionThrowable + { + return type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public LispObject getSlotValue(int index) throws ConditionThrowable + { + return type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public int getFixnumSlotValue(int index) throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + // Not reached. + return 0; + } + + public boolean getSlotValueAsBoolean(int index) throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + // Not reached. + return false; + } + + public void setSlotValue_0(LispObject value) + throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public void setSlotValue_1(LispObject value) + throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public void setSlotValue_2(LispObject value) + throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public void setSlotValue_3(LispObject value) + throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public void setSlotValue(int index, LispObject value) + throws ConditionThrowable + { + type_error(this, Symbol.STRUCTURE_OBJECT); + } + + public LispObject SLOT_VALUE(LispObject slotName) throws ConditionThrowable + { + return type_error(this, Symbol.STANDARD_OBJECT); + } + + public void setSlotValue(LispObject slotName, LispObject newValue) + throws ConditionThrowable + { + type_error(this, Symbol.STANDARD_OBJECT); + } + + // Profiling. + public int getCallCount() + { + return 0; + } + + public void setCallCount(int n) + { + } + + public void incrementCallCount() + { + } + +} Added: branches/save-image/src/org/armedbear/lisp/LispObjectInputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispObjectInputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,43 @@ +package org.armedbear.lisp; + +import java.io.*; + +public class LispObjectInputStream extends ObjectInputStream { + + public LispObjectInputStream(InputStream in) throws IOException { + super(in); + } + + /* + protected Class resolveClass(ObjectStreamClass desc) throws IOException, ClassNotFoundException { + String name = desc.getName(); + if(name != null && name.contains("ABCL_GENERATED_")) { + try { + byte[] bytes = (byte[]) readObject(); + return (new JavaClassLoader()).loadClassFromByteArray(null, bytes, 0, bytes.length); + } catch(java.io.OptionalDataException e) { + System.out.println("AAAAA " + e.eof + " " + e.length); + throw new ClassNotFoundException(); + } + + } + try { + return Class.forName(name, false, JavaClassLoader.getPersistentInstance()); + } catch (ClassNotFoundException ex) { + return super.resolveClass(desc); + } + } + + private void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { + if(getClass().getSimpleName().contains("ABCL_GENERATED_")) { + try { + stream.writeObject(getf(propertyList, Symbol.CLASS_BYTES, new JavaObject(new byte[0])).javaInstance()); + } catch(ConditionThrowable c) { + throw new java.io.InvalidClassException(getClass().getName()); + } + } + stream.defaultWriteObject(); + } + */ + +} \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/LispReader.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispReader.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,454 @@ +/* + * LispReader.java + * + * Copyright (C) 2004-2007 Peter Graves + * $Id: LispReader.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class LispReader extends Lisp +{ + // ### read-comment + public static final ReaderMacroFunction READ_COMMENT = + new ReaderMacroFunction("read-comment", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + while (true) { + int n = stream._readChar(); + if (n < 0) + return null; + if (n == '\n') + return null; + } + } + }; + + // ### read-string + public static final ReaderMacroFunction READ_STRING = + new ReaderMacroFunction("read-string", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char terminator) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + FastStringBuffer sb = new FastStringBuffer(); + while (true) { + int n = stream._readChar(); + if (n < 0) { + error(new EndOfFile(stream)); + // Not reached. + return null; + } + char c = (char) n; + if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { + // Single escape. + n = stream._readChar(); + if (n < 0) { + error(new EndOfFile(stream)); + // Not reached. + return null; + } + sb.append((char)n); + continue; + } + if (Utilities.isPlatformWindows) { + if (c == '\r') { + n = stream._readChar(); + if (n < 0) { + error(new EndOfFile(stream)); + // Not reached. + return null; + } + if (n == '\n') { + sb.append('\n'); + } else { + // '\r' was not followed by '\n'. + stream._unreadChar(n); + sb.append('\r'); + } + continue; + } + } + if (c == terminator) + break; + // Default. + sb.append(c); + } + return new SimpleString(sb); + } + }; + + // ### read-list + public static final ReaderMacroFunction READ_LIST = + new ReaderMacroFunction("read-list", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + return stream.readList(false, false); + } + }; + + // ### read-right-paren + public static final ReaderMacroFunction READ_RIGHT_PAREN = + new ReaderMacroFunction("read-right-paren", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + return error(new ReaderError("Unmatched right parenthesis.", stream)); + } + }; + + // ### read-quote + public static final ReaderMacroFunction READ_QUOTE = + new ReaderMacroFunction("read-quote", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char ignored) + throws ConditionThrowable + { + return new Cons(Symbol.QUOTE, + new Cons(stream.read(true, NIL, true, + LispThread.currentThread()))); + } + }; + + // ### read-dispatch-char + public static final ReaderMacroFunction READ_DISPATCH_CHAR = + new ReaderMacroFunction("read-dispatch-char", PACKAGE_SYS, false, + "stream character") + { + @Override + public LispObject execute(Stream stream, char c) + throws ConditionThrowable + { + return stream.readDispatchChar(c, false); + } + }; + + // ### sharp-left-paren + public static final DispatchMacroFunction SHARP_LEFT_PAREN = + new DispatchMacroFunction("sharp-left-paren", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject list = stream.readList(true, false); + if (_BACKQUOTE_COUNT_.symbolValue(thread).zerop()) { + if (n >= 0) { + LispObject[] array = new LispObject[n]; + for (int i = 0; i < n; i++) { + array[i] = list.car(); + if (list.cdr() != NIL) + list = list.cdr(); + } + return new SimpleVector(array); + } else + return new SimpleVector(list); + } + return new Cons(_BQ_VECTOR_FLAG_.symbolValue(thread), list); + } + }; + + // ### sharp-star + public static final DispatchMacroFunction SHARP_STAR = + new DispatchMacroFunction("sharp-star", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char ignored, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + final boolean suppress = Symbol.READ_SUPPRESS.symbolValue(thread) != NIL; + FastStringBuffer sb = new FastStringBuffer(); + while (true) { + int ch = stream._readChar(); + if (ch < 0) + break; + char c = (char) ch; + if (c == '0' || c == '1') + sb.append(c); + else { + int syntaxType = rt.getSyntaxType(c); + if (syntaxType == Readtable.SYNTAX_TYPE_WHITESPACE || + syntaxType == Readtable.SYNTAX_TYPE_TERMINATING_MACRO) { + stream._unreadChar(c); + break; + } else if (!suppress) { + String name = LispCharacter.charToName(c); + if (name == null) + name = "#\\" + c; + error(new ReaderError("Illegal element for bit-vector: " + name, + stream)); + } + } + } + if (suppress) + return NIL; + if (n >= 0) { + // n was supplied. + final int length = sb.length(); + if (length == 0) { + if (n > 0) + return error(new ReaderError("No element specified for bit vector of length " + + n + '.', + stream)); + } + if (n > length) { + final char c = sb.charAt(length - 1); + for (int i = length; i < n; i++) + sb.append(c); + } else if (n < length) { + return error(new ReaderError("Bit vector is longer than specified length: #" + + n + '*' + sb.toString(), + stream)); + } + } + return new SimpleBitVector(sb.toString()); + } + }; + + // ### sharp-dot + public static final DispatchMacroFunction SHARP_DOT = + new DispatchMacroFunction("sharp-dot", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (Symbol.READ_EVAL.symbolValue(thread) == NIL) + return error(new ReaderError("Can't read #. when *READ-EVAL* is NIL.", + stream)); + else + return eval(stream.read(true, NIL, true, thread), + new Environment(), thread); + } + }; + + // ### sharp-colon + public static final DispatchMacroFunction SHARP_COLON = + new DispatchMacroFunction("sharp-colon", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readSymbol(); + } + }; + + // ### sharp-a + public static final DispatchMacroFunction SHARP_A = + new DispatchMacroFunction("sharp-a", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readArray(n); + } + }; + + // ### sharp-b + public static final DispatchMacroFunction SHARP_B = + new DispatchMacroFunction("sharp-b", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readRadix(2); + } + }; + + // ### sharp-c + public static final DispatchMacroFunction SHARP_C = + new DispatchMacroFunction("sharp-c", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readComplex(); + } + }; + + // ### sharp-o + public static final DispatchMacroFunction SHARP_O = + new DispatchMacroFunction("sharp-o", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readRadix(8); + } + }; + + // ### sharp-p + public static final DispatchMacroFunction SHARP_P = + new DispatchMacroFunction("sharp-p", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readPathname(); + } + }; + + // ### sharp-r + public static final DispatchMacroFunction SHARP_R = + new DispatchMacroFunction("sharp-r", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readRadix(n); + } + }; + + // ### sharp-s + public static final DispatchMacroFunction SHARP_S = + new DispatchMacroFunction("sharp-s", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readStructure(); + } + }; + + // ### sharp-x + public static final DispatchMacroFunction SHARP_X = + new DispatchMacroFunction("sharp-x", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return stream.readRadix(16); + } + }; + + // ### sharp-quote + public static final DispatchMacroFunction SHARP_QUOTE = + new DispatchMacroFunction("sharp-quote", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + return new Cons(Symbol.FUNCTION, + new Cons(stream.read(true, NIL, true, + LispThread.currentThread()))); + } + }; + + // ### sharp-backslash + public static final DispatchMacroFunction SHARP_BACKSLASH = + new DispatchMacroFunction("sharp-backslash", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + return stream.readCharacterLiteral(rt, thread); + } + }; + + // ### sharp-vertical-bar + public static final DispatchMacroFunction SHARP_VERTICAL_BAR = + new DispatchMacroFunction("sharp-vertical-bar", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + stream.skipBalancedComment(); + return null; + } + }; + + // ### sharp-illegal + public static final DispatchMacroFunction SHARP_ILLEGAL = + new DispatchMacroFunction("sharp-illegal", PACKAGE_SYS, false, + "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("Illegal # macro character: #\\"); + String s = LispCharacter.charToName(c); + if (s != null) + sb.append(s); + else + sb.append(c); + return error(new ReaderError(sb.toString(), stream)); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/LispThread.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LispThread.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1189 @@ +/* + * LispThread.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: LispThread.java 11553 2009-01-11 08:29:20Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.Iterator; +import java.util.concurrent.ConcurrentHashMap; + +public final class LispThread extends LispObject +{ + private static boolean use_fast_calls = false; + + // use a concurrent hashmap: we may want to add threads + // while at the same time iterating the hash + final private static ConcurrentHashMap map = + new ConcurrentHashMap(); + + private static ThreadLocal threads = new ThreadLocal(){ + @Override + public LispThread initialValue() { + Thread thisThread = Thread.currentThread(); + LispThread newThread = new LispThread(thisThread); + LispThread.map.put(thisThread,newThread); + return newThread; + } + }; + + public static final LispThread currentThread() + { + return threads.get(); + } + + private final Thread javaThread; + private boolean destroyed; + private final LispObject name; + public SpecialBinding lastSpecialBinding; + public LispObject[] _values; + private boolean threadInterrupted; + private LispObject pending = NIL; + + private LispThread(Thread javaThread) + { + this.javaThread = javaThread; + name = new SimpleString(javaThread.getName()); + } + + private LispThread(final Function fun, LispObject name) + { + Runnable r = new Runnable() { + public void run() + { + try { + funcall(fun, new LispObject[0], LispThread.this); + } + catch (ThreadDestroyed ignored) { + // Might happen. + } + catch (Throwable t) { + if (isInterrupted()) { + try { + processThreadInterrupts(); + } + catch (ConditionThrowable c) { + Debug.trace(c); + } + } + } + finally { + // make sure the thread is *always* removed from the hash again + map.remove(Thread.currentThread()); + } + } + }; + javaThread = new Thread(r); + this.name = name; + javaThread.setDaemon(true); + javaThread.start(); + } + + @Override + public LispObject typeOf() + { + return Symbol.THREAD; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.THREAD; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.THREAD) + return T; + if (typeSpecifier == BuiltInClass.THREAD) + return T; + return super.typep(typeSpecifier); + } + + public final synchronized boolean isDestroyed() + { + return destroyed; + } + + private final synchronized boolean isInterrupted() + { + return threadInterrupted; + } + + private final synchronized void setDestroyed(boolean b) + { + destroyed = b; + } + + private final synchronized void interrupt(LispObject function, LispObject args) + { + pending = new Cons(args, pending); + pending = new Cons(function, pending); + threadInterrupted = true; + javaThread.interrupt(); + } + + private final synchronized void processThreadInterrupts() + throws ConditionThrowable + { + while (pending != NIL) { + LispObject function = pending.car(); + LispObject args = pending.cadr(); + pending = pending.cddr(); + Primitives.APPLY.execute(function, args); + } + threadInterrupted = false; + } + + public final LispObject[] getValues() + { + return _values; + } + + public final LispObject[] getValues(LispObject result, int count) + { + if (_values == null) { + LispObject[] values = new LispObject[count]; + if (count > 0) + values[0] = result; + for (int i = 1; i < count; i++) + values[i] = NIL; + return values; + } + // If the caller doesn't want any extra values, just return the ones + // we've got. + if (count <= _values.length) + return _values; + // The caller wants more values than we have. Pad with NILs. + LispObject[] values = new LispObject[count]; + for (int i = _values.length; i-- > 0;) + values[i] = _values[i]; + for (int i = _values.length; i < count; i++) + values[i] = NIL; + return values; + } + + // Used by the JVM compiler for MULTIPLE-VALUE-CALL. + public final LispObject[] accumulateValues(LispObject result, + LispObject[] oldValues) + { + if (oldValues == null) { + if (_values != null) + return _values; + LispObject[] values = new LispObject[1]; + values[0] = result; + return values; + } + if (_values != null) { + if (_values.length == 0) + return oldValues; + final int totalLength = oldValues.length + _values.length; + LispObject[] values = new LispObject[totalLength]; + System.arraycopy(oldValues, 0, + values, 0, + oldValues.length); + System.arraycopy(_values, 0, + values, oldValues.length, + _values.length); + return values; + } + // _values is null. + final int totalLength = oldValues.length + 1; + LispObject[] values = new LispObject[totalLength]; + System.arraycopy(oldValues, 0, + values, 0, + oldValues.length); + values[totalLength - 1] = result; + return values; + } + + public final LispObject setValues() + { + _values = new LispObject[0]; + return NIL; + } + + public final LispObject setValues(LispObject value1) + { + _values = null; + return value1; + } + + public final LispObject setValues(LispObject value1, LispObject value2) + { + _values = new LispObject[2]; + _values[0] = value1; + _values[1] = value2; + return value1; + } + + public final LispObject setValues(LispObject value1, LispObject value2, + LispObject value3) + { + _values = new LispObject[3]; + _values[0] = value1; + _values[1] = value2; + _values[2] = value3; + return value1; + } + + public final LispObject setValues(LispObject value1, LispObject value2, + LispObject value3, LispObject value4) + { + _values = new LispObject[4]; + _values[0] = value1; + _values[1] = value2; + _values[2] = value3; + _values[3] = value4; + return value1; + } + + public final LispObject setValues(LispObject[] values) + { + switch (values.length) { + case 0: + _values = values; + return NIL; + case 1: + _values = null; + return values[0]; + default: + _values = values; + return values[0]; + } + } + + public final void clearValues() + { + _values = null; + } + + public final LispObject nothing() + { + _values = new LispObject[0]; + return NIL; + } + + // Forces a single value, for situations where multiple values should be + // ignored. + public final LispObject value(LispObject obj) + { + _values = null; + return obj; + } + + public final void bindSpecial(Symbol name, LispObject value) + { + lastSpecialBinding = new SpecialBinding(name, value, lastSpecialBinding); + } + + public final void bindSpecialToCurrentValue(Symbol name) + { + SpecialBinding binding = lastSpecialBinding; + while (binding != null) { + if (binding.name == name) { + lastSpecialBinding = + new SpecialBinding(name, binding.value, lastSpecialBinding); + return; + } + binding = binding.next; + } + // Not found. + lastSpecialBinding = + new SpecialBinding(name, name.getSymbolValue(), lastSpecialBinding); + } + + public final LispObject lookupSpecial(LispObject name) + { + SpecialBinding binding = lastSpecialBinding; + while (binding != null) { + if (binding.name == name) + return binding.value; + binding = binding.next; + } + return null; + } + + public final SpecialBinding getSpecialBinding(LispObject name) + { + SpecialBinding binding = lastSpecialBinding; + while (binding != null) { + if (binding.name == name) + return binding; + binding = binding.next; + } + return null; + } + + public final LispObject setSpecialVariable(Symbol name, LispObject value) + { + SpecialBinding binding = lastSpecialBinding; + while (binding != null) { + if (binding.name == name) { + binding.value = value; + return value; + } + binding = binding.next; + } + name.setSymbolValue(value); + return value; + } + + public final LispObject pushSpecial(Symbol name, LispObject thing) + throws ConditionThrowable + { + SpecialBinding binding = lastSpecialBinding; + while (binding != null) { + if (binding.name == name) { + LispObject newValue = new Cons(thing, binding.value); + binding.value = newValue; + return newValue; + } + binding = binding.next; + } + LispObject value = name.getSymbolValue(); + if (value != null) { + LispObject newValue = new Cons(thing, value); + name.setSymbolValue(newValue); + return newValue; + } else + return error(new UnboundVariable(name)); + } + + // Returns symbol value or NIL if unbound. + public final LispObject safeSymbolValue(Symbol name) + { + SpecialBinding binding = lastSpecialBinding; + while (binding != null) { + if (binding.name == name) + return binding.value; + binding = binding.next; + } + LispObject value = name.getSymbolValue(); + return value != null ? value : NIL; + } + + public final void rebindSpecial(Symbol name, LispObject value) + { + SpecialBinding binding = getSpecialBinding(name); + binding.value = value; + } + + private LispObject catchTags = NIL; + + public void pushCatchTag(LispObject tag) throws ConditionThrowable + { + catchTags = new Cons(tag, catchTags); + } + + public void popCatchTag() throws ConditionThrowable + { + if (catchTags != NIL) + catchTags = catchTags.cdr(); + else + Debug.assertTrue(false); + } + + public void throwToTag(LispObject tag, LispObject result) + throws ConditionThrowable + { + LispObject rest = catchTags; + while (rest != NIL) { + if (rest.car() == tag) + throw new Throw(tag, result, this); + rest = rest.cdr(); + } + error(new ControlError("Attempt to throw to the nonexistent tag " + + tag.writeToString() + ".")); + } + + private static class StackFrame extends LispObject + { + public final LispObject operator; + private final LispObject first; + private final LispObject second; + private final LispObject third; + private final LispObject[] args; + + public StackFrame(LispObject operator) + { + this.operator = operator; + first = null; + second = null; + third = null; + args = null; + } + + public StackFrame(LispObject operator, LispObject arg) + { + this.operator = operator; + first = arg; + second = null; + third = null; + args = null; + } + + public StackFrame(LispObject operator, LispObject first, + LispObject second) + { + this.operator = operator; + this.first = first; + this.second = second; + third = null; + args = null; + } + + public StackFrame(LispObject operator, LispObject first, + LispObject second, LispObject third) + { + this.operator = operator; + this.first = first; + this.second = second; + this.third = third; + args = null; + } + + public StackFrame(LispObject operator, LispObject[] args) + { + this.operator = operator; + first = null; + second = null; + third = null; + this.args = new LispObject[args.length]; + for (int i = args.length; i-- > 0;) + this.args[i] = args[i]; + } + + public LispObject toList() throws ConditionThrowable + { + LispObject list = NIL; + if (args != null) { + for (int i = 0; i < args.length; i++) + list = list.push(args[i]); + } else { + do { + if (first != null) + list = list.push(first); + else + break; + if (second != null) + list = list.push(second); + else + break; + if (third != null) + list = list.push(third); + else + break; + } while (false); + } + list = list.nreverse(); + if (operator instanceof Operator) { + LispObject lambdaName = ((Operator)operator).getLambdaName(); + if (lambdaName != null && lambdaName != NIL) + return list.push(lambdaName); + } + return list.push(operator); + } + } + + private LispObject stack = NIL; + + public LispObject getStack() + { + return stack; + } + + public void setStack(LispObject stack) + { + this.stack = stack; + } + + public void pushStackFrame(LispObject operator) + throws ConditionThrowable + { + stack = new Cons((new StackFrame(operator)), stack); + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + } + + public void pushStackFrame(LispObject operator, LispObject arg) + throws ConditionThrowable + { + stack = new Cons((new StackFrame(operator, arg)), stack); + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + } + + public void pushStackFrame(LispObject operator, LispObject first, + LispObject second) + throws ConditionThrowable + { + stack = new Cons((new StackFrame(operator, first, second)), stack); + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + } + + public void pushStackFrame(LispObject operator, LispObject first, + LispObject second, LispObject third) + throws ConditionThrowable + { + stack = new Cons((new StackFrame(operator, first, second, third)), + stack); + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + } + + public void pushStackFrame(LispObject operator, LispObject[] args) + throws ConditionThrowable + { + stack = new Cons((new StackFrame(operator, args)), stack); + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + } + + public void resetStack() + { + stack = NIL; + } + + @Override + public LispObject execute(LispObject function) throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(); + + LispObject oldStack = stack; + pushStackFrame(function); + try { + return function.execute(); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject arg) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(arg); + + LispObject oldStack = stack; + pushStackFrame(function, arg); + try { + return function.execute(arg); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject first, + LispObject second) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second); + + LispObject oldStack = stack; + pushStackFrame(function, first, second); + try { + return function.execute(first, second); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject first, + LispObject second, LispObject third) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second, third); + + LispObject oldStack = stack; + pushStackFrame(function, first, second, third); + try { + return function.execute(first, second, third); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject first, + LispObject second, LispObject third, + LispObject fourth) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second, third, fourth); + + LispObject oldStack = stack; + LispObject[] args = new LispObject[4]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + pushStackFrame(function, args); + try { + return function.execute(first, second, third, fourth); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second, third, fourth, fifth); + + LispObject oldStack = stack; + LispObject[] args = new LispObject[5]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + pushStackFrame(function, args); + try { + return function.execute(first, second, third, fourth, fifth); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth, + LispObject sixth) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second, third, fourth, fifth, sixth); + + LispObject oldStack = stack; + LispObject[] args = new LispObject[6]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + pushStackFrame(function, args); + try { + return function.execute(first, second, third, fourth, fifth, sixth); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + @Override + public LispObject execute(LispObject function, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth, + LispObject sixth, LispObject seventh) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second, third, fourth, fifth, sixth, + seventh); + + LispObject oldStack = stack; + LispObject[] args = new LispObject[7]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + pushStackFrame(function, args); + try { + return function.execute(first, second, third, fourth, fifth, sixth, + seventh); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + public LispObject execute(LispObject function, LispObject first, + LispObject second, LispObject third, + LispObject fourth, LispObject fifth, + LispObject sixth, LispObject seventh, + LispObject eighth) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(first, second, third, fourth, fifth, sixth, + seventh, eighth); + + LispObject oldStack = stack; + LispObject[] args = new LispObject[8]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + args[7] = eighth; + pushStackFrame(function, args); + try { + return function.execute(first, second, third, fourth, fifth, sixth, + seventh, eighth); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + public LispObject execute(LispObject function, LispObject[] args) + throws ConditionThrowable + { + if (use_fast_calls) + return function.execute(args); + + LispObject oldStack = stack; + pushStackFrame(function, args); + try { + return function.execute(args); + } + finally { + if (profiling && sampling) { + if (sampleNow) + Profiler.sample(this); + } + stack = oldStack; + } + } + + public void backtrace() + { + backtrace(0); + } + + public void backtrace(int limit) + { + if (stack != NIL) { + try { + int count = 0; + Stream out = + checkCharacterOutputStream(Symbol.TRACE_OUTPUT.symbolValue()); + out._writeLine("Evaluation stack:"); + out._finishOutput(); + while (stack != NIL) { + out._writeString(" "); + out._writeString(String.valueOf(count)); + out._writeString(": "); + StackFrame frame = (StackFrame) stack.car(); + pprint(frame.toList(), out.getCharPos(), out); + out.terpri(); + out._finishOutput(); + if (limit > 0 && ++count == limit) + break; + stack = stack.cdr(); + } + } + catch (Throwable t) { + t.printStackTrace(); + } + } + } + + public LispObject backtraceAsList(int limit) throws ConditionThrowable + { + LispObject result = NIL; + if (stack != NIL) { + int count = 0; + try { + LispObject s = stack; + while (s != NIL) { + StackFrame frame = (StackFrame) s.car(); + if (frame != null) { + result = result.push(frame.toList()); + if (limit > 0 && ++count == limit) + break; + } + s = s.cdr(); + } + } + catch (Throwable t) { + t.printStackTrace(); + } + } + return result.nreverse(); + } + + public void incrementCallCounts() throws ConditionThrowable + { + LispObject s = stack; + while (s != NIL) { + StackFrame frame = (StackFrame) s.car(); + if (frame != null) { + LispObject operator = frame.operator; + if (operator != null) + operator.incrementCallCount(); + } + s = s.cdr(); + } + } + + private static void pprint(LispObject obj, int indentBy, Stream stream) + throws ConditionThrowable + { + if (stream.getCharPos() == 0) { + StringBuffer sb = new StringBuffer(); + for (int i = 0; i < indentBy; i++) + sb.append(' '); + stream._writeString(sb.toString()); + } + String raw = obj.writeToString(); + if (stream.getCharPos() + raw.length() < 80) { + // It fits. + stream._writeString(raw); + return; + } + // Object doesn't fit. + if (obj instanceof Cons) { + try { + boolean newlineBefore = false; + LispObject[] array = obj.copyToArray(); + if (array.length > 0) { + LispObject first = array[0]; + if (first == Symbol.LET) { + newlineBefore = true; + } + } + int charPos = stream.getCharPos(); + if (newlineBefore && charPos != indentBy) { + stream.terpri(); + charPos = stream.getCharPos(); + } + if (charPos < indentBy) { + StringBuffer sb = new StringBuffer(); + for (int i = charPos; i < indentBy; i++) + sb.append(' '); + stream._writeString(sb.toString()); + } + stream.print('('); + for (int i = 0; i < array.length; i++) { + pprint(array[i], indentBy + 2, stream); + if (i < array.length - 1) + stream.print(' '); + } + stream.print(')'); + } + catch (ConditionThrowable t) { + Debug.trace(t); + } + } else { + stream.terpri(); + StringBuffer sb = new StringBuffer(); + for (int i = 0; i < indentBy; i++) + sb.append(' '); + stream._writeString(sb.toString()); + stream._writeString(raw); + return; + } + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = new StringBuffer("THREAD"); + if (name != NIL) { + sb.append(" \""); + sb.append(name.getStringValue()); + sb.append("\""); + } + return unreadableString(sb.toString()); + } + + // ### make-thread + private static final Primitive MAKE_THREAD = + new Primitive("make-thread", PACKAGE_EXT, true, "function &key name") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final int length = args.length; + if (length == 0) + error(new WrongNumberOfArgumentsException(this)); + LispObject name = NIL; + if (length > 1) { + if ((length - 1) % 2 != 0) + error(new ProgramError("Odd number of keyword arguments.")); + if (length > 3) + error(new WrongNumberOfArgumentsException(this)); + if (args[1] == Keyword.NAME) + name = args[2].STRING(); + else + error(new ProgramError("Unrecognized keyword argument " + + args[1].writeToString() + ".")); + } + return new LispThread(checkFunction(args[0]), name); + } + }; + + // ### threadp + private static final Primitive THREADP = + new Primitive("threadp", PACKAGE_EXT, true, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof LispThread ? T : NIL; + } + }; + + // ### thread-alive-p + private static final Primitive THREAD_ALIVE_P = + new Primitive("thread-alive-p", PACKAGE_EXT, true, "thread") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispThread lispThread; + try { + lispThread = (LispThread) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.THREAD); + } + return lispThread.javaThread.isAlive() ? T : NIL; + } + }; + + // ### thread-name + private static final Primitive THREAD_NAME = + new Primitive("thread-name", PACKAGE_EXT, true, "thread") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((LispThread)arg).name; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.THREAD); + } + } + }; + + // ### sleep + private static final Primitive SLEEP = new Primitive("sleep", "seconds") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + double d = + ((DoubleFloat)arg.multiplyBy(new DoubleFloat(1000))).getValue(); + if (d < 0) + return type_error(arg, list2(Symbol.REAL, Fixnum.ZERO)); + long millis = d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE; + try { + Thread.sleep(millis); + } + catch (InterruptedException e) { + currentThread().processThreadInterrupts(); + } + return NIL; + } + }; + + // ### mapcar-threads + private static final Primitive MAPCAR_THREADS = + new Primitive("mapcar-threads", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Function fun = checkFunction(arg); + final LispThread thread = LispThread.currentThread(); + LispObject result = NIL; + Iterator it = map.values().iterator(); + while (it.hasNext()) { + LispObject[] args = new LispObject[1]; + args[0] = (LispThread) it.next(); + result = new Cons(funcall(fun, args, thread), result); + } + return result; + } + }; + + // ### destroy-thread + private static final Primitive DESTROY_THREAD = + new Primitive("destroy-thread", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispThread thread; + try { + thread = (LispThread) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.THREAD); + } + thread.setDestroyed(true); + return T; + } + }; + + // ### interrupt-thread thread function &rest args => T + // Interrupts thread and forces it to apply function to args. When the + // function returns, the thread's original computation continues. If + // multiple interrupts are queued for a thread, they are all run, but the + // order is not guaranteed. + private static final Primitive INTERRUPT_THREAD = + new Primitive("interrupt-thread", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread; + try { + thread = (LispThread) args[0]; + } + catch (ClassCastException e) { + return type_error(args[0], Symbol.THREAD); + } + LispObject fun = args[1]; + LispObject funArgs = NIL; + for (int i = args.length; i-- > 2;) + funArgs = new Cons(args[i], funArgs); + thread.interrupt(fun, funArgs); + return T; + } + }; + + // ### current-thread + private static final Primitive CURRENT_THREAD = + new Primitive("current-thread", PACKAGE_EXT, true) + { + @Override + public LispObject execute() throws ConditionThrowable + { + return currentThread(); + } + }; + + // ### backtrace-as-list + private static final Primitive BACKTRACE_AS_LIST = + new Primitive("backtrace-as-list", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject[] args) + throws ConditionThrowable + { + if (args.length > 1) + return error(new WrongNumberOfArgumentsException(this)); + int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0; + return currentThread().backtraceAsList(limit); + } + }; + + // ### use-fast-calls + private static final Primitive USE_FAST_CALLS = + new Primitive("use-fast-calls", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + use_fast_calls = (arg != NIL); + return use_fast_calls ? T : NIL; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Load.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Load.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,609 @@ +/* + * Load.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Load.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.FileInputStream; +import java.io.FileNotFoundException; +import java.io.IOException; +import java.io.InputStream; +import java.net.URL; +import java.util.zip.ZipEntry; +import java.util.zip.ZipException; +import java.util.zip.ZipFile; + +public final class Load extends Lisp +{ + public static final LispObject load(String filename) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + return load(new Pathname(filename), + filename, + Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, + Symbol.LOAD_PRINT.symbolValue(thread) != NIL, + true); + } + + private static final File findLoadableFile(final String filename, + final String dir) + { + File file = new File(dir, filename); + if (!file.isFile()) { + String extension = getExtension(filename); + if (extension == null) { + // No extension specified. Try appending ".lisp" or ".abcl". + File lispFile = new File(dir, filename.concat(".lisp")); + File abclFile = new File(dir, filename.concat(".abcl")); + if (lispFile.isFile() && abclFile.isFile()) { + if (abclFile.lastModified() > lispFile.lastModified()) { + return abclFile; + } else { + return lispFile; + } + } else if (abclFile.isFile()) { + return abclFile; + } else if (lispFile.isFile()) { + return lispFile; + } + } + } else + return file; // the file exists + return null; // this is the error case: the file does not exist + // no need to check again at the caller + } + + public static final LispObject load(Pathname pathname, + String filename, + boolean verbose, + boolean print, + boolean ifDoesNotExist) + throws ConditionThrowable + { + String dir = null; + if (!Utilities.isFilenameAbsolute(filename)) { + dir = + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()).getNamestring(); + } + + File file = findLoadableFile(filename, dir); + if (file == null) { + if (ifDoesNotExist) + return error(new FileError("File not found: " + filename, + pathname)); + else + return NIL; + } + + filename = file.getPath(); + ZipFile zipfile = null; + if (checkZipFile(file)) + { + try { + zipfile = new ZipFile(file); + } + catch (Throwable t) { + // Fall through. + } + } + String truename = filename; + InputStream in = null; + if (zipfile != null) { + String name = file.getName(); + int index = name.lastIndexOf('.'); + Debug.assertTrue(index >= 0); + name = name.substring(0, index).concat("._"); + ZipEntry entry = zipfile.getEntry(name); + if (entry != null) { + try { + in = zipfile.getInputStream(entry); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + } else { + try { + in = new FileInputStream(file); + truename = file.getCanonicalPath(); + } + catch (FileNotFoundException e) { + if (ifDoesNotExist) + return error(new FileError("File not found: " + filename, + pathname)); + else + return NIL; + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + try { + return loadFileFromStream(null, truename, + new Stream(in, Symbol.CHARACTER), + verbose, print, false); + } + catch (FaslVersionMismatch e) { + FastStringBuffer sb = + new FastStringBuffer("Incorrect fasl version: "); + sb.append(truename); + return error(new SimpleError(sb.toString())); + } + finally { + if (in != null) { + try { + in.close(); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + if (zipfile != null) { + try { + zipfile.close(); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + } + } + + public static final LispObject loadSystemFile(String filename) + throws ConditionThrowable + { + 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) + throws ConditionThrowable + { + LispThread thread = LispThread.currentThread(); + if (auto) { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.CURRENT_READTABLE, + STANDARD_READTABLE.symbolValue(thread)); + thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_CL_USER); + try { + return loadSystemFile(filename, + _AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL, + Symbol.LOAD_PRINT.symbolValue(thread) != NIL, + auto); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } else { + return loadSystemFile(filename, + Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, + Symbol.LOAD_PRINT.symbolValue(thread) != NIL, + auto); + } + } + + public static final LispObject loadSystemFile(final String filename, + boolean verbose, + boolean print, + boolean auto) + throws ConditionThrowable + { + final int ARRAY_SIZE = 2; + String[] candidates = new String[ARRAY_SIZE]; + final String extension = getExtension(filename); + if (extension == null) { + // No extension specified. + candidates[0] = filename + '.' + COMPILE_FILE_TYPE; + candidates[1] = filename.concat(".lisp"); + } else if (extension.equals(".abcl")) { + candidates[0] = filename; + candidates[1] = + filename.substring(0, filename.length() - 5).concat(".lisp"); + } else + candidates[0] = filename; + InputStream in = null; + Pathname pathname = null; + String truename = null; + for (int i = 0; i < ARRAY_SIZE; i++) { + String s = candidates[i]; + if (s == null) + break; + ZipFile zipfile = null; + final String dir = Site.getLispHome(); + try { + if (dir != null) { + File file = new File(dir, s); + if (file.isFile()) { + // File exists. For system files, we know the extension + // will be .abcl if it is a compiled file. + String ext = getExtension(s); + if (ext.equalsIgnoreCase(".abcl")) { + try { + zipfile = new ZipFile(file); + String name = file.getName(); + int index = name.lastIndexOf('.'); + Debug.assertTrue(index >= 0); + name = name.substring(0, index).concat("._"); + ZipEntry entry = zipfile.getEntry(name); + if (entry != null) { + in = zipfile.getInputStream(entry); + truename = file.getCanonicalPath(); + } + } + catch (ZipException e) { + // Fall through. + } + catch (Throwable t) { + Debug.trace(t); + in = null; + // Fall through. + } + } + if (in == null) { + try { + in = new FileInputStream(file); + truename = file.getCanonicalPath(); + } + catch (IOException e) { + in = null; + } + } + } + } else { + URL url = Lisp.class.getResource(s); + if (url != null) { + try { + in = url.openStream(); + if ("jar".equals(url.getProtocol()) && + url.getPath().startsWith("file:")) + pathname = new Pathname(url); + truename = getPath(url); + } + catch (IOException e) { + in = null; + } + } + } + if (in != null) { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); + try { + return loadFileFromStream(pathname, truename, + new Stream(in, Symbol.CHARACTER), + verbose, print, auto); + } + catch (FaslVersionMismatch e) { + FastStringBuffer sb = + new FastStringBuffer("; Incorrect fasl version: "); + sb.append(truename); + System.err.println(sb.toString()); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + try { + in.close(); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + } + } + finally { + if (zipfile != null) { + try { + zipfile.close(); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + } + } + return error(new LispError("File not found: " + filename)); + } + + // ### *fasl-version* + // internal symbol + private static final Symbol _FASL_VERSION_ = + exportConstant("*FASL-VERSION*", PACKAGE_SYS, new Fixnum(29)); + + // ### *fasl-anonymous-package* + // internal symbol + public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = + internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); + + // ### init-fasl + private static final Primitive INIT_FASL = + new Primitive("init-fasl", PACKAGE_SYS, true, "&key version") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first == Keyword.VERSION) { + if (second.eql(_FASL_VERSION_.getSymbolValue())) { + // OK + final LispThread thread = LispThread.currentThread(); + thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, NIL); + thread.bindSpecial(_SOURCE_, NIL); + return faslLoadStream(thread); + } + } + throw new FaslVersionMismatch(second); + } + }; + + private static final LispObject loadFileFromStream(LispObject pathname, + String truename, + Stream in, + boolean verbose, + boolean print, + boolean auto) + throws ConditionThrowable + { + long start = System.currentTimeMillis(); + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + // "LOAD binds *READTABLE* and *PACKAGE* to the values they held before + // loading the file." + thread.bindSpecialToCurrentValue(Symbol.CURRENT_READTABLE); + thread.bindSpecialToCurrentValue(Symbol._PACKAGE_); + int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue(thread)); + thread.bindSpecial(_LOAD_DEPTH_, new Fixnum(++loadDepth)); + // Compiler policy. + thread.bindSpecialToCurrentValue(_SPEED_); + thread.bindSpecialToCurrentValue(_SPACE_); + thread.bindSpecialToCurrentValue(_SAFETY_); + thread.bindSpecialToCurrentValue(_DEBUG_); + thread.bindSpecialToCurrentValue(_EXPLAIN_); + final String prefix = getLoadVerbosePrefix(loadDepth); + try { + if (pathname == null && truename != null) + pathname = Pathname.parseNamestring(truename); + thread.bindSpecial(Symbol.LOAD_PATHNAME, + pathname != null ? pathname : NIL); + thread.bindSpecial(Symbol.LOAD_TRUENAME, + pathname != null ? pathname : NIL); + thread.bindSpecial(_SOURCE_, + pathname != null ? pathname : NIL); + if (verbose) { + Stream out = getStandardOutput(); + out.freshLine(); + out._writeString(prefix); + out._writeString(auto ? " Autoloading " : " Loading "); + out._writeString(truename != null ? truename : "stream"); + out._writeLine(" ..."); + out._finishOutput(); + LispObject result = loadStream(in, print, thread); + long elapsed = System.currentTimeMillis() - start; + out.freshLine(); + out._writeString(prefix); + out._writeString(auto ? " Autoloaded " : " Loaded "); + out._writeString(truename != null ? truename : "stream"); + out._writeString(" ("); + out._writeString(String.valueOf(((float)elapsed)/1000)); + out._writeLine(" seconds)"); + out._finishOutput(); + return result; + } else + return loadStream(in, print, thread); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + public static String getLoadVerbosePrefix(int loadDepth) + { + FastStringBuffer sb = new FastStringBuffer(";"); + for (int i = loadDepth - 1; i-- > 0;) + sb.append(' '); + return sb.toString(); + } + + private static final LispObject loadStream(Stream in, boolean print, + LispThread thread) + throws ConditionThrowable + { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(_LOAD_STREAM_, in); + SpecialBinding sourcePositionBinding = + new SpecialBinding(_SOURCE_POSITION_, Fixnum.ZERO, + thread.lastSpecialBinding); + thread.lastSpecialBinding = sourcePositionBinding; + try { + final Environment env = new Environment(); + while (true) { + sourcePositionBinding.value = new Fixnum(in.getOffset()); + LispObject obj = in.read(false, EOF, false, thread); + if (obj == EOF) + break; + LispObject result = eval(obj, env, thread); + if (print) { + Stream out = + checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); + out._writeLine(result.writeToString()); + out._finishOutput(); + } + } + return T; + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + private static final LispObject faslLoadStream(LispThread thread) + throws ConditionThrowable + { + Stream in = (Stream) _LOAD_STREAM_.symbolValue(thread); + final Environment env = new Environment(); + while (true) { + LispObject obj = in.faslRead(false, EOF, true, thread); + if (obj == EOF) + break; + eval(obj, env, thread); + } + return T; + } + + // Returns extension including leading '.' + private static final String getExtension(String filename) + { + int index = filename.lastIndexOf('.'); + if (index < 0) + return null; + if (index < filename.lastIndexOf(File.separatorChar)) + return null; // Last dot was in path part of filename. + return filename.substring(index); + } + + private static final String getPath(URL url) + { + if (url != null) { + String path = url.getPath(); + if (path != null) { + if (Utilities.isPlatformWindows) { + if (path.length() > 0 && path.charAt(0) == '/') + path = path.substring(1); + } + return path; + } + } + return null; + } + + private static final boolean checkZipFile(File file) + { + InputStream in = null; + try { + in = new FileInputStream(file); + byte[] bytes = new byte[4]; + int bytesRead = in.read(bytes); + return (bytesRead == 4 + && bytes[0] == 0x50 + && bytes[1] == 0x4b + && bytes[2] == 0x03 + && bytes[3] == 0x04); + } + catch (Throwable t) { + return false; + } + finally { + if (in != null) { + try { + in.close(); + } + catch (Throwable t) {} + } + } + } + + // ### %load filespec verbose print if-does-not-exist => generalized-boolean + private static final Primitive _LOAD = + new Primitive("%load", PACKAGE_SYS, false, + "filespec verbose print if-does-not-exist") + { + @Override + public LispObject execute(LispObject filespec, LispObject verbose, + LispObject print, LispObject ifDoesNotExist) + throws ConditionThrowable + { + if (filespec instanceof Stream) { + if (((Stream)filespec).isOpen()) { + LispObject pathname; + if (filespec instanceof FileStream) + pathname = ((FileStream)filespec).getPathname(); + else + pathname = NIL; + String truename; + if (pathname instanceof Pathname) + truename = ((Pathname)pathname).getNamestring(); + else + truename = null; + return loadFileFromStream(pathname, + truename, + (Stream) filespec, + verbose != NIL, + print != NIL, + false); + } + // If stream is closed, fall through... + } + Pathname pathname = coerceToPathname(filespec); + if (pathname instanceof LogicalPathname) + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); + return load(pathname, + pathname.getNamestring(), + verbose != NIL, + print != NIL, + ifDoesNotExist != NIL); + } + }; + + // ### load-system-file + private static final Primitive LOAD_SYSTEM_FILE = + new Primitive("load-system-file", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + return loadSystemFile(arg.getStringValue(), + Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, + Symbol.LOAD_PRINT.symbolValue(thread) != NIL, + false); + } + }; + + private static class FaslVersionMismatch extends Error + { + private final LispObject version; + + public FaslVersionMismatch(LispObject version) + { + this.version = version; + } + + public LispObject getVersion() + { + return version; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/LogicalPathname.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/LogicalPathname.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,328 @@ +/* + * LogicalPathname.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: LogicalPathname.java 11539 2009-01-04 14:27:54Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.HashMap; +import java.util.StringTokenizer; + +public final class LogicalPathname extends Pathname +{ + private static final String LOGICAL_PATHNAME_CHARS = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-;*."; + + private static final HashMap map = new HashMap(); + + public LogicalPathname() + { + } + + public LogicalPathname(String host, String rest) throws ConditionThrowable + { + final int limit = rest.length(); + for (int i = 0; i < limit; i++) { + char c = rest.charAt(i); + if (LOGICAL_PATHNAME_CHARS.indexOf(c) < 0) { + error(new ParseError("The character #\\" + c + " is not valid in a logical pathname.")); + return; + } + } + + this.host = new SimpleString(host); + + // "The device component of a logical pathname is always :UNSPECIFIC; + // no other component of a logical pathname can be :UNSPECIFIC." + device = Keyword.UNSPECIFIC; + + int semi = rest.lastIndexOf(';'); + if (semi >= 0) { + // Directory. + String d = rest.substring(0, semi + 1); + directory = parseDirectory(d); + rest = rest.substring(semi + 1); + } else { + // "If a relative-directory-marker precedes the directories, the + // directory component parsed is as relative; otherwise, the + // directory component is parsed as absolute." + directory = new Cons(Keyword.ABSOLUTE); + } + + int dot = rest.indexOf('.'); + if (dot >= 0) { + String n = rest.substring(0, dot); + if (n.equals("*")) + name = Keyword.WILD; + else + name = new SimpleString(n.toUpperCase()); + rest = rest.substring(dot + 1); + dot = rest.indexOf('.'); + if (dot >= 0) { + String t = rest.substring(0, dot); + if (t.equals("*")) + type = Keyword.WILD; + else + type = new SimpleString(t.toUpperCase()); + // What's left is the version. + String v = rest.substring(dot + 1); + if (v.equals("*")) + version = Keyword.WILD; + else if (v.equals("NEWEST") || v.equals("newest")) + version = Keyword.NEWEST; + else + version = PACKAGE_CL.intern("PARSE-INTEGER").execute(new SimpleString(v)); + } else { + String t = rest; + if (t.equals("*")) + type = Keyword.WILD; + else + type = new SimpleString(t.toUpperCase()); + } + } else { + String n = rest; + if (n.equals("*")) + name = Keyword.WILD; + else if (n.length() > 0) + name = new SimpleString(n.toUpperCase()); + } + } + + private static final String LOGICAL_PATHNAME_COMPONENT_CHARS = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-"; + + public static final SimpleString canonicalizeStringComponent(AbstractString s) + throws ConditionThrowable + { + final int limit = s.length(); + for (int i = 0; i < limit; i++) { + char c = s.charAt(i); + if (LOGICAL_PATHNAME_COMPONENT_CHARS.indexOf(c) < 0) { + error(new ParseError("Invalid character #\\" + c + + " in logical pathname component \"" + s + + '"')); + // Not reached. + return null; + } + } + return new SimpleString(s.getStringValue().toUpperCase()); + } + + public static Pathname translateLogicalPathname(LogicalPathname pathname) + throws ConditionThrowable + { + return (Pathname) Symbol.TRANSLATE_LOGICAL_PATHNAME.execute(pathname); + } + + private static final LispObject parseDirectory(String s) + throws ConditionThrowable + { + LispObject result; + if (s.charAt(0) == ';') { + result = new Cons(Keyword.RELATIVE); + s = s.substring(1); + } else + result = new Cons(Keyword.ABSOLUTE); + StringTokenizer st = new StringTokenizer(s, ";"); + while (st.hasMoreTokens()) { + String token = st.nextToken(); + LispObject obj; + if (token.equals("*")) + obj = Keyword.WILD; + else if (token.equals("**")) + obj = Keyword.WILD_INFERIORS; + else if (token.equals("..")) { + if (result.car() instanceof AbstractString) { + result = result.cdr(); + continue; + } + obj= Keyword.UP; + } else + obj = new SimpleString(token.toUpperCase()); + result = new Cons(obj, result); + } + return result.nreverse(); + } + + @Override + public LispObject typeOf() + { + return Symbol.LOGICAL_PATHNAME; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.LOGICAL_PATHNAME; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.LOGICAL_PATHNAME) + return T; + if (type == BuiltInClass.LOGICAL_PATHNAME) + return T; + return super.typep(type); + } + + @Override + protected String getDirectoryNamestring() throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(); + // "If a pathname is converted to a namestring, the symbols NIL and + // :UNSPECIFIC cause the field to be treated as if it were empty. That + // is, both NIL and :UNSPECIFIC cause the component not to appear in + // the namestring." 19.2.2.2.3.1 + if (directory != NIL) { + LispObject temp = directory; + LispObject part = temp.car(); + if (part == Keyword.ABSOLUTE) { + } else if (part == Keyword.RELATIVE) + sb.append(';'); + else + error(new FileError("Unsupported directory component " + part.writeToString() + ".", + this)); + temp = temp.cdr(); + while (temp != NIL) { + part = temp.car(); + if (part instanceof AbstractString) + sb.append(part.getStringValue()); + else if (part == Keyword.WILD) + sb.append('*'); + else if (part == Keyword.WILD_INFERIORS) + sb.append("**"); + else if (part == Keyword.UP) + sb.append(".."); + else + error(new FileError("Unsupported directory component " + part.writeToString() + ".", + this)); + sb.append(';'); + temp = temp.cdr(); + } + } + return sb.toString(); + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + FastStringBuffer sb = new FastStringBuffer(); + if (printReadably || printEscape) + sb.append("#P\""); + sb.append(host.getStringValue()); + sb.append(':'); + if (directory != NIL) + sb.append(getDirectoryNamestring()); + if (name != NIL) { + if (name == Keyword.WILD) + sb.append('*'); + else + sb.append(name.getStringValue()); + } + if (type != NIL) { + sb.append('.'); + if (type == Keyword.WILD) + sb.append('*'); + else + sb.append(type.getStringValue()); + } + if (version.integerp()) { + sb.append('.'); + int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); + if (version instanceof Fixnum) + sb.append(Integer.toString(((Fixnum)version).value, base).toUpperCase()); + else if (version instanceof Bignum) + sb.append(((Bignum)version).value.toString(base).toUpperCase()); + } else if (version == Keyword.WILD) { + sb.append(".*"); + } else if (version == Keyword.NEWEST) { + sb.append(".NEWEST"); + } + if (printReadably || printEscape) + sb.append('"'); + return sb.toString(); + } + + // ### canonicalize-logical-host host => canonical-host + private static final Primitive CANONICALIZE_LOGICAL_HOST = + new Primitive("canonicalize-logical-host", PACKAGE_SYS, true, "host") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + try { + AbstractString s = (AbstractString) arg; + if (s.length() == 0) { + // "The null string, "", is not a valid value for any + // component of a logical pathname." 19.3.2.2 + return error(new LispError("Invalid logical host name: \"" + + s.getStringValue() + '"')); + } + return canonicalizeStringComponent(s); + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STRING); + } + } + }; + + // ### %make-logical-pathname namestring => logical-pathname + private static final Primitive _MAKE_LOGICAL_PATHNAME = + new Primitive("%make-logical-pathname", PACKAGE_SYS, true, "namestring") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + // Check for a logical pathname host. + String s = arg.getStringValue(); + String h = getHostString(s); + if (h != null) { + if (h.length() == 0) { + // "The null string, "", is not a valid value for any + // component of a logical pathname." 19.3.2.2 + return error(new LispError("Invalid logical host name: \"" + + h + '"')); + } + if (Pathname.LOGICAL_PATHNAME_TRANSLATIONS.get(new SimpleString(h)) != null) { + // A defined logical pathname host. + return new LogicalPathname(h, s.substring(s.indexOf(':') + 1)); + } + } + return error(new TypeError("Logical namestring does not specify a host: \"" + s + '"')); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/MacroObject.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/MacroObject.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,134 @@ +/* + * MacroObject.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: MacroObject.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class MacroObject extends Function +{ + private final LispObject name; + public final LispObject expander; + + public MacroObject(LispObject name, LispObject expander) + { + this.name = name; + this.expander = expander; + if (name instanceof Symbol && name != NIL && expander instanceof Function) + ((Function)expander).setLambdaName(list2(Symbol.MACRO_FUNCTION, + name)); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return error(new UndefinedFunction(name)); + } + + @Override + public String writeToString() + { + return unreadableString("MACRO-OBJECT"); + } +} Added: branches/save-image/src/org/armedbear/lisp/Mailbox.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Mailbox.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,199 @@ +/* + * Mailbox.java + * + * Copyright (C) 2004-2007 Peter Graves, Andras Simon + * $Id: Mailbox.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.LinkedList; +import java.util.NoSuchElementException; + +public final class Mailbox extends LispObject +{ + private LinkedList box = new LinkedList(); + + @Override + public LispObject typeOf() + { + return Symbol.MAILBOX; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.MAILBOX; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.MAILBOX) + return T; + if (typeSpecifier == BuiltInClass.MAILBOX) + return T; + return super.typep(typeSpecifier); + } + + private void send(LispObject o) + { + synchronized(this) + { + box.add(o); + notify(); + } + } + + private LispObject read() + { + synchronized(this) + { + while (box.isEmpty()) + { + try + { + wait(); + } + catch(InterruptedException e) + { + throw new RuntimeException(e); + } + } + return (LispObject) box.removeFirst(); + } + } + + private LispObject peek() + { + synchronized(this) + { + try + { + return (LispObject) box.getFirst(); + } + catch(NoSuchElementException e) + { + return NIL; + } + } + } + + private LispObject empty() + { + return box.isEmpty() ? T : NIL; + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.MAILBOX); + } + + // ### make-mailbox + private static final Primitive MAKE_MAILBOX = + new Primitive("make-mailbox", PACKAGE_EXT, true, "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new Mailbox(); + } + }; + + // ### mailbox-send mailbox object + private static final Primitive MAILBOX_SEND = + new Primitive("mailbox-send", PACKAGE_EXT, true, "mailbox object") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Mailbox) + { + Mailbox mbox = (Mailbox) first; + mbox.send(second); + return T; + } + else + return type_error(first, Symbol.MAILBOX); + } + }; + + // ### mailbox-read mailbox + private static final Primitive MAILBOX_READ = + new Primitive("mailbox-read", PACKAGE_EXT, true, "mailbox") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Mailbox) + { + Mailbox mbox = (Mailbox) arg; + return mbox.read(); + } + else + return type_error(arg, Symbol.MAILBOX); + } + }; + + // ### mailbox-peek mailbox + private static final Primitive MAILBOX_PEEK = + new Primitive("mailbox-peek", PACKAGE_EXT, true, "mailbox") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Mailbox) + { + Mailbox mbox = (Mailbox) arg; + return mbox.peek(); + } + else + return type_error(arg, Symbol.MAILBOX); + } + }; + + // ### mailbox-empty-p mailbox + private static final Primitive MAILBOX_EMPTY_P = + new Primitive("mailbox-empty-p", PACKAGE_EXT, true, "mailbox") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Mailbox) + { + Mailbox mbox = (Mailbox) arg; + return mbox.empty(); + } + else + return type_error(arg, Symbol.MAILBOX); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Main.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Main.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,55 @@ +/* + * Main.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: Main.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Main +{ + public static final long startTimeMillis = System.currentTimeMillis(); + + public static void main(final String[] args) + { + // Run the interpreter in a secondary thread so we can control the stack + // size. + Runnable r = new Runnable() + { + public void run() + { + Interpreter interpreter = Interpreter.createDefaultInstance(args); + if (interpreter != null) + interpreter.run(); + } + }; + new Thread(null, r, "interpreter", 4194304L).start(); + } +} Added: branches/save-image/src/org/armedbear/lisp/MathFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/MathFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,877 @@ +/* + * MathFunctions.java + * + * Copyright (C) 2004-2006 Peter Graves + * $Id: MathFunctions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.lang.reflect.Method; + +public final class MathFunctions extends Lisp +{ + // ### sin + private static final Primitive SIN = new Primitive("sin", "radians") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return sin(arg); + } + }; + + private static LispObject sin(LispObject arg) throws ConditionThrowable + { + if (arg instanceof DoubleFloat) + return new DoubleFloat(Math.sin(((DoubleFloat)arg).value)); + if (arg.realp()) + return new SingleFloat((float)Math.sin(SingleFloat.coerceToFloat(arg).value)); + if (arg instanceof Complex) { + LispObject n = arg.multiplyBy(Complex.getInstance(Fixnum.ZERO, + Fixnum.ONE)); + LispObject result = exp(n); + result = result.subtract(exp(n.multiplyBy(Fixnum.MINUS_ONE))); + return result.divideBy(Fixnum.TWO.multiplyBy(Complex.getInstance(Fixnum.ZERO, + Fixnum.ONE))); + } + return type_error(arg, Symbol.NUMBER); + } + + // ### cos + private static final Primitive COS = new Primitive("cos", "radians") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return cos(arg); + } + }; + + private static LispObject cos(LispObject arg) throws ConditionThrowable + { + if (arg instanceof DoubleFloat) + return new DoubleFloat(Math.cos(((DoubleFloat)arg).value)); + if (arg.realp()) + return new SingleFloat((float)Math.cos(SingleFloat.coerceToFloat(arg).value)); + if (arg instanceof Complex) { + LispObject n = arg.multiplyBy(Complex.getInstance(Fixnum.ZERO, + Fixnum.ONE)); + LispObject result = exp(n); + result = result.add(exp(n.multiplyBy(Fixnum.MINUS_ONE))); + return result.divideBy(Fixnum.TWO); + } + return type_error(arg, Symbol.NUMBER); + } + + // ### tan + private static final Primitive TAN = new Primitive("tan", "radians") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof DoubleFloat) + return new DoubleFloat(Math.tan(((DoubleFloat)arg).value)); + if (arg.realp()) + return new SingleFloat((float)Math.tan(SingleFloat.coerceToFloat(arg).value)); + return sin(arg).divideBy(cos(arg)); + } + }; + + // ### asin + private static final Primitive ASIN = new Primitive("asin", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return asin(arg); + } + }; + + private static LispObject asin(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) { + float f = ((SingleFloat)arg).value; + if (Math.abs(f) <= 1) + return new SingleFloat((float)Math.asin(f)); + } + if (arg instanceof DoubleFloat) { + double d = ((DoubleFloat)arg).value; + if (Math.abs(d) <= 1) + return new DoubleFloat(Math.asin(d)); + } + LispObject result = arg.multiplyBy(arg); + result = Fixnum.ONE.subtract(result); + result = sqrt(result); + LispObject n = Complex.getInstance(Fixnum.ZERO, Fixnum.ONE); + n = n.multiplyBy(arg); + result = n.add(result); + result = log(result); + result = result.multiplyBy(Complex.getInstance(Fixnum.ZERO, + Fixnum.MINUS_ONE)); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + // ### acos + private static final Primitive ACOS = new Primitive("acos", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return acos(arg); + } + }; + + private static LispObject acos(LispObject arg) throws ConditionThrowable + { + if (arg instanceof DoubleFloat) { + double d = ((DoubleFloat)arg).value; + if (Math.abs(d) <= 1) + return new DoubleFloat(Math.acos(d)); + } + if (arg instanceof SingleFloat) { + float f = ((SingleFloat)arg).value; + if (Math.abs(f) <= 1) + return new SingleFloat((float)Math.acos(f)); + } + LispObject result = new DoubleFloat(Math.PI/2); + if (!(arg instanceof DoubleFloat)) + result = new SingleFloat((float)((DoubleFloat)result).value); + result = result.subtract(asin(arg)); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + // ### atan + private static final Primitive ATAN = + new Primitive("atan", "number1 &optional number2") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg.numberp()) + return atan(arg); + return type_error(arg, Symbol.NUMBER); + } + + // "If both number1 and number2 are supplied for atan, the result is + // the arc tangent of number1/number2." + + // y = +0 x = +0 +0 + // y = -0 x = +0 -0 + // y = +0 x = -0 + + // y = -0 x = -0 - + @Override + public LispObject execute(LispObject y, LispObject x) + throws ConditionThrowable + { + if (!y.realp()) + return type_error(y, Symbol.REAL); + if (!x.realp()) + return type_error(x, Symbol.REAL); + double d1, d2; + d1 = DoubleFloat.coerceToFloat(y).value; + d2 = DoubleFloat.coerceToFloat(x).value; + double result = Math.atan2(d1, d2); + if (y instanceof DoubleFloat || x instanceof DoubleFloat) + return new DoubleFloat(result); + else + return new SingleFloat((float)result); + } + }; + + private static LispObject atan(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) { + LispObject im = ((Complex)arg).imagpart; + if (im.zerop()) + return Complex.getInstance(atan(((Complex)arg).realpart), + im); + LispObject result = arg.multiplyBy(arg); + result = result.add(Fixnum.ONE); + result = Fixnum.ONE.divideBy(result); + result = sqrt(result); + LispObject n = Complex.getInstance(Fixnum.ZERO, Fixnum.ONE); + n = n.multiplyBy(arg); + n = n.add(Fixnum.ONE); + result = n.multiplyBy(result); + result = log(result); + result = result.multiplyBy(Complex.getInstance(Fixnum.ZERO, Fixnum.MINUS_ONE)); + return result; + } + if (arg instanceof DoubleFloat) + return new DoubleFloat(Math.atan(((DoubleFloat)arg).value)); + return new SingleFloat((float)Math.atan(SingleFloat.coerceToFloat(arg).value)); + } + + // ### sinh + private static final Primitive SINH = new Primitive("sinh", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return sinh(arg); + } + }; + + private static Method sinhMethod = null; + static { + try { + sinhMethod = Class.forName("java.lang.Math") + .getMethod("sinh", new Class[] { Double.TYPE }); + } + catch (Throwable t) { + Debug.trace(t); + } + } + + private static LispObject sinh(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) { + LispObject im = ((Complex)arg).getImaginaryPart(); + if (im.zerop()) + return Complex.getInstance(sinh(((Complex)arg).getRealPart()), + im); + } + if (arg instanceof SingleFloat) { + try { + if (sinhMethod != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(((SingleFloat)arg).value); + Double d = (Double) sinhMethod.invoke(null, args); + return new SingleFloat((float)d.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } else if (arg instanceof DoubleFloat) { + try { + if (sinhMethod != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(((DoubleFloat)arg).value); + Double d = (Double) sinhMethod.invoke(null, args); + return new DoubleFloat(d.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } + LispObject result = exp(arg); + result = result.subtract(exp(arg.multiplyBy(Fixnum.MINUS_ONE))); + result = result.divideBy(Fixnum.TWO); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + // ### cosh + private static final Primitive COSH = new Primitive("cosh", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return cosh(arg); + } + }; + + private static Method coshMethod = null; + static { + try { + coshMethod = Class.forName("java.lang.Math") + .getMethod("cosh", new Class[] { Double.TYPE }); + } + catch (Throwable t) { + Debug.trace(t); + } + } + + private static LispObject cosh(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) { + LispObject im = ((Complex)arg).getImaginaryPart(); + if (im.zerop()) + return Complex.getInstance(cosh(((Complex)arg).getRealPart()), + im); + } + if (arg instanceof SingleFloat) { + try { + if (coshMethod != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(((SingleFloat)arg).value); + Double d = (Double) coshMethod.invoke(null, args); + return new SingleFloat((float)d.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } else if (arg instanceof DoubleFloat) { + try { + if (coshMethod != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(((DoubleFloat)arg).value); + Double d = (Double) coshMethod.invoke(null, args); + return new DoubleFloat(d.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } + LispObject result = exp(arg); + result = result.add(exp(arg.multiplyBy(Fixnum.MINUS_ONE))); + result = result.divideBy(Fixnum.TWO); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + private static Method tanhMethod = null; + static { + try { + tanhMethod = Class.forName("java.lang.Math") + .getMethod("tanh", new Class[] { Double.TYPE }); + } + catch (Throwable t) { + Debug.trace(t); + } + } + + // ### tanh + private static final Primitive TANH = new Primitive("tanh", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) { + try { + if (tanhMethod != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(((SingleFloat)arg).value); + Double d = (Double) tanhMethod.invoke(null, args); + return new SingleFloat((float)d.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } else if (arg instanceof DoubleFloat) { + try { + if (tanhMethod != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(((DoubleFloat)arg).value); + Double d = (Double) tanhMethod.invoke(null, args); + return new DoubleFloat(d.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } + return sinh(arg).divideBy(cosh(arg)); + } + }; + + // ### asinh + private static final Primitive ASINH = new Primitive("asinh", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return asinh(arg); + } + }; + + private static LispObject asinh(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) { + LispObject im = ((Complex)arg).getImaginaryPart(); + if (im.zerop()) + return Complex.getInstance(asinh(((Complex)arg).getRealPart()), + im); + } + LispObject result = arg.multiplyBy(arg); + result = Fixnum.ONE.add(result); + result = sqrt(result); + result = result.add(arg); + result = log(result); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + // ### acosh + private static final Primitive ACOSH = new Primitive("acosh", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return acosh(arg); + } + }; + + private static LispObject acosh(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) { + LispObject im = ((Complex)arg).getImaginaryPart(); + if (im.zerop()) + return Complex.getInstance(acosh(((Complex)arg).getRealPart()), + im); + } + LispObject n1 = arg.add(Fixnum.ONE); + n1 = n1.divideBy(Fixnum.TWO); + n1 = sqrt(n1); + LispObject n2 = arg.subtract(Fixnum.ONE); + n2 = n2.divideBy(Fixnum.TWO); + n2 = sqrt(n2); + LispObject result = n1.add(n2); + result = log(result); + result = result.multiplyBy(Fixnum.TWO); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + // ### atanh + private static final Primitive ATANH = new Primitive("atanh", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return atanh(arg); + } + }; + + private static LispObject atanh(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) { + LispObject im = ((Complex)arg).getImaginaryPart(); + if (im.zerop()) + return Complex.getInstance(atanh(((Complex)arg).getRealPart()), + im); + } + LispObject n1 = log(Fixnum.ONE.add(arg)); + LispObject n2 = log(Fixnum.ONE.subtract(arg)); + LispObject result = n1.subtract(n2); + result = result.divideBy(Fixnum.TWO); + if (result instanceof Complex) { + if (arg instanceof Complex) + return result; + LispObject im = ((Complex)result).getImaginaryPart(); + if (im.zerop()) + return ((Complex)result).getRealPart(); + } + return result; + } + + // ### cis + private static final Primitive CIS = new Primitive("cis", "radians") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return cis(arg); + } + }; + + private static LispObject cis(LispObject arg) throws ConditionThrowable + { + if (arg.realp()) + return Complex.getInstance(cos(arg), sin(arg)); + return type_error(arg, Symbol.REAL); + } + + // ### exp + private static final Primitive EXP = new Primitive("exp", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return exp(arg); + } + }; + + private static LispObject exp(LispObject arg) throws ConditionThrowable + { + if (arg.realp()) { + if (arg instanceof DoubleFloat) { + double d = Math.pow(Math.E, ((DoubleFloat)arg).value); + if (TRAP_OVERFLOW && Double.isInfinite(d)) + return error(new FloatingPointOverflow(NIL)); + if (d == 0 && TRAP_UNDERFLOW) + return error(new FloatingPointUnderflow(NIL)); + return new DoubleFloat(d); + } else { + float f = (float) Math.pow(Math.E, SingleFloat.coerceToFloat(arg).value); + if (TRAP_OVERFLOW && Float.isInfinite(f)) + return error(new FloatingPointOverflow(NIL)); + if (f == 0 && TRAP_UNDERFLOW) + return error(new FloatingPointUnderflow(NIL)); + return new SingleFloat(f); + } + } + if (arg instanceof Complex) { + Complex c = (Complex) arg; + return exp(c.getRealPart()).multiplyBy(cis(c.getImaginaryPart())); + } + return type_error(arg, Symbol.NUMBER); + } + + // ### sqrt + private static final Primitive SQRT = new Primitive("sqrt", "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return sqrt(arg); + } + }; + + private static final LispObject sqrt(LispObject obj) throws ConditionThrowable + { + if (obj instanceof DoubleFloat) { + if (obj.minusp()) + return Complex.getInstance(new DoubleFloat(0), sqrt(obj.negate())); + return new DoubleFloat(Math.sqrt(DoubleFloat.coerceToFloat(obj).value)); + } + if (obj.realp()) { + if (obj.minusp()) + return Complex.getInstance(new SingleFloat(0), sqrt(obj.negate())); + return new SingleFloat((float)Math.sqrt(SingleFloat.coerceToFloat(obj).value)); + } + if (obj instanceof Complex) { + LispObject imagpart = ((Complex)obj).imagpart; + if (imagpart.zerop()) { + LispObject realpart = ((Complex)obj).realpart; + if (realpart.minusp()) + return Complex.getInstance(imagpart, sqrt(realpart.negate())); + else + return Complex.getInstance(sqrt(realpart), imagpart); + } + return exp(log(obj).divideBy(Fixnum.TWO)); + } + return type_error(obj, Symbol.NUMBER); + } + + private static Method log10Method = null; + static { + try { + log10Method = Class.forName("java.lang.Math") + .getMethod("log10", new Class[] { Double.TYPE }); + } + catch (Throwable t) { + Debug.trace(t); + } + } + + // ### log + private static final Primitive LOG = + new Primitive("log", "number &optional base") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return log(arg); + } + @Override + public LispObject execute(LispObject number, LispObject base) + throws ConditionThrowable + { + if (number.realp() && !number.minusp() && base.isEqualTo(new Fixnum(10))) { + double d = DoubleFloat.coerceToFloat(number).value; + try { + if (log10Method != null) { + Object[] args; + args = new Object[1]; + args[0] = new Double(d); + Double result = (Double) log10Method.invoke(null, args); + if (number instanceof DoubleFloat || base instanceof DoubleFloat) + return new DoubleFloat(result.doubleValue()); + else + return new SingleFloat((float)result.doubleValue()); + } + } + catch (Throwable t) { + Debug.trace(t); + // Fall through... + } + } + return log(number).divideBy(log(base)); + } + }; + + private static final LispObject log(LispObject obj) throws ConditionThrowable + { + if (obj.realp() && !obj.minusp()) { + // Result is real. + if (obj instanceof Fixnum) + return new SingleFloat((float)Math.log(((Fixnum)obj).value)); + if (obj instanceof Bignum) + return new SingleFloat((float)Math.log(((Bignum)obj).doubleValue())); + if (obj instanceof Ratio) + return new SingleFloat((float)Math.log(((Ratio)obj).doubleValue())); + if (obj instanceof SingleFloat) + return new SingleFloat((float)Math.log(((SingleFloat)obj).value)); + if (obj instanceof DoubleFloat) + return new DoubleFloat(Math.log(((DoubleFloat)obj).value)); + } else { + // Result is complex. + if (obj.realp() && obj.minusp()) { + if (obj instanceof DoubleFloat) { + DoubleFloat re = DoubleFloat.coerceToFloat(obj); + DoubleFloat abs = new DoubleFloat(Math.abs(re.value)); + DoubleFloat phase = new DoubleFloat(Math.PI); + return Complex.getInstance(new DoubleFloat(Math.log(abs.getValue())), phase); + } else { + SingleFloat re = SingleFloat.coerceToFloat(obj); + SingleFloat abs = new SingleFloat(Math.abs(re.value)); + SingleFloat phase = new SingleFloat((float)Math.PI); + return Complex.getInstance(new SingleFloat((float)Math.log(abs.value)), phase); + } + } else if (obj instanceof Complex) { + if (((Complex)obj).getRealPart() instanceof DoubleFloat) { + DoubleFloat re = DoubleFloat.coerceToFloat(((Complex)obj).getRealPart()); + DoubleFloat im = DoubleFloat.coerceToFloat(((Complex)obj).getImaginaryPart()); + DoubleFloat phase = + new DoubleFloat(Math.atan2(im.getValue(), re.getValue())); // atan(y/x) + DoubleFloat abs = DoubleFloat.coerceToFloat(obj.ABS()); + return Complex.getInstance(new DoubleFloat(Math.log(abs.getValue())), phase); + } else { + SingleFloat re = SingleFloat.coerceToFloat(((Complex)obj).getRealPart()); + SingleFloat im = SingleFloat.coerceToFloat(((Complex)obj).getImaginaryPart()); + SingleFloat phase = + new SingleFloat((float)Math.atan2(im.value, re.value)); // atan(y/x) + SingleFloat abs = SingleFloat.coerceToFloat(obj.ABS()); + return Complex.getInstance(new SingleFloat((float)Math.log(abs.value)), phase); + } + } + } + type_error(obj, Symbol.NUMBER); + return NIL; + } + + // ### expt base-number power-number => result + public static final Primitive EXPT = + new Primitive("expt", "base-number power-number") + { + @Override + public LispObject execute(LispObject base, LispObject power) + throws ConditionThrowable + { + if (power.zerop()) { + if (power instanceof Fixnum) { + if (base instanceof SingleFloat) + return SingleFloat.ONE; + if (base instanceof DoubleFloat) + return DoubleFloat.ONE; + if (base instanceof Complex) { + if (((Complex)base).realpart instanceof SingleFloat) + return Complex.getInstance(SingleFloat.ONE, + SingleFloat.ZERO); + if (((Complex)base).realpart instanceof DoubleFloat) + return Complex.getInstance(DoubleFloat.ONE, + DoubleFloat.ZERO); + } + return Fixnum.ONE; + } + if (power instanceof DoubleFloat) + return DoubleFloat.ONE; + if (base instanceof DoubleFloat) + return DoubleFloat.ONE; + return SingleFloat.ONE; + } + if (base.zerop()) + return base; + if (power instanceof Fixnum) { + if (base.rationalp()) + return intexp(base, power); + LispObject result; + if (base instanceof SingleFloat) + result = SingleFloat.ONE; + else if (base instanceof DoubleFloat) + result = DoubleFloat.ONE; + else + // base is complex + result = Fixnum.ONE; + int pow = ((Fixnum)power).value; + if (pow > 0) { + LispObject term = base; + while (pow != 0) { + if ((pow & 1) == 1) + result = result.multiplyBy(term); + + term = term.multiplyBy(term); + pow = pow >> 1; + } + } else if (pow < 0) { + LispObject term = base; + pow = -pow; + while (pow != 0) { + if ((pow & 1) == 1) + result = result.divideBy(term); + + term = term.multiplyBy(term); + pow = pow >> 1; + } + } + if (TRAP_OVERFLOW) { + if (result instanceof SingleFloat) + if (Float.isInfinite(((SingleFloat)result).value)) + return error(new FloatingPointOverflow(NIL)); + if (result instanceof DoubleFloat) + if (Double.isInfinite(((DoubleFloat)result).value)) + return error(new FloatingPointOverflow(NIL)); + } + if (TRAP_UNDERFLOW) { + if (result.zerop()) + return error(new FloatingPointUnderflow(NIL)); + } + return result; + } + if (base instanceof Fixnum && power instanceof Bignum) + return ((Fixnum)base).pow(power); + if (base instanceof Complex || power instanceof Complex) + return exp(power.multiplyBy(log(base))); + final double x; // base + final double y; // power + if (base instanceof Fixnum) + x = ((Fixnum)base).value; + else if (base instanceof Ratio) + x = ((Ratio)base).doubleValue(); + else if (base instanceof SingleFloat) + x = ((SingleFloat)base).value; + else if (base instanceof DoubleFloat) + x = ((DoubleFloat)base).value; + else + return error(new LispError("EXPT: unsupported case: base is of type " + + base.typeOf().writeToString())); + if (power instanceof Ratio) + y = ((Ratio)power).doubleValue(); + else if (power instanceof SingleFloat) + y = ((SingleFloat)power).value; + else if (power instanceof DoubleFloat) + y = ((DoubleFloat)power).value; + else + return error(new LispError("EXPT: unsupported case: power is of type " + + power.typeOf().writeToString())); + double r = Math.pow(x, y); + if (Double.isNaN(r)) { + if (x < 0) { + r = Math.pow(-x, y); + double realPart = r * Math.cos(y * Math.PI); + double imagPart = r * Math.sin(y * Math.PI); + if (base instanceof DoubleFloat || power instanceof DoubleFloat) + return Complex.getInstance(new DoubleFloat(realPart), + new DoubleFloat(imagPart)); + else + return Complex.getInstance(new SingleFloat((float)realPart), + new SingleFloat((float)imagPart)); + } + } + if (base instanceof DoubleFloat || power instanceof DoubleFloat) + return new DoubleFloat(r); + else + return new SingleFloat((float)r); + } + }; + + // Adapted from SBCL. + private static final LispObject intexp(LispObject base, LispObject power) + throws ConditionThrowable + { + if (power.minusp()) { + power = Fixnum.ZERO.subtract(power); + return Fixnum.ONE.divideBy(intexp(base, power)); + } + if (base.eql(Fixnum.TWO)) + return Fixnum.ONE.ash(power); + LispObject nextn = power.ash(Fixnum.MINUS_ONE); + LispObject total; + if (power.oddp()) + total = base; + else + total = Fixnum.ONE; + while (true) { + if (nextn.zerop()) + return total; + base = base.multiplyBy(base); + power = nextn; + nextn = power.ash(Fixnum.MINUS_ONE); + if (power.oddp()) + total = base.multiplyBy(total); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/Mutex.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Mutex.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,155 @@ +/* + * Mutex.java + * + * Copyright (C) 2004-2007 Peter Graves + * $Id: Mutex.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +/* + File: Mutex.java + + Originally written by Doug Lea and released into the public domain. + This may be used for any purposes whatsoever without acknowledgment. + Thanks for the assistance and support of Sun Microsystems Labs, + and everyone contributing, testing, and using this code. + + History: + Date Who What + 11Jun1998 dl Create public version +*/ + +package org.armedbear.lisp; + +public final class Mutex extends LispObject +{ + private boolean inUse; + + @Override + public LispObject typeOf() + { + return Symbol.MUTEX; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.MUTEX; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.MUTEX) + return T; + if (typeSpecifier == BuiltInClass.MUTEX) + return T; + return super.typep(typeSpecifier); + } + + public void acquire() throws InterruptedException + { + if (Thread.interrupted()) + throw new InterruptedException(); + synchronized (this) { + try { + while (inUse) + wait(); + inUse = true; + } + catch (InterruptedException e) { + notify(); + throw e; + } + } + } + + public synchronized void release() { + inUse = false; + notify(); + } + + + @Override + public String writeToString() + { + return unreadableString("MUTEX"); + } + + // ### make-mutex => mutex + private static final Primitive MAKE_MUTEX = + new Primitive("make-mutex", PACKAGE_EXT, true, "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new Mutex(); + } + }; + + // ### get-mutex mutex => generalized-boolean + private static final Primitive GET_MUTEX = + new Primitive("get-mutex", PACKAGE_EXT, true, "mutex") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + ((Mutex)arg).acquire(); + return T; + } + catch (ClassCastException e) { + return error(new TypeError("The value " + arg.writeToString() + + " is not a mutex.")); + } + catch (InterruptedException e) { + return error(new LispError( + "The thread " + LispThread.currentThread().writeToString() + + " was interrupted.")); + } + } + }; + + // ### release-mutex mutex + private static final Primitive RELEASE_MUTEX = + new Primitive("release-mutex", PACKAGE_EXT, true, "mutex") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + ((Mutex)arg).release(); + return T; + } + catch (ClassCastException e) { + return error(new TypeError("The value " + arg.writeToString() + + " is not a mutex.")); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Nil.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Nil.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,257 @@ +/* + * Nil.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: Nil.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Nil extends Symbol +{ + public Nil(Package pkg) + { + super("NIL", pkg); + pkg.addSymbol(this); + initializeConstant(this); + } + + @Override + public LispObject typeOf() + { + return Symbol.NULL; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.NULL; + } + + @Override + public LispObject getDescription() + { + return new SimpleString("The symbol NIL"); + } + + @Override + public boolean getBooleanValue() + { + return false; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.NULL) + return T; + if (typeSpecifier == Symbol.LIST) + return T; + if (typeSpecifier == Symbol.SEQUENCE) + return T; + if (typeSpecifier == Symbol.SYMBOL) + return T; + if (typeSpecifier == Symbol.BOOLEAN) + return T; + if (typeSpecifier == BuiltInClass.NULL) + return T; + if (typeSpecifier == BuiltInClass.LIST) + return T; + if (typeSpecifier == BuiltInClass.SEQUENCE) + return T; + if (typeSpecifier == BuiltInClass.SYMBOL) + return T; + return super.typep(typeSpecifier); + } + + @Override + public boolean constantp() + { + return true; + } + + @Override + public final LispObject getSymbolValue() + { + return this; + } + + @Override + public LispObject car() + { + return this; + } + + @Override + public LispObject cdr() + { + return this; + } + + @Override + public final LispObject cadr() + { + return this; + } + + @Override + public final LispObject cddr() + { + return this; + } + + @Override + public final LispObject caddr() + { + return this; + } + + @Override + public LispObject nthcdr(int n) throws ConditionThrowable + { + if (n < 0) + return type_error(new Fixnum(n), + list2(Symbol.INTEGER, Fixnum.ZERO)); + return this; + } + + @Override + public int length() + { + return 0; + } + + @Override + public LispObject push(LispObject obj) + { + return new Cons(obj); + } + + @Override + public LispObject NTH(int index) throws ConditionThrowable + { + if (index < 0) + error(new TypeError(String.valueOf(index) + + " is not of type UNSIGNED-BYTE.")); + return NIL; + } + + @Override + public LispObject NTH(LispObject arg) throws ConditionThrowable + { + int index; + try { + index = ((Fixnum)arg).value; + } + catch (ClassCastException e) { + if (arg instanceof Bignum) { + if (arg.minusp()) + return error(new TypeError(arg, Symbol.UNSIGNED_BYTE)); + return NIL; + } + return error(new TypeError(arg, Symbol.UNSIGNED_BYTE)); + } + if (index < 0) + error(new TypeError(arg, Symbol.UNSIGNED_BYTE)); + return NIL; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + return error(new TypeError("ELT: invalid index " + index + " for " + this + ".")); + } + + @Override + public LispObject reverse() + { + return this; + } + + @Override + public LispObject nreverse() + { + return this; + } + + @Override + public LispObject[] copyToArray() + { + return new LispObject[0]; + } + + @Override + public boolean listp() + { + return true; + } + + @Override + public LispObject LISTP() + { + return T; + } + + @Override + public boolean endp() + { + return true; + } + + @Override + public LispObject ENDP() + { + return T; + } + + @Override + public LispObject NOT() + { + return T; + } + + @Override + public final LispObject getSymbolFunction() + { + return null; + } + + @Override + public String toString() + { + if (Symbol.PRINT_READABLY.symbolValueNoThrow() != NIL) + return "|COMMON-LISP|::|NIL|"; + return "NIL"; + } + + public Object readResolve() throws java.io.ObjectStreamException { + return NIL; + } + +} Added: branches/save-image/src/org/armedbear/lisp/NilVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/NilVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,269 @@ +/* + * NilVector.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: NilVector.java 11557 2009-01-15 23:19:35Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class NilVector extends AbstractString +{ + private int capacity; + + public NilVector(int capacity) throws ConditionThrowable + { + this.capacity = capacity; + } + + @Override + public char[] chars() throws ConditionThrowable + { + if (capacity != 0) + accessError(); + return new char[0]; + } + + @Override + public char[] getStringChars() throws ConditionThrowable + { + if (capacity != 0) + accessError(); + return new char[0]; + } + + @Override + public String getStringValue() throws ConditionThrowable + { + if (capacity != 0) + accessError(); + return ""; + } + + @Override + public LispObject typeOf() + { + return list2(Symbol.NIL_VECTOR, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.NIL_VECTOR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.NIL_VECTOR) + return T; + if (type == Symbol.SIMPLE_STRING) + return T; + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.NIL_VECTOR) + return T; + if (type == BuiltInClass.SIMPLE_STRING) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(type); + } + + @Override + public LispObject SIMPLE_STRING_P() + { + return T; + } + + @Override + public boolean equal(LispObject obj) throws ConditionThrowable + { + if (obj instanceof NilVector) { + if (capacity != ((NilVector)obj).capacity) + return false; + if (capacity != 0) { + accessError(); + // Not reached. + return false; + } + return true; + } + if (obj instanceof AbstractString) { + if (capacity != obj.length()) + return false; + if (capacity != 0) { + accessError(); + // Not reached. + return false; + } + return true; + } + return false; + } + + public String getValue() throws ConditionThrowable + { + if (capacity == 0) + return ""; + accessError(); + // Not reached. + return null; + } + + @Override + public int length() + { + return capacity; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public LispObject getElementType() + { + return NIL; + } + + @Override + public LispObject CHAR(int index) throws ConditionThrowable + { + return accessError(); + } + + @Override + public LispObject SCHAR(int index) throws ConditionThrowable + { + return accessError(); + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + return accessError(); + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + storeError(newValue); + } + + @Override + public char charAt(int index) throws ConditionThrowable + { + accessError(); + // Not reached. + return 0; + } + + @Override + public void setCharAt(int index, char c) throws ConditionThrowable + { + storeError(LispCharacter.getInstance(c)); + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + if (capacity == 0 && start == 0 && end == 0) + return this; + return accessError(); + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + storeError(obj); + } + + @Override + public void fill(char c) throws ConditionThrowable + { + storeError(LispCharacter.getInstance(c)); + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + return accessError(); + } + + public LispObject accessError() throws ConditionThrowable + { + return error(new TypeError("Attempt to access an array of element type NIL.")); + } + + private void storeError(LispObject obj) throws ConditionThrowable + { + error(new TypeError(String.valueOf(obj) + " is not of type NIL.")); + } + + @Override + public String toString() + { + return unreadableString("NIL-VECTOR"); + } + + @Override + public int sxhash() + { + return 0; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + accessError(); + // Not reached. + return null; + } + + @Override + public AbstractVector adjustArray(int size, AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + accessError(); + // Not reached. + return null; + } +} Added: branches/save-image/src/org/armedbear/lisp/Operator.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Operator.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,70 @@ +/* + * Operator.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Operator.java 11478 2008-12-25 11:46:10Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class Operator extends LispObject +{ + protected LispObject lambdaName; + + private LispObject lambdaList; + + public final LispObject getLambdaName() + { + return lambdaName; + } + + public final void setLambdaName(LispObject obj) + { + lambdaName = obj; + } + + public final LispObject getLambdaList() + { + return lambdaList; + } + + public final void setLambdaList(LispObject obj) + { + lambdaList = obj; + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject result = NIL; + result = result.push(new Cons("lambda-name", lambdaName)); + result = result.push(new Cons("lambda-list", lambdaList)); + return result.nreverse(); + } +} Added: branches/save-image/src/org/armedbear/lisp/Package.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Package.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,867 @@ +/* + * Package.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Package.java 11492 2008-12-27 19:35:53Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.ArrayList; +import java.util.HashMap; +import java.util.Iterator; +import java.util.List; + +public final class Package extends LispObject +{ + private String name; + private SimpleString lispName; + + private LispObject propertyList; + + private final SymbolHashTable internalSymbols = new SymbolHashTable(16); + private final SymbolHashTable externalSymbols = new SymbolHashTable(16); + + private HashMap shadowingSymbols; + private ArrayList nicknames; + private LispObject useList = null; + private ArrayList usedByList = null; + + // Anonymous package. + public Package() + { + } + + public Package(String name) + { + this.name = name; + lispName = new SimpleString(name); + } + + public Package(String name, int size) + { + this.name = name; + lispName = new SimpleString(name); + } + + @Override + public LispObject typeOf() + { + return Symbol.PACKAGE; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.PACKAGE; + } + + @Override + public LispObject getDescription() + { + if (name != null) { + FastStringBuffer sb = new FastStringBuffer("The "); + sb.append(name); + sb.append(" package"); + return new SimpleString(sb); + } + return new SimpleString("PACKAGE"); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.PACKAGE) + return T; + if (type == BuiltInClass.PACKAGE) + return T; + return super.typep(type); + } + + public final String getName() + { + return name; + } + + public final LispObject NAME() + { + return lispName != null ? lispName : NIL; + } + + @Override + public final LispObject getPropertyList() + { + if (propertyList == null) + propertyList = NIL; + return propertyList; + } + + @Override + public final void setPropertyList(LispObject obj) + { + if (obj == null) + throw new NullPointerException(); + propertyList = obj; + } + + public final List getNicknames() + { + return nicknames; + } + + public final synchronized boolean delete() throws ConditionThrowable + { + if (name != null) { + Packages.deletePackage(this); + List internals = internalSymbols.getSymbols(); + for (int i = internals.size(); i-- > 0;) { + Symbol symbol = (Symbol) internals.get(i); + if (symbol.getPackage() == this) + symbol.setPackage(NIL); + internalSymbols.remove(symbol); + } + List externals = externalSymbols.getSymbols(); + for (int i = externals.size(); i-- > 0;) { + Symbol symbol = (Symbol) externals.get(i); + if (symbol.getPackage() == this) + symbol.setPackage(NIL); + externalSymbols.remove(symbol); + } + name = null; + lispName = null; + nicknames = null; + return true; + } + return false; + } + + public final synchronized void rename(String newName, LispObject newNicks) + throws ConditionThrowable + { + ArrayList arrayList = null; + while (newNicks != NIL) { + if (arrayList == null) + arrayList = new ArrayList(); + arrayList.add(javaString(newNicks.car())); + newNicks = newNicks.cdr(); + } + // Remove old name and nicknames from Packages map. + Packages.deletePackage(this); + // Now change the names... + name = newName; + lispName = new SimpleString(newName); + nicknames = arrayList; + // And add the package back. + Packages.addPackage(this); + } + + public synchronized Symbol findInternalSymbol(SimpleString name) + { + return internalSymbols.get(name); + } + + public synchronized Symbol findExternalSymbol(SimpleString name) + { + return externalSymbols.get(name); + } + + public synchronized Symbol findExternalSymbol(SimpleString name, int hash) + { + return externalSymbols.get(name, hash); + } + + // Returns null if symbol is not accessible in this package. + public synchronized Symbol findAccessibleSymbol(String name) + throws ConditionThrowable + { + return findAccessibleSymbol(new SimpleString(name)); + } + + // Returns null if symbol is not accessible in this package. + public synchronized Symbol findAccessibleSymbol(SimpleString name) + throws ConditionThrowable + { + // Look in external and internal symbols of this package. + Symbol symbol = externalSymbols.get(name); + if (symbol != null) + return symbol; + symbol = internalSymbols.get(name); + if (symbol != null) + return symbol; + // Look in external symbols of used packages. + if (useList instanceof Cons) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + symbol = pkg.findExternalSymbol(name); + if (symbol != null) + return symbol; + usedPackages = usedPackages.cdr(); + } + } + // Not found. + return null; + } + + public synchronized LispObject findSymbol(String name) + throws ConditionThrowable + { + final SimpleString s = new SimpleString(name); + final LispThread thread = LispThread.currentThread(); + // Look in external and internal symbols of this package. + Symbol symbol = externalSymbols.get(s); + if (symbol != null) + return thread.setValues(symbol, Keyword.EXTERNAL); + symbol = internalSymbols.get(s); + if (symbol != null) + return thread.setValues(symbol, Keyword.INTERNAL); + // Look in external symbols of used packages. + if (useList instanceof Cons) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + symbol = pkg.findExternalSymbol(s); + if (symbol != null) + return thread.setValues(symbol, Keyword.INHERITED); + usedPackages = usedPackages.cdr(); + } + } + // Not found. + return thread.setValues(NIL, NIL); + } + + // Helper function to add NIL to PACKAGE_CL. + public synchronized void addSymbol(Symbol symbol) + { + Debug.assertTrue(symbol.getPackage() == this); + Debug.assertTrue(symbol.getName().equals("NIL")); + try { + externalSymbols.put(symbol.name, symbol); + } + catch (Throwable t) { + Debug.trace(t); // FIXME + } + } + + private synchronized Symbol addSymbol(SimpleString name, int hash) + { + Symbol symbol = new Symbol(name, hash, this); + try { + if (this == PACKAGE_KEYWORD) { + symbol.initializeConstant(symbol); + externalSymbols.put(name, symbol); + } else + internalSymbols.put(name, symbol); + } + catch (Throwable t) { + Debug.trace(t); // FIXME + } + return symbol; + } + + public synchronized Symbol addInternalSymbol(String symbolName) + { + final Symbol symbol = new Symbol(symbolName, this); + internalSymbols.put(symbol); + return symbol; + } + + public synchronized Symbol addExternalSymbol(String symbolName) + { + final Symbol symbol = new Symbol(symbolName, this); + externalSymbols.put(symbol); + return symbol; + } + + public synchronized Symbol intern(String symbolName) + { + return intern(new SimpleString(symbolName)); + } + + public synchronized Symbol intern(SimpleString symbolName) + { + final int hash = symbolName.sxhash(); + // Look in external and internal symbols of this package. + Symbol symbol = externalSymbols.get(symbolName, hash); + if (symbol != null) + return symbol; + symbol = internalSymbols.get(symbolName, hash); + if (symbol != null) + return symbol; + // Look in external symbols of used packages. + if (useList instanceof Cons) { + try { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + symbol = pkg.findExternalSymbol(symbolName, hash); + if (symbol != null) + return symbol; + usedPackages = usedPackages.cdr(); + } + } + catch (Throwable t) { + Debug.trace(t); + } + } + // Not found. + return addSymbol(symbolName, hash); + } + + public synchronized Symbol intern(final SimpleString s, + final LispThread thread) + { + final int hash = s.sxhash(); + // Look in external and internal symbols of this package. + Symbol symbol = externalSymbols.get(s, hash); + if (symbol != null) + return (Symbol) thread.setValues(symbol, Keyword.EXTERNAL); + symbol = internalSymbols.get(s, hash); + if (symbol != null) + return (Symbol) thread.setValues(symbol, Keyword.INTERNAL); + // Look in external symbols of used packages. + if (useList instanceof Cons) { + try { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + symbol = pkg.findExternalSymbol(s, hash); + if (symbol != null) + return (Symbol) thread.setValues(symbol, Keyword.INHERITED); + usedPackages = usedPackages.cdr(); + } + } + catch (Throwable t) { + Debug.trace(t); + } + } + // Not found. + return (Symbol) thread.setValues(addSymbol(s, hash), NIL); + } + + public synchronized Symbol internAndExport(String symbolName) + throws ConditionThrowable + { + final SimpleString s = new SimpleString(symbolName); + final int hash = s.sxhash(); + // Look in external and internal symbols of this package. + Symbol symbol = externalSymbols.get(s, hash); + if (symbol != null) + return symbol; + symbol = internalSymbols.get(s, hash); + if (symbol != null) { + export(symbol); + return symbol; + } + if (useList instanceof Cons) { + // Look in external symbols of used packages. + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + symbol = pkg.findExternalSymbol(s, hash); + if (symbol != null) { + export(symbol); + return symbol; + } + usedPackages = usedPackages.cdr(); + } + } + // Not found. + symbol = new Symbol(s, hash, this); + if (this == PACKAGE_KEYWORD) + symbol.initializeConstant(symbol); + externalSymbols.put(s, symbol); + return symbol; + } + + public synchronized LispObject unintern(final Symbol symbol) + throws ConditionThrowable + { + final String symbolName = symbol.getName(); + final boolean shadow; + if (shadowingSymbols != null && shadowingSymbols.get(symbolName) == symbol) + shadow = true; + else + shadow = false; + if (shadow) { + // Check for conflicts that might be exposed in used package list + // if we remove the shadowing symbol. + Symbol sym = null; + if (useList instanceof Cons) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + Symbol s = pkg.findExternalSymbol(symbol.name); + if (s != null) { + if (sym == null) + sym = s; + else if (sym != s) { + FastStringBuffer sb = + new FastStringBuffer("Uninterning the symbol "); + sb.append(symbol.getQualifiedName()); + sb.append(" causes a name conflict between "); + sb.append(sym.getQualifiedName()); + sb.append(" and "); + sb.append(s.getQualifiedName()); + return error(new PackageError(sb.toString())); + } + } + usedPackages = usedPackages.cdr(); + } + } + } + // Reaching here, it's OK to remove the symbol. + if (internalSymbols.get(symbol.name) == symbol) + internalSymbols.remove(symbol.name); + else if (externalSymbols.get(symbol.name) == symbol) + externalSymbols.remove(symbol.name); + else + // Not found. + return NIL; + if (shadow) { + Debug.assertTrue(shadowingSymbols != null); + shadowingSymbols.remove(symbolName); + } + if (symbol.getPackage() == this) + symbol.setPackage(NIL); + return T; + } + + public synchronized void importSymbol(Symbol symbol) throws ConditionThrowable + { + if (symbol.getPackage() == this) + return; // Nothing to do. + Symbol sym = findAccessibleSymbol(symbol.name); + if (sym != null && sym != symbol) { + FastStringBuffer sb = new FastStringBuffer("The symbol "); + sb.append(sym.getQualifiedName()); + sb.append(" is already accessible in package "); + sb.append(name); + sb.append('.'); + error(new PackageError(sb.toString())); + } + internalSymbols.put(symbol.name, symbol); + if (symbol.getPackage() == NIL) + symbol.setPackage(this); + } + + public synchronized void export(final Symbol symbol) throws ConditionThrowable + { + final String symbolName = symbol.getName(); + boolean added = false; + if (symbol.getPackage() != this) { + Symbol sym = findAccessibleSymbol(symbol.name); + if (sym != symbol) { + FastStringBuffer sb = new FastStringBuffer("The symbol "); + sb.append(symbol.getQualifiedName()); + sb.append(" is not accessible in package "); + sb.append(name); + sb.append('.'); + error(new PackageError(sb.toString())); + return; + } + internalSymbols.put(symbol.name, symbol); + added = true; + } + if (added || internalSymbols.get(symbol.name) == symbol) { + if (usedByList != null) { + for (Iterator it = usedByList.iterator(); it.hasNext();) { + Package pkg = (Package) it.next(); + Symbol sym = pkg.findAccessibleSymbol(symbol.name); + if (sym != null && sym != symbol) { + if (pkg.shadowingSymbols != null && + pkg.shadowingSymbols.get(symbolName) == sym) { + // OK. + } else { + FastStringBuffer sb = new FastStringBuffer("The symbol "); + sb.append(sym.getQualifiedName()); + sb.append(" is already accessible in package "); + sb.append(pkg.getName()); + sb.append('.'); + error(new PackageError(sb.toString())); + return; + } + } + } + } + // No conflicts. + internalSymbols.remove(symbol.name); + externalSymbols.put(symbol.name, symbol); + return; + } + if (externalSymbols.get(symbol.name) == symbol) + // Symbol is already exported; there's nothing to do. + return; + FastStringBuffer sb = new FastStringBuffer("The symbol "); + sb.append(symbol.getQualifiedName()); + sb.append(" is not accessible in package "); + sb.append(name); + sb.append('.'); + error(new PackageError(sb.toString())); + } + + public synchronized void unexport(final Symbol symbol) + throws ConditionThrowable + { + if (symbol.getPackage() == this) { + if (externalSymbols.get(symbol.name) == symbol) { + externalSymbols.remove(symbol.name); + internalSymbols.put(symbol.name, symbol); + } + } else { + // Signal an error if symbol is not accessible. + if (useList instanceof Cons) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + if (pkg.findExternalSymbol(symbol.name) == symbol) + return; // OK. + usedPackages = usedPackages.cdr(); + } + } + FastStringBuffer sb = new FastStringBuffer("The symbol "); + sb.append(symbol.getQualifiedName()); + sb.append(" is not accessible in package "); + sb.append(name); + error(new PackageError(sb.toString())); + } + } + + public synchronized void shadow(final String symbolName) + throws ConditionThrowable + { + if (shadowingSymbols == null) + shadowingSymbols = new HashMap(); + final SimpleString s = new SimpleString(symbolName); + Symbol symbol = externalSymbols.get(s); + if (symbol != null) { + shadowingSymbols.put(symbolName, symbol); + return; + } + symbol = internalSymbols.get(s); + if (symbol != null) { + shadowingSymbols.put(symbolName, symbol); + return; + } + if (shadowingSymbols.get(symbolName) != null) + return; + symbol = new Symbol(s, this); + internalSymbols.put(s, symbol); + shadowingSymbols.put(symbolName, symbol); + } + + public synchronized void shadowingImport(Symbol symbol) throws ConditionThrowable + { + LispObject where = NIL; + final String symbolName = symbol.getName(); + Symbol sym = externalSymbols.get(symbol.name); + if (sym != null) { + where = Keyword.EXTERNAL; + } else { + sym = internalSymbols.get(symbol.name); + if (sym != null) { + where = Keyword.INTERNAL; + } else { + // Look in external symbols of used packages. + if (useList instanceof Cons) { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + sym = pkg.findExternalSymbol(symbol.name); + if (sym != null) { + where = Keyword.INHERITED; + break; + } + usedPackages = usedPackages.cdr(); + } + } + } + } + if (sym != null) { + if (where == Keyword.INTERNAL || where == Keyword.EXTERNAL) { + if (sym != symbol) { + if (shadowingSymbols != null) + shadowingSymbols.remove(symbolName); + unintern(sym); + } + } + } + internalSymbols.put(symbol.name, symbol); + if (shadowingSymbols == null) + shadowingSymbols = new HashMap(); + Debug.assertTrue(shadowingSymbols.get(symbolName) == null); + shadowingSymbols.put(symbolName, symbol); + } + + // "USE-PACKAGE causes PACKAGE to inherit all the external symbols of + // PACKAGES-TO-USE. The inherited symbols become accessible as internal + // symbols of PACKAGE." + public void usePackage(Package pkg) throws ConditionThrowable + { + if (useList == null) + useList = NIL; + if (!memq(pkg, useList)) { + // "USE-PACKAGE checks for name conflicts between the newly + // imported symbols and those already accessible in package." + List symbols = pkg.getExternalSymbols(); + for (int i = symbols.size(); i-- > 0;) { + Symbol symbol = (Symbol) symbols.get(i); + Symbol existing = findAccessibleSymbol(symbol.name); + if (existing != null && existing != symbol) { + if (shadowingSymbols == null || + shadowingSymbols.get(symbol.getName()) == null) + { + error(new PackageError("A symbol named " + symbol.getName() + + " is already accessible in package " + + name + ".")); + return; + } + } + } + useList = useList.push(pkg); + // Add this package to the used-by list of pkg. + if (pkg.usedByList != null) + Debug.assertTrue(!pkg.usedByList.contains(this)); + if (pkg.usedByList == null) + pkg.usedByList = new ArrayList(); + pkg.usedByList.add(this); + } + } + + public void unusePackage(Package pkg) throws ConditionThrowable + { + if (useList instanceof Cons) { + if (memq(pkg, useList)) { + // FIXME Modify the original list instead of copying it! + LispObject newList = NIL; + while (useList != NIL) { + if (useList.car() != pkg) + newList = newList.push(useList.car()); + useList = useList.cdr(); + } + useList = newList.nreverse(); + Debug.assertTrue(!memq(pkg, useList)); + Debug.assertTrue(pkg.usedByList != null); + Debug.assertTrue(pkg.usedByList.contains(this)); + pkg.usedByList.remove(this); + } + } + } + + public final void addNickname(String s) throws ConditionThrowable + { + // This call will signal an error if there's a naming conflict. + Packages.addNickname(this, s); + + if (nicknames != null) { + if (nicknames.contains(s)) + return; // Nothing to do. + } else + nicknames = new ArrayList(); + + nicknames.add(s); + } + + public String getNickname() + { + if (nicknames != null && nicknames.size() > 0) + return (String) nicknames.get(0); + return null; + } + + public LispObject packageNicknames() + { + LispObject list = NIL; + if (nicknames != null) { + for (int i = nicknames.size(); i-- > 0;) { + String nickname = (String) nicknames.get(i); + list = new Cons(new SimpleString(nickname), list); + } + } + return list; + } + + public LispObject getUseList() + { + if (useList == null) + useList = NIL; + return useList; + } + + public boolean uses(LispObject pkg) throws ConditionThrowable + { + return (useList instanceof Cons) && memq(pkg, useList); + } + + public LispObject getUsedByList() + { + LispObject list = NIL; + if (usedByList != null) { + for (Iterator it = usedByList.iterator(); it.hasNext();) { + Package pkg = (Package) it.next(); + list = new Cons(pkg, list); + } + } + return list; + } + + public LispObject getShadowingSymbols() + { + LispObject list = NIL; + if (shadowingSymbols != null) { + for (Iterator it = shadowingSymbols.values().iterator(); it.hasNext();) { + Symbol symbol = (Symbol) it.next(); + list = new Cons(symbol, list); + } + } + return list; + } + + public synchronized List getExternalSymbols() + { + return externalSymbols.getSymbols(); + } + + public synchronized List getAccessibleSymbols() + { + ArrayList list = new ArrayList(); + list.addAll(internalSymbols.getSymbols()); + list.addAll(externalSymbols.getSymbols()); + if (useList instanceof Cons) { + try { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + List symbols = pkg.externalSymbols.getSymbols(); + for (int i = 0; i < symbols.size(); i++) { + Symbol symbol = (Symbol) symbols.get(i); + if (shadowingSymbols == null || shadowingSymbols.get(symbol.getName()) == null) + list.add(symbol); + } + usedPackages = usedPackages.cdr(); + } + } + catch (Throwable t) { + Debug.trace(t); + } + } + return list; + } + + public synchronized LispObject PACKAGE_INTERNAL_SYMBOLS() + { + LispObject list = NIL; + List symbols = internalSymbols.getSymbols(); + for (int i = symbols.size(); i-- > 0;) + list = new Cons((Symbol)symbols.get(i), list); + return list; + } + + public synchronized LispObject PACKAGE_EXTERNAL_SYMBOLS() + { + LispObject list = NIL; + List symbols = externalSymbols.getSymbols(); + for (int i = symbols.size(); i-- > 0;) + list = new Cons((Symbol)symbols.get(i), list); + return list; + } + + public synchronized LispObject PACKAGE_INHERITED_SYMBOLS() + { + LispObject list = NIL; + if (useList instanceof Cons) { + try { + LispObject usedPackages = useList; + while (usedPackages != NIL) { + Package pkg = (Package) usedPackages.car(); + List externals = pkg.getExternalSymbols(); + for (int i = externals.size(); i-- > 0;) { + Symbol symbol = (Symbol) externals.get(i); + if (shadowingSymbols != null && shadowingSymbols.get(symbol.getName()) != null) + continue; + if (externalSymbols.get(symbol.name) == symbol) + continue; + list = new Cons(symbol, list); + } + usedPackages = usedPackages.cdr(); + } + } + catch (Throwable t) { + Debug.trace(t); + } + } + return list; + } + + public synchronized LispObject getSymbols() + { + LispObject list = NIL; + List internals = internalSymbols.getSymbols(); + for (int i = internals.size(); i-- > 0;) + list = new Cons((Symbol)internals.get(i), list); + List externals = externalSymbols.getSymbols(); + for (int i = externals.size(); i-- > 0;) + list = new Cons((Symbol)externals.get(i), list); + return list; + } + + public synchronized Symbol[] symbols() + { + List internals = internalSymbols.getSymbols(); + List externals = externalSymbols.getSymbols(); + Symbol[] array = new Symbol[internals.size() + externals.size()]; + int i = 0; + for (Iterator it = internals.iterator(); it.hasNext();) { + Symbol symbol = (Symbol) it.next(); + array[i++] = symbol; + } + for (Iterator it = externals.iterator(); it.hasNext();) { + Symbol symbol = (Symbol) it.next(); + array[i++] = symbol; + } + return array; + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (_PRINT_FASL_.symbolValue() != NIL && name != null) { + FastStringBuffer sb = new FastStringBuffer("#.(FIND-PACKAGE \""); + sb.append(name); + sb.append("\")"); + return sb.toString(); + } else if (name != null) { + FastStringBuffer sb = new FastStringBuffer("#"); + return sb.toString(); + } else + return unreadableString("PACKAGE"); + } +} Added: branches/save-image/src/org/armedbear/lisp/PackageError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/PackageError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,122 @@ +/* + * PackageError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: PackageError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class PackageError extends LispError +{ + public PackageError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.PACKAGE_ERROR); + initialize(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + + if (initArgs.listp() && initArgs.car().stringp()) { + setFormatControl(initArgs.car().getStringValue()); + // When printing an error string, presumably, if the string contains + // a symbol, we'll want to complain about its full name, not the accessible + // name, because it may omit an (important) package name part. + // Two problems: (1) symbols can be contained in sublists + // (2) symbols may not be printed, but used otherwise. + for (LispObject arg = initArgs.cdr(); arg != NIL; arg = arg.cdr()) { + if (arg.car() instanceof Symbol) + arg.setCar(new SimpleString(((Symbol)arg.car()).getQualifiedName())); + } + setFormatArguments(initArgs.cdr()); + setPackage(NIL); + + return; + } + + LispObject pkg = NIL; + LispObject first, second; + while (initArgs != NIL) { + first = initArgs.car(); + initArgs = initArgs.cdr(); + second = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.PACKAGE) + pkg = second; + } + setPackage(pkg); + } + + public PackageError(String message) throws ConditionThrowable + { + super(StandardClass.PACKAGE_ERROR); + setFormatControl(message); + } + + @Override + public LispObject typeOf() + { + return Symbol.PACKAGE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.PACKAGE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.PACKAGE_ERROR) + return T; + if (type == StandardClass.PACKAGE_ERROR) + return T; + return super.typep(type); + } + + public LispObject getPackage() + { + Debug.assertTrue(layout != null); + int index = layout.getSlotIndex(Symbol.PACKAGE); + Debug.assertTrue(index >= 0); + return slots[index]; + } + + public void setPackage(LispObject pkg) + { + Debug.assertTrue(layout != null); + int index = layout.getSlotIndex(Symbol.PACKAGE); + Debug.assertTrue(index >= 0); + slots[index] = pkg; + } +} Added: branches/save-image/src/org/armedbear/lisp/PackageFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/PackageFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,379 @@ +/* + * PackageFunctions.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: PackageFunctions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class PackageFunctions extends Lisp +{ + // ### packagep + // packagep object => generalized-boolean + private static final Primitive PACKAGEP = new Primitive("packagep", "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof Package ? T : NIL; + } + }; + + // ### package-name + // package-name package => nicknames + private static final Primitive PACKAGE_NAME = + new Primitive("package-name", "package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).NAME(); + } + }; + + // ### package-nicknames + // package-nicknames package => nicknames + private static final Primitive PACKAGE_NICKNAMES = + new Primitive("package-nicknames", "package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).packageNicknames(); + } + }; + + // ### package-use-list + // package-use-list package => use-list + private static final Primitive PACKAGE_USE_LIST = + new Primitive("package-use-list", "package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).getUseList(); + } + }; + + // ### package-used-by-list + // package-used-by-list package => used-by-list + private static final Primitive PACKAGE_USED_BY_LIST = + new Primitive("package-used-by-list", "package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).getUsedByList(); + } + }; + + // ### %import + // %import symbols &optional package => t + private static final Primitive _IMPORT = + new Primitive("%import", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length == 0 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject symbols = args[0]; + Package pkg = + args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); + if (symbols.listp()) { + while (symbols != NIL) { + pkg.importSymbol(checkSymbol(symbols.car())); + symbols = symbols.cdr(); + } + } else + pkg.importSymbol(checkSymbol(symbols)); + return T; + } + }; + + // ### unexport + // unexport symbols &optional package => t + private static final Primitive UNEXPORT = + new Primitive("unexport", "symbols &optional package") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length == 0 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject symbols = args[0]; + Package pkg = + args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); + if (symbols.listp()) { + while (symbols != NIL) { + pkg.unexport(checkSymbol(symbols.car())); + symbols = symbols.cdr(); + } + } else + pkg.unexport(checkSymbol(symbols)); + return T; + } + }; + + // ### shadow + // shadow symbol-names &optional package => t + private static final Primitive SHADOW = + new Primitive("shadow", "symbol-names &optional package") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length == 0 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject symbols = args[0]; + Package pkg = + args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); + if (symbols.listp()) { + while (symbols != NIL) { + pkg.shadow(javaString(symbols.car())); + symbols = symbols.cdr(); + } + } else + pkg.shadow(javaString(symbols)); + return T; + } + }; + + // ### shadowing-import + // shadowing-import symbols &optional package => t + private static final Primitive SHADOWING_IMPORT = + new Primitive("shadowing-import", "symbols &optional package") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length == 0 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject symbols = args[0]; + Package pkg = + args.length == 2 ? coerceToPackage(args[1]) : getCurrentPackage(); + if (symbols.listp()) { + while (symbols != NIL) { + pkg.shadowingImport(checkSymbol(symbols.car())); + symbols = symbols.cdr(); + } + } else + pkg.shadowingImport(checkSymbol(symbols)); + return T; + } + }; + + // ### package-shadowing-symbols + // package-shadowing-symbols package => used-by-list + private static final Primitive PACKAGE_SHADOWING_SYMBOLS = + new Primitive("package-shadowing-symbols", "package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).getShadowingSymbols(); + } + }; + + // ### delete-package + private static final Primitive DELETE_PACKAGE = + new Primitive("delete-package", "package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).delete() ? T : NIL; + } + }; + + // ### unuse-package + // unuse-package packages-to-unuse &optional package => t + private static final Primitive USE_PACKAGE = + new Primitive("unuse-package", "packages-to-unuse &optional package") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + Package pkg; + if (args.length == 2) + pkg = coerceToPackage(args[1]); + else + pkg = getCurrentPackage(); + if (args[0] instanceof Cons) { + LispObject list = args[0]; + while (list != NIL) { + pkg.unusePackage(coerceToPackage(list.car())); + list = list.cdr(); + } + } else + pkg.unusePackage(coerceToPackage(args[0])); + return T; + } + }; + + // ### rename-package + // rename-package package new-name &optional new-nicknames => package-object + private static final Primitive RENAME_PACKAGE = + new Primitive("rename-package", "package new-name &optional new-nicknames") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2 || args.length > 3) + return error(new WrongNumberOfArgumentsException(this)); + Package pkg = coerceToPackage(args[0]); + String newName = javaString(args[1]); + LispObject nicknames = args.length == 3 ? checkList(args[2]) : NIL; + pkg.rename(newName, nicknames); + return pkg; + } + }; + + private static final Primitive LIST_ALL_PACKAGES = + new Primitive("list-all-packages", "") + { + @Override + public LispObject execute() + { + return Packages.listAllPackages(); + } + }; + + // ### %defpackage name nicknames size shadows shadowing-imports use + // imports interns exports doc-string => package + private static final Primitive _DEFPACKAGE = + new Primitive("%defpackage", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 10) + return error(new WrongNumberOfArgumentsException(this)); + final String packageName = args[0].getStringValue(); + LispObject nicknames = checkList(args[1]); + // FIXME size is ignored + // LispObject size = args[2]; + LispObject shadows = checkList(args[3]); + LispObject shadowingImports = checkList(args[4]); + LispObject use = checkList(args[5]); + LispObject imports = checkList(args[6]); + LispObject interns = checkList(args[7]); + LispObject exports = checkList(args[8]); + // FIXME docString is ignored + // LispObject docString = args[9]; + Package pkg = Packages.findPackage(packageName); + if (pkg != null) + return pkg; + if (nicknames != NIL) { + LispObject list = nicknames; + while (list != NIL) { + String nick = javaString(list.car()); + if (Packages.findPackage(nick) != null) { + return error(new PackageError("A package named " + nick + + " already exists.")); + } + list = list.cdr(); + } + } + pkg = Packages.createPackage(packageName); + while (nicknames != NIL) { + LispObject string = nicknames.car().STRING(); + pkg.addNickname(string.getStringValue()); + nicknames = nicknames.cdr(); + } + while (shadows != NIL) { + String symbolName = shadows.car().getStringValue(); + pkg.shadow(symbolName); + shadows = shadows.cdr(); + } + while (shadowingImports != NIL) { + LispObject si = shadowingImports.car(); + Package otherPkg = coerceToPackage(si.car()); + LispObject symbolNames = si.cdr(); + while (symbolNames != NIL) { + String symbolName = symbolNames.car().getStringValue(); + Symbol sym = otherPkg.findAccessibleSymbol(symbolName); + if (sym != null) + pkg.shadowingImport(sym); + else + return error(new LispError(symbolName + + " not found in package " + + otherPkg.getName() + ".")); + symbolNames = symbolNames.cdr(); + } + shadowingImports = shadowingImports.cdr(); + } + while (use != NIL) { + LispObject obj = use.car(); + if (obj instanceof Package) + pkg.usePackage((Package)obj); + else { + LispObject string = obj.STRING(); + Package p = Packages.findPackage(string.getStringValue()); + if (p == null) + return error(new LispError(obj.writeToString() + + " is not the name of a package.")); + pkg.usePackage(p); + } + use = use.cdr(); + } + while (imports != NIL) { + LispObject si = imports.car(); + Package otherPkg = coerceToPackage(si.car()); + LispObject symbolNames = si.cdr(); + while (symbolNames != NIL) { + String symbolName = symbolNames.car().getStringValue(); + Symbol sym = otherPkg.findAccessibleSymbol(symbolName); + if (sym != null) + pkg.importSymbol(sym); + else + return error(new LispError(symbolName + + " not found in package " + + otherPkg.getName() + ".")); + symbolNames = symbolNames.cdr(); + } + imports = imports.cdr(); + } + while (interns != NIL) { + String symbolName = interns.car().getStringValue(); + pkg.intern(symbolName); + interns = interns.cdr(); + } + while (exports != NIL) { + String symbolName = exports.car().getStringValue(); + pkg.export(pkg.intern(symbolName)); + exports = exports.cdr(); + } + return pkg; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Packages.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Packages.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,159 @@ +/* + * Packages.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Packages.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.ArrayList; +import java.util.HashMap; +import java.util.Iterator; +import java.util.List; + +public final class Packages extends Lisp +{ + private static final ArrayList packages = new ArrayList(); + private static final HashMap map = new HashMap(); + + public static final synchronized Package createPackage(String name) + { + return createPackage(name, 0); + } + + public static final synchronized Package createPackage(String name, int size) + { + Package pkg = (Package) map.get(name); + if (pkg == null) + { + pkg = size != 0 ? new Package(name, size) : new Package(name); + packages.add(pkg); + map.put(name, pkg); + } + else + Debug.trace("package " + name + " already exists"); + return pkg; + } + + public static final synchronized void addPackage(Package pkg) + throws ConditionThrowable + { + final String name = pkg.getName(); + if (map.get(name) != null) + { + error(new LispError("A package named " + name + " already exists.")); + return; + } + packages.add(pkg); + map.put(name, pkg); + List nicknames = pkg.getNicknames(); + if (nicknames != null) + { + for (Iterator it = nicknames.iterator(); it.hasNext();) + { + String nickname = (String) it.next(); + addNickname(pkg, nickname); + } + } + } + + // Returns null if package doesn't exist. + public static final synchronized Package findPackage(String name) + { + return (Package) map.get(name); + } + + public static final synchronized Package makePackage(String name) + throws ConditionThrowable + { + if (map.get(name) != null) + { + error(new LispError("A package named " + name + " already exists.")); + // Not reached. + return null; + } + Package pkg = new Package(name); + packages.add(pkg); + map.put(name, pkg); + return pkg; + } + + public static final synchronized void addNickname(Package pkg, String nickname) + throws ConditionThrowable + { + Object obj = map.get(nickname); + if (obj != null && obj != pkg) + { + error(new PackageError("A package named " + nickname + " already exists.")); + return; + } + map.put(nickname, pkg); + } + + // Removes name and nicknames from map, removes pkg from packages. + public static final synchronized boolean deletePackage(Package pkg) + { + String name = pkg.getName(); + if (name != null) + { + map.remove(name); + List nicknames = pkg.getNicknames(); + if (nicknames != null) + { + for (Iterator it = nicknames.iterator(); it.hasNext();) + { + String nickname = (String) it.next(); + map.remove(nickname); + } + } + packages.remove(pkg); + return true; + } + return false; + } + + public static final synchronized LispObject listAllPackages() + { + LispObject result = NIL; + for (Iterator it = packages.iterator(); it.hasNext();) + { + Package pkg = (Package) it.next(); + result = new Cons(pkg, result); + } + return result; + } + + public static final synchronized Package[] getAllPackages() + { + Package[] array = new Package[packages.size()]; + packages.toArray(array); + return array; + } +} Added: branches/save-image/src/org/armedbear/lisp/ParseError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ParseError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,72 @@ +/* + * ParseError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ParseError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ParseError extends LispError +{ + public ParseError(String message) throws ConditionThrowable + { + super(StandardClass.PARSE_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + } + + public ParseError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.PARSE_ERROR); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.PARSE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.PARSE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.PARSE_ERROR) + return T; + if (type == StandardClass.PARSE_ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Pathname.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Pathname.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1393 @@ +/* + * Pathname.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Pathname.java 11581 2009-01-24 13:26:18Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.IOException; +import java.net.URL; +import java.util.StringTokenizer; + +public class Pathname extends LispObject +{ + protected LispObject host = NIL; + protected LispObject device = NIL; + protected LispObject directory = NIL; + protected LispObject name = NIL; + + // A string, NIL, :WILD or :UNSPECIFIC. + protected LispObject type = NIL; + + // A positive integer, or NIL, :WILD, :UNSPECIFIC, or :NEWEST. + protected LispObject version = NIL; + + private String namestring; + + protected Pathname() + { + } + + public Pathname(String s) throws ConditionThrowable + { + init(s); + } + + public Pathname(URL url) throws ConditionThrowable + { + String protocol = url.getProtocol(); + if ("jar".equals(protocol)) { + String s = url.getPath(); + if (s.startsWith("file:")) { + int index = s.indexOf("!/"); + String container = s.substring(5, index); + if (Utilities.isPlatformWindows) { + if (container.length() > 0 && container.charAt(0) == '/') + container = container.substring(1); + } + device = new Pathname(container); + s = s.substring(index + 1); + Pathname p = new Pathname(s); + directory = p.directory; + name = p.name; + type = p.type; + return; + } + } else if ("file".equals(protocol)) { + String s = url.getPath(); + if (s != null && s.startsWith("file:")) { + init(s.substring(5)); + return; + } + } + error(new LispError("Unsupported URL: \"" + url.toString() + '"')); + } + + private final void init(String s) throws ConditionThrowable + { + if (s == null) + return; + if (s.equals(".") || s.equals("./") || + (Utilities.isPlatformWindows && s.equals(".\\"))) { + directory = new Cons(Keyword.RELATIVE); + return; + } + if (s.equals("..") || s.equals("../")) { + directory = list2(Keyword.RELATIVE, Keyword.UP); + return; + } + if (Utilities.isPlatformWindows) { + if (s.startsWith("\\\\")) { + //UNC path support + // match \\\\[directories-and-files] + + int shareIndex = s.indexOf('\\', 2); + int dirIndex = s.indexOf('\\', shareIndex + 1); + + if (shareIndex == -1 || dirIndex == -1) + error(new LispError("Unsupported UNC path format: \"" + s + '"')); + + host = new SimpleString(s.substring(2, shareIndex)); + device = new SimpleString(s.substring(shareIndex + 1, dirIndex)); + + Pathname p = new Pathname(s.substring(dirIndex)); + directory = p.directory; + name = p.name; + type = p.type; + version = p.version; + return; + } + + s = s.replace('/', '\\'); + } + // Jar file support. + int bang = s.indexOf("!/"); + if (bang >= 0) { + Pathname container = new Pathname(s.substring(0, bang)); + LispObject containerType = container.type; + if (containerType instanceof AbstractString) { + if (containerType.getStringValue().equalsIgnoreCase("jar")) { + device = container; + s = s.substring(bang + 1); + Pathname p = new Pathname(s); + directory = p.directory; + name = p.name; + type = p.type; + return; + } + } + } + if (Utilities.isPlatformUnix) { + if (s.equals("~")) + s = System.getProperty("user.home").concat("/"); + else if (s.startsWith("~/")) + s = System.getProperty("user.home").concat(s.substring(1)); + } + namestring = s; + if (Utilities.isPlatformWindows) { + if (s.length() >= 2 && s.charAt(1) == ':') { + device = new SimpleString(s.charAt(0)); + s = s.substring(2); + } + } + String d = null; + // Find last file separator char. + if (Utilities.isPlatformWindows) { + for (int i = s.length(); i-- > 0;) { + char c = s.charAt(i); + if (c == '/' || c == '\\') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; + } + } + } else { + for (int i = s.length(); i-- > 0;) { + if (s.charAt(i) == '/') { + d = s.substring(0, i + 1); + s = s.substring(i + 1); + break; + } + } + } + if (d != null) { + if (s.equals("..")) { + d = d.concat(s); + s = ""; + } + directory = parseDirectory(d); + } + if (s.startsWith(".")) { + name = new SimpleString(s); + return; + } + int index = s.lastIndexOf('.'); + String n = null; + String t = null; + if (index > 0) { + n = s.substring(0, index); + t = s.substring(index + 1); + } else if (s.length() > 0) + n = s; + if (n != null) { + if (n.equals("*")) + name = Keyword.WILD; + else + name = new SimpleString(n); + } + if (t != null) { + if (t.equals("*")) + type = Keyword.WILD; + else + type = new SimpleString(t); + } + } + + private static final LispObject parseDirectory(String d) + throws ConditionThrowable + { + if (d.equals("/") || (Utilities.isPlatformWindows && d.equals("\\"))) + return new Cons(Keyword.ABSOLUTE); + LispObject result; + if (d.startsWith("/") || (Utilities.isPlatformWindows && d.startsWith("\\"))) + result = new Cons(Keyword.ABSOLUTE); + else + result = new Cons(Keyword.RELATIVE); + StringTokenizer st = new StringTokenizer(d, "/\\"); + while (st.hasMoreTokens()) { + String token = st.nextToken(); + LispObject obj; + if (token.equals("*")) + obj = Keyword.WILD; + else if (token.equals("**")) + obj = Keyword.WILD_INFERIORS; + else if (token.equals("..")) { + if (result.car() instanceof AbstractString) { + result = result.cdr(); + continue; + } + obj= Keyword.UP; + } else + obj = new SimpleString(token); + result = new Cons(obj, result); + } + return result.nreverse(); + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject parts = NIL; + parts = parts.push(new Cons("HOST", host)); + parts = parts.push(new Cons("DEVICE", device)); + parts = parts.push(new Cons("DIRECTORY", directory)); + parts = parts.push(new Cons("NAME", name)); + parts = parts.push(new Cons("TYPE", type)); + parts = parts.push(new Cons("VERSION", version)); + return parts.nreverse(); + } + + @Override + public LispObject typeOf() + { + return Symbol.PATHNAME; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.PATHNAME; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.PATHNAME) + return T; + if (type == BuiltInClass.PATHNAME) + return T; + return super.typep(type); + } + + public final LispObject getDevice() + { + return device; + } + + public String getNamestring() throws ConditionThrowable + { + if (namestring != null) + return namestring; + if (name == NIL && type != NIL) { + Debug.assertTrue(namestring == null); + return null; + } + if (directory instanceof AbstractString) + Debug.assertTrue(false); + FastStringBuffer sb = new FastStringBuffer(); + // "If a pathname is converted to a namestring, the symbols NIL and + // :UNSPECIFIC cause the field to be treated as if it were empty. That + // is, both NIL and :UNSPECIFIC cause the component not to appear in + // the namestring." 19.2.2.2.3.1 + if (host != NIL) { + Debug.assertTrue(host instanceof AbstractString); + if (! (this instanceof LogicalPathname)) + sb.append("\\\\"); //UNC file support; if there's a host, it's a UNC path. + sb.append(host.getStringValue()); + if (this instanceof LogicalPathname) + sb.append(':'); + else + sb.append(File.separatorChar); + } + if (device == NIL) { + } else if (device == Keyword.UNSPECIFIC) { + } else if (device instanceof AbstractString) { + sb.append(device.getStringValue()); + if (this instanceof LogicalPathname + || host == NIL) + sb.append(':'); // non-UNC paths + } else if (device instanceof Pathname) { + sb.append(((Pathname)device).getNamestring()); + sb.append("!"); + } else + Debug.assertTrue(false); + sb.append(getDirectoryNamestring()); + if (name instanceof AbstractString) { + String n = name.getStringValue(); + if (n.indexOf(File.separatorChar) >= 0) { + Debug.assertTrue(namestring == null); + return null; + } + sb.append(n); + } else if (name == Keyword.WILD) + sb.append('*'); + if (type != NIL) { + sb.append('.'); + if (type instanceof AbstractString) { + String t = type.getStringValue(); + if (t.indexOf('.') >= 0) { + Debug.assertTrue(namestring == null); + return null; + } + sb.append(t); + } else if (type == Keyword.WILD) + sb.append('*'); + else + Debug.assertTrue(false); + } + if (this instanceof LogicalPathname) { + if (version.integerp()) { + sb.append('.'); + int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue()); + if (version instanceof Fixnum) + sb.append(Integer.toString(((Fixnum)version).value, base).toUpperCase()); + else if (version instanceof Bignum) + sb.append(((Bignum)version).value.toString(base).toUpperCase()); + } else if (version == Keyword.WILD) { + sb.append(".*"); + } else if (version == Keyword.NEWEST) { + sb.append(".NEWEST"); + } + } + return namestring = sb.toString(); + } + + protected String getDirectoryNamestring() throws ConditionThrowable + { + validateDirectory(true); + FastStringBuffer sb = new FastStringBuffer(); + // "If a pathname is converted to a namestring, the symbols NIL and + // :UNSPECIFIC cause the field to be treated as if it were empty. That + // is, both NIL and :UNSPECIFIC cause the component not to appear in + // the namestring." 19.2.2.2.3.1 + if (directory != NIL) { + final char separatorChar; + if (device instanceof Pathname) + separatorChar = '/'; // Jar file. + else + separatorChar = File.separatorChar; + LispObject temp = directory; + LispObject part = temp.car(); + temp = temp.cdr(); + if (part == Keyword.ABSOLUTE) { + sb.append(separatorChar); + } else if (part == Keyword.RELATIVE) { + if (temp == NIL) { + // #p"./" + sb.append('.'); + sb.append(separatorChar); + } + // else: Nothing to do. + } else { + error(new FileError("Unsupported directory component " + + part.writeToString() + ".", + this)); + } + while (temp != NIL) { + part = temp.car(); + if (part instanceof AbstractString) + sb.append(part.getStringValue()); + else if (part == Keyword.WILD) + sb.append('*'); + else if (part == Keyword.WILD_INFERIORS) + sb.append("**"); + else if (part == Keyword.UP) + sb.append(".."); + else + error(new FileError("Unsupported directory component " + part.writeToString() + ".", + this)); + sb.append(separatorChar); + temp = temp.cdr(); + } + } + return sb.toString(); + } + + @Override + public boolean equal(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof Pathname) { + Pathname p = (Pathname) obj; + if (Utilities.isPlatformWindows) { + if (!host.equalp(p.host)) + return false; + if (!device.equalp(p.device)) + return false; + if (!directory.equalp(p.directory)) + return false; + if (!name.equalp(p.name)) + return false; + if (!type.equalp(p.type)) + return false; + // Ignore version component. + //if (!version.equalp(p.version)) + // return false; + } else { + // Unix. + if (!host.equal(p.host)) + return false; + if (!device.equal(p.device)) + return false; + if (!directory.equal(p.directory)) + return false; + if (!name.equal(p.name)) + return false; + if (!type.equal(p.type)) + return false; + // Ignore version component. + //if (!version.equal(p.version)) + // return false; + } + return true; + } + return false; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + return equal(obj); + } + + @Override + public int sxhash() + { + return ((host.sxhash() ^ + device.sxhash() ^ + directory.sxhash() ^ + name.sxhash() ^ + type.sxhash()) & 0x7fffffff); + } + + @Override + public String writeToString() throws ConditionThrowable + { + try { + final LispThread thread = LispThread.currentThread(); + boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + boolean printEscape = (Symbol.PRINT_ESCAPE.symbolValue(thread) != NIL); + boolean useNamestring; + String s = null; + try { + s = getNamestring(); + } + catch (Throwable t) {} + if (s != null) { + useNamestring = true; + if (printReadably) { + // We have a namestring. Check for pathname components that + // can't be read from the namestring. + if (host != NIL || version != NIL) { + useNamestring = false; + } else if (name instanceof AbstractString) { + String n = name.getStringValue(); + if (n.equals(".") || n.equals("..")) + useNamestring = false; + else if (n.indexOf(File.separatorChar) >= 0) + useNamestring = false; + } + } + } else + useNamestring = false; + FastStringBuffer sb = new FastStringBuffer(); + if (useNamestring) { + if (printReadably || printEscape) + sb.append("#P\""); + final int limit = s.length(); + for (int i = 0; i < limit; i++) { + char c = s.charAt(i); + if (printReadably || printEscape) { + if (c == '\"' || c == '\\') + sb.append('\\'); + } + sb.append(c); + } + if (printReadably || printEscape) + sb.append('"'); + } else { + sb.append("#P("); + if (host != NIL) { + sb.append(":HOST "); + sb.append(host.writeToString()); + sb.append(' '); + } + if (device != NIL) { + sb.append(":DEVICE "); + sb.append(device.writeToString()); + sb.append(' '); + } + if (directory != NIL) { + sb.append(":DIRECTORY "); + sb.append(directory.writeToString()); + sb.append(" "); + } + if (name != NIL) { + sb.append(":NAME "); + sb.append(name.writeToString()); + sb.append(' '); + } + if (type != NIL) { + sb.append(":TYPE "); + sb.append(type.writeToString()); + sb.append(' '); + } + if (version != NIL) { + sb.append(":VERSION "); + sb.append(version.writeToString()); + sb.append(' '); + } + if (sb.charAt(sb.length() - 1) == ' ') + sb.setLength(sb.length() - 1); + sb.append(')'); + } + return sb.toString(); + } + catch (ConditionThrowable t) { + return unreadableString("PATHNAME"); + } + } + + // A logical host is represented as the string that names it. + // (defvar *logical-pathname-translations* (make-hash-table :test 'equal)) + public static EqualHashTable LOGICAL_PATHNAME_TRANSLATIONS = + new EqualHashTable(64, NIL, NIL); + + private static final Symbol _LOGICAL_PATHNAME_TRANSLATIONS_ = + exportSpecial("*LOGICAL-PATHNAME-TRANSLATIONS*", PACKAGE_SYS, + LOGICAL_PATHNAME_TRANSLATIONS); + + public static Pathname parseNamestring(String s) + throws ConditionThrowable + { + return new Pathname(s); + } + + public static Pathname parseNamestring(AbstractString namestring) + throws ConditionThrowable + { + // Check for a logical pathname host. + String s = namestring.getStringValue(); + String h = getHostString(s); + if (h != null && LOGICAL_PATHNAME_TRANSLATIONS.get(new SimpleString(h)) != null) { + // A defined logical pathname host. + return new LogicalPathname(h, s.substring(s.indexOf(':') + 1)); + } + return new Pathname(s); + } + + public static Pathname parseNamestring(AbstractString namestring, + AbstractString host) + throws ConditionThrowable + { + // Look for a logical pathname host in the namestring. + String s = namestring.getStringValue(); + String h = getHostString(s); + if (h != null) { + if (!h.equals(host.getStringValue())) { + error(new LispError("Host in " + s + + " does not match requested host " + + host.getStringValue())); + // Not reached. + return null; + } + // Remove host prefix from namestring. + s = s.substring(s.indexOf(':') + 1); + } + if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) != null) { + // A defined logical pathname host. + return new LogicalPathname(host.getStringValue(), s); + } + error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + // Not reached. + return null; + } + + // "one or more uppercase letters, digits, and hyphens" + protected static String getHostString(String s) + { + int colon = s.indexOf(':'); + if (colon >= 0) + return s.substring(0, colon).toUpperCase(); + else + return null; + } + + private static final void checkCaseArgument(LispObject arg) + throws ConditionThrowable + { + if (arg != Keyword.COMMON && arg != Keyword.LOCAL) + type_error(arg, list3(Symbol.MEMBER, Keyword.COMMON, + Keyword.LOCAL)); + } + + // ### %pathname-host + private static final Primitive _PATHNAME_HOST = + new Primitive("%pathname-host", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkCaseArgument(second); + return coerceToPathname(first).host; + } + }; + + // ### %pathname-device + private static final Primitive _PATHNAME_DEVICE = + new Primitive("%pathname-device", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkCaseArgument(second); + return coerceToPathname(first).device; + } + }; + + // ### %pathname-directory + private static final Primitive _PATHNAME_DIRECTORY = + new Primitive("%pathname-directory", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkCaseArgument(second); + return coerceToPathname(first).directory; + } + }; + + // ### %pathname-name + private static final Primitive _PATHNAME_NAME = + new Primitive("%pathname-name", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkCaseArgument(second); + return coerceToPathname(first).name; + } + }; + + // ### %pathname-type + private static final Primitive _PATHNAME_TYPE = + new Primitive("%pathname-type", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkCaseArgument(second); + return coerceToPathname(first).type; + } + }; + + // ### pathname-version + private static final Primitive PATHNAME_VERSION = + new Primitive("pathname-version", "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPathname(arg).version; + } + }; + + // ### namestring + // namestring pathname => namestring + private static final Primitive NAMESTRING = + new Primitive("namestring", "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + String namestring = pathname.getNamestring(); + if (namestring == null) + error(new SimpleError("Pathname has no namestring: " + + pathname.writeToString())); + return new SimpleString(namestring); + } + }; + + // ### directory-namestring + // directory-namestring pathname => namestring + private static final Primitive DIRECTORY_NAMESTRING = + new Primitive("directory-namestring", "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new SimpleString(coerceToPathname(arg).getDirectoryNamestring()); + } + }; + + // ### pathname pathspec => pathname + private static final Primitive PATHNAME = + new Primitive("pathname", "pathspec") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPathname(arg); + } + }; + + // ### %parse-namestring string host default-pathname => pathname, position + private static final Primitive _PARSE_NAMESTRING = + new Primitive("%parse-namestring", PACKAGE_SYS, false, + "namestring host default-pathname") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final AbstractString namestring; + try { + namestring = (AbstractString) first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STRING); + } + // The HOST parameter must be a string or NIL. + if (second == NIL) { + // "If HOST is NIL, DEFAULT-PATHNAME is a logical pathname, and + // THING is a syntactically valid logical pathname namestring + // without an explicit host, then it is parsed as a logical + // pathname namestring on the host that is the host component + // of DEFAULT-PATHNAME." + third = coerceToPathname(third); + if (third instanceof LogicalPathname) + second = ((LogicalPathname)third).host; + else + return thread.setValues(parseNamestring(namestring), + namestring.LENGTH()); + } + Debug.assertTrue(second != NIL); + final AbstractString host; + try { + host = (AbstractString) second; + } + catch (ClassCastException e) { + return type_error(second, Symbol.STRING); + } + return thread.setValues(parseNamestring(namestring, host), + namestring.LENGTH()); + } + }; + + // ### make-pathname + private static final Primitive MAKE_PATHNAME = + new Primitive("make-pathname", + "&key host device directory name type version defaults case") + { + @Override + public LispObject execute(LispObject[] args) + throws ConditionThrowable + { + return _makePathname(args); + } + }; + + // Used by the #p reader. + public static final Pathname makePathname(LispObject args) + throws ConditionThrowable + { + return _makePathname(args.copyToArray()); + } + + private static final Pathname _makePathname(LispObject[] args) + throws ConditionThrowable + { + if (args.length % 2 != 0) + error(new ProgramError("Odd number of keyword arguments.")); + LispObject host = NIL; + LispObject device = NIL; + LispObject directory = NIL; + LispObject name = NIL; + LispObject type = NIL; + LispObject version = NIL; + Pathname defaults = null; + boolean deviceSupplied = false; + boolean nameSupplied = false; + boolean typeSupplied = false; + for (int i = 0; i < args.length; i += 2) { + LispObject key = args[i]; + LispObject value = args[i+1]; + if (key == Keyword.HOST) { + host = value; + } else if (key == Keyword.DEVICE) { + device = value; + deviceSupplied = true; + } else if (key == Keyword.DIRECTORY) { + if (value instanceof AbstractString) + directory = list2(Keyword.ABSOLUTE, value); + else if (value == Keyword.WILD) + directory = list2(Keyword.ABSOLUTE, Keyword.WILD); + else + directory = value; + } else if (key == Keyword.NAME) { + name = value; + nameSupplied = true; + } else if (key == Keyword.TYPE) { + type = value; + typeSupplied = true; + } else if (key == Keyword.VERSION) { + version = value; + } else if (key == Keyword.DEFAULTS) { + defaults = coerceToPathname(value); + } else if (key == Keyword.CASE) { + // Ignored. + } + } + if (defaults != null) { + if (host == NIL) + host = defaults.host; + directory = mergeDirectories(directory, defaults.directory); + if (!deviceSupplied) + device = defaults.device; + if (!nameSupplied) + name = defaults.name; + if (!typeSupplied) + type = defaults.type; + } + final Pathname p; + final boolean logical; + if (host != NIL) { + if (host instanceof AbstractString) + host = LogicalPathname.canonicalizeStringComponent((AbstractString)host); + if (LOGICAL_PATHNAME_TRANSLATIONS.get(host) == null) { + // Not a defined logical pathname host. + error(new LispError(host.writeToString() + " is not defined as a logical pathname host.")); + } + p = new LogicalPathname(); + logical = true; + p.host = host; + p.device = Keyword.UNSPECIFIC; + } else { + p = new Pathname(); + logical = false; + } + if (device != NIL) { + if (logical) { + // "The device component of a logical pathname is always :UNSPECIFIC." + if (device != Keyword.UNSPECIFIC) + error(new LispError("The device component of a logical pathname must be :UNSPECIFIC.")); + } else + p.device = device; + } + if (directory != NIL) { + if (logical) { + if (directory.listp()) { + LispObject d = NIL; + while (directory != NIL) { + LispObject component = directory.car(); + if (component instanceof AbstractString) + d = d.push(LogicalPathname.canonicalizeStringComponent((AbstractString)component)); + else + d = d.push(component); + directory = directory.cdr(); + } + p.directory = d.nreverse(); + } else if (directory == Keyword.WILD || directory == Keyword.WILD_INFERIORS) + p.directory = directory; + else + error(new LispError("Invalid directory component for logical pathname: " + directory.writeToString())); + } else + p.directory = directory; + } + if (name != NIL) { + if (logical && name instanceof AbstractString) + p.name = LogicalPathname.canonicalizeStringComponent((AbstractString)name); + else if (name instanceof AbstractString) + p.name = validateStringComponent((AbstractString)name); + else + p.name = name; + } + if (type != NIL) { + if (logical && type instanceof AbstractString) + p.type = LogicalPathname.canonicalizeStringComponent((AbstractString)type); + else + p.type = type; + } + p.version = version; + return p; + } + + private static final AbstractString validateStringComponent(AbstractString s) + throws ConditionThrowable + { + final int limit = s.length(); + for (int i = 0; i < limit; i++) { + char c = s.charAt(i); + if (c == '/' || c == '\\' && Utilities.isPlatformWindows) { + error(new LispError("Invalid character #\\" + c + + " in pathname component \"" + s + + '"')); + // Not reached. + return null; + } + } + return s; + } + + private final boolean validateDirectory(boolean signalError) + throws ConditionThrowable + { + LispObject temp = directory; + while (temp != NIL) { + LispObject first = temp.car(); + temp = temp.cdr(); + if (first == Keyword.ABSOLUTE || first == Keyword.WILD_INFERIORS) { + LispObject second = temp.car(); + if (second == Keyword.UP || second == Keyword.BACK) { + if (signalError) { + FastStringBuffer sb = new FastStringBuffer(); + sb.append(first.writeToString()); + sb.append(" may not be followed immediately by "); + sb.append(second.writeToString()); + sb.append('.'); + error(new FileError(sb.toString(), this)); + } + return false; + } + } + } + return true; + } + + // ### pathnamep + private static final Primitive PATHNAMEP = + new Primitive("pathnamep", "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof Pathname ? T : NIL; + } + }; + + // ### logical-pathname-p + private static final Primitive LOGICAL_PATHNAME_P = + new Primitive("logical-pathname-p", PACKAGE_SYS, true, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof LogicalPathname ? T : NIL; + } + }; + + // ### user-homedir-pathname &optional host => pathname + private static final Primitive USER_HOMEDIR_PATHNAME = + new Primitive("user-homedir-pathname", "&optional host") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + switch (args.length) { + case 0: { + String s = System.getProperty("user.home"); + if (!s.endsWith(File.separator)) + s = s.concat(File.separator); + return new Pathname(s); + } + case 1: + return NIL; + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + }; + + // ### list-directory + private static final Primitive LIST_DIRECTORY = + new Primitive("list-directory", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + if (pathname instanceof LogicalPathname) + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); + LispObject result = NIL; + String s = pathname.getNamestring(); + if (s != null) { + File f = new File(s); + if (f.isDirectory()) { + try { + File[] files = f.listFiles(); + for (int i = files.length; i-- > 0;) { + File file = files[i]; + Pathname p; + if (file.isDirectory()) + p = Utilities.getDirectoryPathname(file); + else + p = new Pathname(file.getCanonicalPath()); + result = new Cons(p, result); + } + } + catch (IOException e) { + return error(new FileError("Unable to list directory " + pathname.writeToString() + ".", + pathname)); + } + catch (SecurityException e) { + } + catch (NullPointerException e) { + } + } + } + return result; + } + }; + + public boolean isWild() throws ConditionThrowable + { + if (host == Keyword.WILD || host == Keyword.WILD_INFERIORS) + return true; + if (device == Keyword.WILD || device == Keyword.WILD_INFERIORS) + return true; + if (directory instanceof Cons) { + if (memq(Keyword.WILD, directory)) + return true; + if (memq(Keyword.WILD_INFERIORS, directory)) + return true; + } + if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) + return true; + if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) + return true; + if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) + return true; + return false; + } + + // ### %wild-pathname-p + private static final Primitive _WILD_PATHNAME_P = + new Primitive("%wild-pathname-p", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Pathname pathname = coerceToPathname(first); + if (second == NIL) + return pathname.isWild() ? T : NIL; + if (second == Keyword.DIRECTORY) { + if (pathname.directory instanceof Cons) { + if (memq(Keyword.WILD, pathname.directory)) + return T; + if (memq(Keyword.WILD_INFERIORS, pathname.directory)) + return T; + } + return NIL; + } + LispObject value; + if (second == Keyword.HOST) + value = pathname.host; + else if (second == Keyword.DEVICE) + value = pathname.device; + else if (second == Keyword.NAME) + value = pathname.name; + else if (second == Keyword.TYPE) + value = pathname.type; + else if (second == Keyword.VERSION) + value = pathname.version; + else + return error(new ProgramError("Unrecognized keyword " + + second.writeToString() + ".")); + if (value == Keyword.WILD || value == Keyword.WILD_INFERIORS) + return T; + else + return NIL; + } + }; + + // ### merge-pathnames + private static final Primitive MERGE_PATHNAMES = + new Primitive("merge-pathnames", + "pathname &optional default-pathname default-version") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + Pathname defaultPathname = + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()); + LispObject defaultVersion = Keyword.NEWEST; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Pathname pathname = coerceToPathname(first); + Pathname defaultPathname = + coerceToPathname(second); + LispObject defaultVersion = Keyword.NEWEST; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + Pathname pathname = coerceToPathname(first); + Pathname defaultPathname = + coerceToPathname(second); + LispObject defaultVersion = third; + return mergePathnames(pathname, defaultPathname, defaultVersion); + } + }; + + public static final Pathname mergePathnames(Pathname pathname, + Pathname defaultPathname, + LispObject defaultVersion) + throws ConditionThrowable + { + Pathname p; + if (pathname instanceof LogicalPathname) + p = new LogicalPathname(); + else + p = new Pathname(); + if (pathname.host != NIL) + p.host = pathname.host; + else + p.host = defaultPathname.host; + if (pathname.device != NIL) + p.device = pathname.device; + else + p.device = defaultPathname.device; + p.directory = + mergeDirectories(pathname.directory, defaultPathname.directory); + if (pathname.name != NIL) + p.name = pathname.name; + else + p.name = defaultPathname.name; + if (pathname.type != NIL) + p.type = pathname.type; + else + p.type = defaultPathname.type; + if (pathname.version != NIL) + p.version = pathname.version; + else if (pathname.name instanceof AbstractString) + p.version = defaultVersion; + else if (defaultPathname.version != NIL) + p.version = defaultPathname.version; + else + p.version = defaultVersion; + if (p instanceof LogicalPathname) { + // When we're returning a logical + p.device = Keyword.UNSPECIFIC; + if (p.directory.listp()) { + LispObject original = p.directory; + LispObject canonical = NIL; + while (original != NIL) { + LispObject component = original.car(); + if (component instanceof AbstractString) + component = LogicalPathname.canonicalizeStringComponent((AbstractString)component); + canonical = canonical.push(component); + original = original.cdr(); + } + p.directory = canonical.nreverse(); + } + if (p.name instanceof AbstractString) + p.name = LogicalPathname.canonicalizeStringComponent((AbstractString)p.name); + if (p.type instanceof AbstractString) + p.type = LogicalPathname.canonicalizeStringComponent((AbstractString)p.type); + } + return p; + } + + private static final LispObject mergeDirectories(LispObject dir, + LispObject defaultDir) + throws ConditionThrowable + { + if (dir == NIL) + return defaultDir; + if (dir.car() == Keyword.RELATIVE && defaultDir != NIL) { + LispObject result = NIL; + while (defaultDir != NIL) { + result = new Cons(defaultDir.car(), result); + defaultDir = defaultDir.cdr(); + } + dir = dir.cdr(); // Skip :RELATIVE. + while (dir != NIL) { + result = new Cons(dir.car(), result); + dir = dir.cdr(); + } + LispObject[] array = result.copyToArray(); + for (int i = 0; i < array.length - 1; i++) { + if (array[i] == Keyword.BACK) { + if (array[i+1] instanceof AbstractString || array[i+1] == Keyword.WILD) { + array[i] = null; + array[i+1] = null; + } + } + } + result = NIL; + for (int i = 0; i < array.length; i++) { + if (array[i] != null) + result = new Cons(array[i], result); + } + return result; + } + return dir; + } + + public static final LispObject truename(LispObject arg, + boolean errorIfDoesNotExist) + throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + if (pathname instanceof LogicalPathname) + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); + if (pathname.isWild()) + return error(new FileError("Bad place for a wild pathname.", + pathname)); + final Pathname defaultedPathname = + mergePathnames(pathname, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), + NIL); + final String namestring = defaultedPathname.getNamestring(); + if (namestring == null) + return error(new FileError("Pathname has no namestring: " + defaultedPathname.writeToString(), + defaultedPathname)); + final File file = new File(namestring); + if (file.isDirectory()) + return Utilities.getDirectoryPathname(file); + if (file.exists()) { + try { + return new Pathname(file.getCanonicalPath()); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + } + if (errorIfDoesNotExist) { + FastStringBuffer sb = new FastStringBuffer("The file "); + sb.append(defaultedPathname.writeToString()); + sb.append(" does not exist."); + return error(new FileError(sb.toString(), defaultedPathname)); + } + return NIL; + } + + // ### mkdir + private static final Primitive MKDIR = + new Primitive("mkdir", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) + error(new FileError("Bad place for a wild pathname.", pathname)); + Pathname defaultedPathname = + mergePathnames(pathname, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), + NIL); + File file = Utilities.getFile(defaultedPathname); + return file.mkdir() ? T : NIL; + } + }; + + // ### rename-file filespec new-name => defaulted-new-name, old-truename, new-truename + public static final Primitive RENAME_FILE = + new Primitive("rename-file", "filespec new-name") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Pathname original = (Pathname) truename(first, true); + final String originalNamestring = original.getNamestring(); + Pathname newName = coerceToPathname(second); + if (newName.isWild()) + error(new FileError("Bad place for a wild pathname.", newName)); + newName = mergePathnames(newName, original, NIL); + final String newNamestring; + if (newName instanceof LogicalPathname) + newNamestring = LogicalPathname.translateLogicalPathname((LogicalPathname)newName).getNamestring(); + else + newNamestring = newName.getNamestring(); + if (originalNamestring != null && newNamestring != null) { + final File source = new File(originalNamestring); + final File destination = new File(newNamestring); + if (Utilities.isPlatformWindows) { + if (destination.isFile()) + destination.delete(); + } + if (source.renameTo(destination)) + // Success! + return LispThread.currentThread().setValues(newName, original, + truename(newName, true)); + } + return error(new FileError("Unable to rename " + + original.writeToString() + + " to " + newName.writeToString() + + ".")); + } + }; + + // ### file-namestring pathname => namestring + private static final Primitive FILE_NAMESTRING = + new Primitive("file-namestring", "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname p = coerceToPathname(arg); + FastStringBuffer sb = new FastStringBuffer(); + if (p.name instanceof AbstractString) + sb.append(p.name.getStringValue()); + else if (p.name == Keyword.WILD) + sb.append('*'); + else + return NIL; + if (p.type instanceof AbstractString) { + sb.append('.'); + sb.append(p.type.getStringValue()); + } else if (p.type == Keyword.WILD) + sb.append(".*"); + return new SimpleString(sb); + } + }; + + // ### host-namestring pathname => namestring + private static final Primitive HOST_NAMESTRING = + new Primitive("host-namestring", "pathname") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPathname(arg).host; + } + }; + + static { + try { + LispObject obj = Symbol.DEFAULT_PATHNAME_DEFAULTS.getSymbolValue(); + Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(coerceToPathname(obj)); + } + catch (Throwable t) { + Debug.trace(t); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/Primitive.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Primitive.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,213 @@ +/* + * Primitive.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Primitive.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Primitive extends Function +{ + public Primitive(LispObject name) + { + super(name); + } + + public Primitive(String name) + { + super(name); + } + + public Primitive(Symbol symbol, String arglist) + { + super(symbol, arglist); + } + + public Primitive(Symbol symbol, String arglist, String docstring) + { + super(symbol, arglist, docstring); + } + + public Primitive(String name, String arglist) + { + super(name, arglist); + } + + public Primitive(LispObject name, LispObject lambdaList) + { + super(name, lambdaList); + } + + public Primitive(String name, Package pkg) + { + super(name, pkg); + } + + public Primitive(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public Primitive(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + public Primitive(String name, Package pkg, boolean exported, + String arglist, String docstring) + { + super(name, pkg, exported, arglist, docstring); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILED_FUNCTION; + } + + @Override + public LispObject execute() throws ConditionThrowable + { + LispObject[] args = new LispObject[0]; + return execute(args); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispObject[] args = new LispObject[1]; + args[0] = arg; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + LispObject[] args = new LispObject[2]; + args[0] = first; + args[1] = second; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + LispObject[] args = new LispObject[3]; + args[0] = first; + args[1] = second; + args[2] = third; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[4]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[5]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[6]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + LispObject[] args = new LispObject[7]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + return execute(args); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + LispObject[] args = new LispObject[8]; + args[0] = first; + args[1] = second; + args[2] = third; + args[3] = fourth; + args[4] = fifth; + args[5] = sixth; + args[6] = seventh; + args[7] = eighth; + return execute(args); + } +} Added: branches/save-image/src/org/armedbear/lisp/Primitive0R.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Primitive0R.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,174 @@ +/* + * Primitive0R.java + * + * Copyright (C) 2005 Peter Graves + * $Id: Primitive0R.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Primitive0R extends Function +{ + public Primitive0R(LispObject name) + { + super(name); + } + + public Primitive0R(String name) + { + super(name); + } + + public Primitive0R(String name, String arglist) + { + super(name, arglist); + } + + public Primitive0R(LispObject name, LispObject lambdaList) + { + super(name, lambdaList); + } + + public Primitive0R(String name, Package pkg) + { + super(name, pkg); + } + + public Primitive0R(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public Primitive0R(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + public Primitive0R(String name, Package pkg, boolean exported, + String arglist, String docstring) + { + super(name, pkg, exported, arglist, docstring); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILED_FUNCTION; + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return _execute(NIL); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return _execute(new Cons(arg)); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return _execute(list2(first, second)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return _execute(list3(first, second, third)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return _execute(list4(first, second, third, fourth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return _execute(list5(first, second, third, fourth, fifth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return _execute(list6(first, second, third, fourth, fifth, sixth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return _execute(list7(first, second, third, fourth, fifth, sixth, + seventh)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return _execute(list8(first, second, third, fourth, fifth, sixth, + seventh, eighth)); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject list = NIL; + for (int i = args.length; i-- > 0;) + list = new Cons(args[i], list); + return _execute(list); + } + + protected LispObject _execute(LispObject arg) throws ConditionThrowable + { + return error(new LispError("Not implemented.")); + } +} Added: branches/save-image/src/org/armedbear/lisp/Primitive1R.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Primitive1R.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,169 @@ +/* + * Primitive1R.java + * + * Copyright (C) 2005 Peter Graves + * $Id: Primitive1R.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Primitive1R extends Function +{ + public Primitive1R(LispObject name) + { + super(name); + } + + public Primitive1R(String name) + { + super(name); + } + + public Primitive1R(String name, String arglist) + { + super(name, arglist); + } + + public Primitive1R(LispObject name, LispObject lambdaList) + { + super(name, lambdaList); + } + + public Primitive1R(String name, Package pkg) + { + super(name, pkg); + } + + public Primitive1R(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public Primitive1R(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + public Primitive1R(String name, Package pkg, boolean exported, + String arglist, String docstring) + { + super(name, pkg, exported, arglist, docstring); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILED_FUNCTION; + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return _execute(arg, NIL); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return _execute(first, new Cons(second)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return _execute(first, list2(second, third)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return _execute(first, list3(second, third, fourth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return _execute(first, list4(second, third, fourth, fifth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return _execute(first, list5(second, third, fourth, fifth, sixth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return _execute(first, list6(second, third, fourth, fifth, sixth, + seventh)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return _execute(first, list7(second, third, fourth, fifth, sixth, + seventh, eighth)); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject list = NIL; + for (int i = args.length; i-- > 1;) + list = new Cons(args[i], list); + return _execute(args[0], list); + } + + protected LispObject _execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return error(new LispError("Not implemented.")); + } +} Added: branches/save-image/src/org/armedbear/lisp/Primitive2R.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Primitive2R.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,164 @@ +/* + * Primitive2R.java + * + * Copyright (C) 2005 Peter Graves + * $Id: Primitive2R.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Primitive2R extends Function +{ + public Primitive2R(LispObject name) + { + super(name); + } + + public Primitive2R(String name) + { + super(name); + } + + public Primitive2R(String name, String arglist) + { + super(name, arglist); + } + + public Primitive2R(LispObject name, LispObject lambdaList) + { + super(name, lambdaList); + } + + public Primitive2R(String name, Package pkg) + { + super(name, pkg); + } + + public Primitive2R(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public Primitive2R(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + public Primitive2R(String name, Package pkg, boolean exported, + String arglist, String docstring) + { + super(name, pkg, exported, arglist, docstring); + } + + @Override + public LispObject typeOf() + { + return Symbol.COMPILED_FUNCTION; + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return _execute(first, second, NIL); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return _execute(first, second, new Cons(third)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return _execute(first, second, list2(third, fourth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return _execute(first, second, list3(third, fourth, fifth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return _execute(first, second, list4(third, fourth, fifth, sixth)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return _execute(first, second, list5(third, fourth, fifth, sixth, + seventh)); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return _execute(first, second, list6(third, fourth, fifth, sixth, + seventh, eighth)); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject list = NIL; + for (int i = args.length; i-- > 2;) + list = new Cons(args[i], list); + return _execute(args[0], args[1], list); + } + + protected LispObject _execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return error(new LispError("Not implemented.")); + } +} Added: branches/save-image/src/org/armedbear/lisp/Primitives.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Primitives.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,5991 @@ +/* + * Primitives.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Primitives.java 11539 2009-01-04 14:27:54Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; +import java.util.ArrayList; + +public final class Primitives extends Lisp +{ + // ### * + public static final Primitive MULTIPLY = + new Primitive(Symbol.STAR, "&rest numbers") + { + @Override + public LispObject execute() + { + return Fixnum.ONE; + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg.numberp()) + return arg; + return type_error(arg, Symbol.NUMBER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.multiplyBy(second); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = Fixnum.ONE; + for (int i = 0; i < args.length; i++) + result = result.multiplyBy(args[i]); + return result; + } + }; + + // ### / + public static final Primitive DIVIDE = + new Primitive(Symbol.SLASH, "numerator &rest denominators") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Fixnum.ONE.divideBy(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.divideBy(second); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = args[0]; + for (int i = 1; i < args.length; i++) + result = result.divideBy(args[i]); + return result; + } + }; + + // ### min + public static final Primitive MIN = + new Primitive(Symbol.MIN, "&rest reals") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg.realp()) + return arg; + return type_error(arg, Symbol.REAL); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isLessThan(second) ? first : second; + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = args[0]; + if (!result.realp()) + type_error(result, Symbol.REAL); + for (int i = 1; i < args.length; i++) + { + if (args[i].isLessThan(result)) + result = args[i]; + } + return result; + } + }; + + // ### max + public static final Primitive MAX = + new Primitive(Symbol.MAX, "&rest reals") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg.realp()) + return arg; + return type_error(arg, Symbol.REAL); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isGreaterThan(second) ? first : second; + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = args[0]; + if (!result.realp()) + type_error(result, Symbol.REAL); + for (int i = 1; i < args.length; i++) + { + if (args[i].isGreaterThan(result)) + result = args[i]; + } + return result; + } + }; + + // ### identity + private static final Primitive IDENTITY = + new Primitive(Symbol.IDENTITY, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg; + } + }; + + // ### compiled-function-p + private static final Primitive COMPILED_FUNCTION_P = + new Primitive(Symbol.COMPILED_FUNCTION_P, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.typep(Symbol.COMPILED_FUNCTION); + } + }; + + // ### consp + private static final Primitive CONSP = + new Primitive(Symbol.CONSP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof Cons ? T : NIL; + } + }; + + // ### listp + private static final Primitive LISTP = + new Primitive(Symbol.LISTP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.LISTP(); + } + }; + + // ### abs + private static final Primitive ABS = + new Primitive(Symbol.ABS, "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.ABS(); + } + }; + + // ### arrayp + private static final Primitive ARRAYP = + new Primitive(Symbol.ARRAYP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof AbstractArray ? T : NIL; + } + }; + + // ### array-has-fill-pointer-p + private static final Primitive ARRAY_HAS_FILL_POINTER_P = + new Primitive(Symbol.ARRAY_HAS_FILL_POINTER_P, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((AbstractArray)arg).hasFillPointer() ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + // ### vectorp + private static final Primitive VECTORP = + new Primitive(Symbol.VECTORP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.VECTORP(); + } + }; + + // ### simple-vector-p + private static final Primitive SIMPLE_VECTOR_P = + new Primitive(Symbol.SIMPLE_VECTOR_P, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof SimpleVector ? T : NIL; + } + }; + + // ### bit-vector-p + private static final Primitive BIT_VECTOR_P = + new Primitive(Symbol.BIT_VECTOR_P, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof AbstractBitVector ? T : NIL; + } + }; + + // ### simple-bit-vector-p + private static final Primitive SIMPLE_BIT_VECTOR_P = + new Primitive(Symbol.SIMPLE_BIT_VECTOR_P, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.typep(Symbol.SIMPLE_BIT_VECTOR); + } + }; + + // ### %eval + private static final Primitive _EVAL = + new Primitive("%eval", PACKAGE_SYS, false, "form") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return eval(arg, new Environment(), LispThread.currentThread()); + } + }; + + // ### eq + private static final Primitive EQ = new Primitive(Symbol.EQ, "x y") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first == second ? T : NIL; + } + }; + + // ### eql + private static final Primitive EQL = new Primitive(Symbol.EQL, "x y") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.eql(second) ? T : NIL; + } + }; + + // ### equal + private static final Primitive EQUAL = new Primitive(Symbol.EQUAL, "x y") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.equal(second) ? T : NIL; + } + }; + + // ### equalp + private static final Primitive EQUALP = new Primitive(Symbol.EQUALP, "x y") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.equalp(second) ? T : NIL; + } + }; + + // ### values + private static final Primitive VALUES = + new Primitive(Symbol.VALUES, "&rest object") + { + @Override + public LispObject execute() + { + return LispThread.currentThread().setValues(); + } + @Override + public LispObject execute(LispObject arg) + { + return LispThread.currentThread().setValues(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + return LispThread.currentThread().setValues(first, second); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + { + return LispThread.currentThread().setValues(first, second, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + { + return LispThread.currentThread().setValues(first, second, third, + fourth); + } + @Override + public LispObject execute(LispObject[] args) + { + return LispThread.currentThread().setValues(args); + } + }; + + // ### values-list list => element* + // Returns the elements of the list as multiple values. + private static final Primitive VALUES_LIST = + new Primitive(Symbol.VALUES_LIST, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == NIL) + return LispThread.currentThread().setValues(); + if (arg.cdr() == NIL) + return arg.car(); + return LispThread.currentThread().setValues(arg.copyToArray()); + } + }; + + // ### cons + private static final Primitive CONS = + new Primitive(Symbol.CONS, "object-1 object-2") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return new Cons(first, second); + } + }; + + // ### length + private static final Primitive LENGTH = + new Primitive(Symbol.LENGTH, "sequence") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.LENGTH(); + } + }; + + // ### elt + private static final Primitive ELT = + new Primitive(Symbol.ELT, "sequence index") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return first.elt(((Fixnum)second).value); + } + catch (ClassCastException e) + { + return type_error(second, Symbol.FIXNUM); + } + } + }; + + // ### atom + private static final Primitive ATOM = new Primitive(Symbol.ATOM, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof Cons ? NIL : T; + } + }; + + // ### constantp + private static final Primitive CONSTANTP = + new Primitive(Symbol.CONSTANTP, "form &optional environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.constantp() ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.constantp() ? T : NIL; + } + }; + + // ### functionp + private static final Primitive FUNCTIONP = + new Primitive(Symbol.FUNCTIONP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return (arg instanceof Function || arg instanceof StandardGenericFunction) ? T : NIL; + } + }; + + // ### special-operator-p + private static final Primitive SPECIAL_OPERATOR_P = + new Primitive(Symbol.SPECIAL_OPERATOR_P, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.isSpecialOperator() ? T : NIL; + } + }; + + // ### symbolp + private static final Primitive SYMBOLP = + new Primitive(Symbol.SYMBOLP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof Symbol ? T : NIL; + } + }; + + // ### endp + private static final Primitive ENDP = new Primitive(Symbol.ENDP, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.endp() ? T : NIL; + } + }; + + // ### null + private static final Primitive NULL = new Primitive(Symbol.NULL, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg == NIL ? T : NIL; + } + }; + + // ### not + private static final Primitive NOT = new Primitive(Symbol.NOT, "x") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg == NIL ? T : NIL; + } + }; + + // ### plusp + private static final Primitive PLUSP = new Primitive(Symbol.PLUSP, "real") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.PLUSP(); + } + }; + + // ### minusp + private static final Primitive MINUSP = + new Primitive(Symbol.MINUSP, "real") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.MINUSP(); + } + }; + + // ### zerop + private static final Primitive ZEROP = + new Primitive(Symbol.ZEROP, "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.ZEROP(); + } + }; + + // ### fixnump + private static final Primitive FIXNUMP = + new Primitive("fixnump", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof Fixnum ? T : NIL; + } + }; + + // ### symbol-value + private static final Primitive SYMBOL_VALUE = + new Primitive(Symbol.SYMBOL_VALUE, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispObject value; + try + { + value = ((Symbol)arg).symbolValue(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + if (value instanceof SymbolMacro) + return error(new LispError(arg.writeToString() + + " has no dynamic value.")); + return value; + } + }; + + // ### set symbol value => value + private static final Primitive SET = + new Primitive(Symbol.SET, "symbol value") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return LispThread.currentThread().setSpecialVariable((Symbol)first, + second); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + }; + + // ### rplaca + private static final Primitive RPLACA = + new Primitive(Symbol.RPLACA, "cons object") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + first.setCar(second); + return first; + } + }; + + // ### rplacd + private static final Primitive RPLACD = + new Primitive(Symbol.RPLACD, "cons object") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + first.setCdr(second); + return first; + } + }; + + // ### + + private static final Primitive ADD = + new Primitive(Symbol.PLUS, "&rest numbers") + { + @Override + public LispObject execute() + { + return Fixnum.ZERO; + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg.numberp()) + return arg; + return type_error(arg, Symbol.NUMBER); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.add(second); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return first.add(second).add(third); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = Fixnum.ZERO; + final int length = args.length; + for (int i = 0; i < length; i++) + result = result.add(args[i]); + return result; + } + }; + + // ### 1+ + private static final Primitive ONE_PLUS = + new Primitive(Symbol.ONE_PLUS, "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.incr(); + } + }; + + // ### - + private static final Primitive SUBTRACT = + new Primitive(Symbol.MINUS, "minuend &rest subtrahends") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.negate(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.subtract(second); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = args[0]; + for (int i = 1; i < args.length; i++) + result = result.subtract(args[i]); + return result; + } + }; + + // ### 1- + private static final Primitive ONE_MINUS = + new Primitive(Symbol.ONE_MINUS, "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.decr(); + } + }; + + // ### when + private static final SpecialOperator WHEN = + new SpecialOperator(Symbol.WHEN) + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + if (eval(args.car(), env, thread) != NIL) + { + args = args.cdr(); + thread.clearValues(); + return progn(args, env, thread); + } + return thread.setValues(NIL); + } + }; + + // ### unless + private static final SpecialOperator UNLESS = + new SpecialOperator(Symbol.UNLESS) + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + if (eval(args.car(), env, thread) == NIL) + { + args = args.cdr(); + thread.clearValues(); + return progn(args, env, thread); + } + return thread.setValues(NIL); + } + }; + + // ### %stream-output-object object stream => object + private static final Primitive _STREAM_OUTPUT_OBJECT = + new Primitive("%stream-output-object", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((Stream)second)._writeString(first.writeToString()); + return first; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STREAM); + } + } + }; + + // ### %output-object object stream => object + private static final Primitive _OUTPUT_OBJECT = + new Primitive("%output-object", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Stream out; + try + { + if (second == T) + out = (Stream) Symbol.TERMINAL_IO.symbolValue(); + else if (second == NIL) + out = (Stream) Symbol.STANDARD_OUTPUT.symbolValue(); + else + out = (Stream) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STREAM); + } + out._writeString(first.writeToString()); + return first; + } + }; + + // ### %write-to-string object => string + private static final Primitive _WRITE_TO_STRING = + new Primitive("%write-to-string", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new SimpleString(arg.writeToString()); + } + }; + + // ### %stream-terpri output-stream => nil + private static final Primitive _STREAM_TERPRI = + new Primitive("%stream-terpri", PACKAGE_SYS, true, "output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + ((Stream)arg)._writeChar('\n'); + return NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + } + }; + + // ### %terpri output-stream => nil + private static final Primitive _TERPRI = + new Primitive("%terpri", PACKAGE_SYS, false, "output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == T) + arg = Symbol.TERMINAL_IO.symbolValue(); + else if (arg == NIL) + arg = Symbol.STANDARD_OUTPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + return stream.terpri(); + } + }; + + // ### %fresh-line + // %fresh-line &optional output-stream => generalized-boolean + private static final Primitive _FRESH_LINE = + new Primitive("%fresh-line", PACKAGE_SYS, false, "output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == T) + arg = Symbol.TERMINAL_IO.symbolValue(); + else if (arg == NIL) + arg = Symbol.STANDARD_OUTPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + return stream.freshLine(); + } + }; + + // ### boundp + // Determines only whether a symbol has a value in the global environment; + // any lexical bindings are ignored. + private static final Primitive BOUNDP = + new Primitive(Symbol.BOUNDP, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final Symbol symbol; + try + { + symbol = (Symbol) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + // PROGV: "If too few values are supplied, the remaining symbols + // are bound and then made to have no value." So BOUNDP must + // explicitly check for a binding with no value. + SpecialBinding binding = + LispThread.currentThread().getSpecialBinding(symbol); + if (binding != null) + return binding.value != null ? T : NIL; + // No binding. + return symbol.getSymbolValue() != null ? T : NIL; + } + }; + + // ### fboundp + private static final Primitive FBOUNDP = + new Primitive(Symbol.FBOUNDP, "name") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Symbol) + return arg.getSymbolFunction() != null ? T : NIL; + if (isValidSetfFunctionName(arg)) + { + LispObject f = get(arg.cadr(), Symbol.SETF_FUNCTION, null); + return f != null ? T : NIL; + } + return type_error(arg, FUNCTION_NAME); + } + }; + + // ### fmakunbound name => name + private static final Primitive FMAKUNBOUND = + new Primitive(Symbol.FMAKUNBOUND, "name") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Symbol) + { + ((Symbol)arg).setSymbolFunction(null); + return arg; + } + if (isValidSetfFunctionName(arg)) + { + remprop((Symbol)arg.cadr(), Symbol.SETF_FUNCTION); + return arg; + } + return type_error(arg, FUNCTION_NAME); + } + }; + + // ### setf-function-name-p + private static final Primitive SETF_FUNCTION_NAME_P = + new Primitive("setf-function-name-p", PACKAGE_SYS, true, "thing") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return isValidSetfFunctionName(arg) ? T : NIL; + } + }; + + // ### remprop + private static final Primitive REMPROP = + new Primitive(Symbol.REMPROP, "symbol indicator") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return remprop(checkSymbol(first), second); + } + }; + + // ### append + public static final Primitive APPEND = + new Primitive(Symbol.APPEND, "&rest lists") + { + @Override + public LispObject execute() + { + return NIL; + } + @Override + public LispObject execute(LispObject arg) + { + return arg; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first == NIL) + return second; + // APPEND is required to copy its first argument. + Cons result = new Cons(first.car()); + Cons splice = result; + first = first.cdr(); + while (first != NIL) + { + Cons temp = new Cons(first.car()); + splice.cdr = temp; + splice = temp; + first = first.cdr(); + } + splice.cdr = second; + return result; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first == NIL) + return execute(second, third); + Cons result = new Cons(first.car()); + Cons splice = result; + first = first.cdr(); + while (first != NIL) + { + Cons temp = new Cons(first.car()); + splice.cdr = temp; + splice = temp; + first = first.cdr(); + } + while (second != NIL) + { + Cons temp = new Cons(second.car()); + splice.cdr = temp; + splice = temp; + second = second.cdr(); + } + splice.cdr = third; + return result; + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + Cons result = null; + Cons splice = null; + final int limit = args.length - 1; + int i; + for (i = 0; i < limit; i++) + { + LispObject top = args[i]; + if (top == NIL) + continue; + result = new Cons(top.car()); + splice = result; + top = top.cdr(); + while (top != NIL) + { + Cons temp = new Cons(top.car()); + splice.cdr = temp; + splice = temp; + top = top.cdr(); + } + break; + } + if (result == null) + return args[i]; + for (++i; i < limit; i++) + { + LispObject top = args[i]; + while (top != NIL) + { + Cons temp = new Cons(top.car()); + splice.cdr = temp; + splice = temp; + top = top.cdr(); + } + } + splice.cdr = args[i]; + return result; + } + }; + + // ### nconc + private static final Primitive NCONC = + new Primitive(Symbol.NCONC, "&rest lists") + { + @Override + public LispObject execute() + { + return NIL; + } + @Override + public LispObject execute(LispObject arg) + { + return arg; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first == NIL) + return second; + if (first instanceof Cons) + { + LispObject result = first; + Cons splice = null; + while (first instanceof Cons) + { + splice = (Cons) first; + first = splice.cdr; + } + splice.cdr = second; + return result; + } + return type_error(first, Symbol.LIST); + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + LispObject result = null; + Cons splice = null; + final int limit = array.length - 1; + int i; + for (i = 0; i < limit; i++) + { + LispObject list = array[i]; + if (list == NIL) + continue; + if (list instanceof Cons) + { + if (splice != null) + { + splice.cdr = list; + splice = (Cons) list; + } + while (list instanceof Cons) + { + if (result == null) + { + result = list; + splice = (Cons) result; + } + else + splice = (Cons) list; + list = splice.cdr; + } + } + else + type_error(list, Symbol.LIST); + } + if (result == null) + return array[i]; + splice.cdr = array[i]; + return result; + } + }; + + // ### = + // Numeric equality. + private static final Primitive EQUALS = + new Primitive(Symbol.EQUALS, "&rest numbers") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) + { + return T; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isEqualTo(second) ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first.isEqualTo(second) && second.isEqualTo(third)) + return T; + else + return NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + final LispObject obj = array[0]; + for (int i = 1; i < length; i++) + { + if (array[i].isNotEqualTo(obj)) + return NIL; + } + return T; + } + }; + + // ### /= + // Returns true if no two numbers are the same; otherwise returns false. + private static final Primitive NOT_EQUALS = + new Primitive(Symbol.NOT_EQUALS, "&rest numbers") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) + { + return T; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isNotEqualTo(second) ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first.isEqualTo(second)) + return NIL; + if (first.isEqualTo(third)) + return NIL; + if (second.isEqualTo(third)) + return NIL; + return T; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + for (int i = 0; i < length; i++) + { + final LispObject obj = array[i]; + for (int j = i+1; j < length; j++) + { + if (array[j].isEqualTo(obj)) + return NIL; + } + } + return T; + } + }; + + // ### < + // Numeric comparison. + private static final Primitive LT = + new Primitive(Symbol.LT, "&rest numbers") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) + { + return T; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isLessThan(second) ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first.isLessThan(second) && second.isLessThan(third)) + return T; + else + return NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + for (int i = 1; i < length; i++) + { + if (array[i].isLessThanOrEqualTo(array[i-1])) + return NIL; + } + return T; + } + }; + + // ### <= + private static final Primitive LE = + new Primitive(Symbol.LE, "&rest numbers") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) + { + return T; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isLessThanOrEqualTo(second) ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first.isLessThanOrEqualTo(second) && second.isLessThanOrEqualTo(third)) + return T; + else + return NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + for (int i = 1; i < length; i++) + { + if (array[i].isLessThan(array[i-1])) + return NIL; + } + return T; + } + }; + + // ### > + private static final Primitive GT = + new Primitive(Symbol.GT, "&rest numbers") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) + { + return T; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isGreaterThan(second) ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first.isGreaterThan(second) && second.isGreaterThan(third)) + return T; + else + return NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + for (int i = 1; i < length; i++) + { + if (array[i].isGreaterThanOrEqualTo(array[i-1])) + return NIL; + } + return T; + } + }; + + // ### >= + private static final Primitive GE = + new Primitive(Symbol.GE, "&rest numbers") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) + { + return T; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.isGreaterThanOrEqualTo(second) ? T : NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first.isGreaterThanOrEqualTo(second) && second.isGreaterThanOrEqualTo(third)) + return T; + else + return NIL; + } + @Override + public LispObject execute(LispObject[] array) throws ConditionThrowable + { + final int length = array.length; + for (int i = 1; i < length; i++) + { + if (array[i].isGreaterThan(array[i-1])) + return NIL; + } + return T; + } + }; + + // ### nth n list => object + private static final Primitive NTH = new Primitive(Symbol.NTH, "n list") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return second.NTH(first); + } + }; + + // ### %set-nth n list new-object => new-object + private static final Primitive _SET_NTH = + new Primitive("%set-nth", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + int index = Fixnum.getValue(first); + if (index < 0) + error(new TypeError("(SETF NTH): invalid index " + index + ".")); + int i = 0; + while (true) + { + if (i == index) + { + second.setCar(third); + return third; + } + second = second.cdr(); + if (second == NIL) + { + return error(new LispError("(SETF NTH): the index " + + index + "is too large.")); + } + ++i; + } + } + }; + + // ### nthcdr + private static final Primitive NTHCDR = + new Primitive(Symbol.NTHCDR, "n list") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final int index; + try + { + index = ((Fixnum)first).value; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.FIXNUM); + } + if (index < 0) + return type_error(first, + list2(Symbol.INTEGER, Fixnum.ZERO)); + for (int i = 0; i < index; i++) + { + second = second.cdr(); + if (second == NIL) + return NIL; + } + return second; + } + }; + + // ### error + private static final Primitive ERROR = + new Primitive(Symbol.ERROR, "datum &rest arguments") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + Error e = new Error(); + + e.printStackTrace(); + + System.out.println("ERROR placeholder called with arguments:"); + for (LispObject a : args) + System.out.println(a.writeToString()); + + //###FIXME: Bail out, but do it nicer... + System.exit(1); + return NIL; + } + }; + + // ### signal + private static final Primitive SIGNAL = + new Primitive(Symbol.SIGNAL, "datum &rest arguments") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1) + throw new ConditionThrowable(new WrongNumberOfArgumentsException(this)); + if (args[0] instanceof Condition) + throw new ConditionThrowable((Condition)args[0]); + throw new ConditionThrowable(new SimpleCondition()); + } + }; + + // ### undefined-function-called + // Redefined in restart.lisp. + private static final Primitive UNDEFINED_FUNCTION_CALLED = + new Primitive(Symbol.UNDEFINED_FUNCTION_CALLED, "name arguments") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return error(new UndefinedFunction(first)); + } + }; + + // ### %format + private static final Primitive _FORMAT = + new Primitive("%format", PACKAGE_SYS, false, + "destination control-string &rest args") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + LispObject destination = first; + // Copy remaining arguments. + LispObject[] _args = new LispObject[2]; + _args[0] = second; + _args[1] = third; + String s = _format(_args); + return outputFormattedString(s, destination); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + LispObject destination = first; + // Copy remaining arguments. + LispObject[] _args = new LispObject[3]; + _args[0] = second; + _args[1] = third; + _args[2] = fourth; + String s = _format(_args); + return outputFormattedString(s, destination); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2) + return error(new WrongNumberOfArgumentsException(this)); + LispObject destination = args[0]; + // Copy remaining arguments. + LispObject[] _args = new LispObject[args.length - 1]; + for (int i = 0; i < _args.length; i++) + _args[i] = args[i+1]; + String s = _format(_args); + return outputFormattedString(s, destination); + } + private final String _format(LispObject[] args) + throws ConditionThrowable + { + LispObject formatControl = args[0]; + LispObject formatArguments = NIL; + for (int i = 1; i < args.length; i++) + formatArguments = new Cons(args[i], formatArguments); + formatArguments = formatArguments.nreverse(); + return format(formatControl, formatArguments); + } + private final LispObject outputFormattedString(String s, + LispObject destination) + throws ConditionThrowable + { + if (destination == T) + { + checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue())._writeString(s); + return NIL; + } + if (destination == NIL) + return new SimpleString(s); + if (destination instanceof TwoWayStream) + { + Stream out = ((TwoWayStream)destination).getOutputStream(); + if (out instanceof Stream) + { + ((Stream)out)._writeString(s); + return NIL; + } + error(new TypeError("The value " + + destination.writeToString() + + " is not a character output stream.")); + } + if (destination instanceof Stream) + { + ((Stream)destination)._writeString(s); + return NIL; + } + return NIL; + } + }; + + private static final Symbol _SIMPLE_FORMAT_FUNCTION_ = + internSpecial("*SIMPLE-FORMAT-FUNCTION*", PACKAGE_SYS, _FORMAT); + + private static void checkRedefinition(LispObject arg) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (_WARN_ON_REDEFINITION_.symbolValue(thread) != NIL) + { + if (arg instanceof Symbol) + { + LispObject oldDefinition = arg.getSymbolFunction(); + if (oldDefinition != null && !(oldDefinition instanceof Autoload)) + { + LispObject oldSource = + Extensions.SOURCE_PATHNAME.execute(arg); + LispObject currentSource = _SOURCE_.symbolValue(thread); + if (currentSource == NIL) + currentSource = Keyword.TOP_LEVEL; + if (oldSource != NIL) + { + if (currentSource.equal(oldSource)) + return; // OK + } + if (currentSource == Keyword.TOP_LEVEL) + { + Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S at top level"), + arg); + + } + else + { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_CL); + try + { + Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S in ~S"), + arg, currentSource); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + } + } + } + } + + // ### %defun name definition => name + private static final Primitive _DEFUN = + new Primitive("%defun", PACKAGE_SYS, true, "name definition") + { + @Override + public LispObject execute(LispObject name, LispObject definition) + throws ConditionThrowable + { + if (name instanceof Symbol) + { + Symbol symbol = (Symbol) name; + if (symbol.getSymbolFunction() instanceof SpecialOperator) + { + String message = + symbol.getName() + " is a special operator and may not be redefined."; + return error(new ProgramError(message)); + } + } + else if (!isValidSetfFunctionName(name)) + return type_error(name, FUNCTION_NAME); + if (definition instanceof Function) + { + Symbol.FSET.execute(name, definition, NIL, + ((Function)definition).getLambdaList()); + return name; + } + return type_error(definition, Symbol.FUNCTION); + } + }; + + // ### fdefinition-block-name + private static final Primitive FDEFINITION_BLOCK_NAME = + new Primitive("fdefinition-block-name", PACKAGE_SYS, true, "function-name") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Symbol) + return arg; + if (isValidSetfFunctionName(arg)) + return arg.cadr(); + return type_error(arg, FUNCTION_NAME); + } + }; + + // ### macro-function + private static final Primitive MACRO_FUNCTION = + new Primitive(Symbol.MACRO_FUNCTION, "symbol &optional environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispObject obj = arg.getSymbolFunction(); + if (obj instanceof AutoloadMacro) + { + ((AutoloadMacro)obj).load(); + obj = arg.getSymbolFunction(); + } + if (obj instanceof MacroObject) + return ((MacroObject)obj).expander; + if (obj instanceof SpecialOperator) + { + obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL); + if (obj instanceof AutoloadMacro) + { + ((AutoloadMacro)obj).load(); + obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL); + } + if (obj instanceof MacroObject) + return ((MacroObject)obj).expander; + } + return NIL; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + LispObject obj; + if (second != NIL) + { + Environment env = checkEnvironment(second); + obj = env.lookupFunction(first); + } + else + obj = first.getSymbolFunction(); + if (obj instanceof AutoloadMacro) + { + ((AutoloadMacro)obj).load(); + obj = first.getSymbolFunction(); + } + if (obj instanceof MacroObject) + return ((MacroObject)obj).expander; + if (obj instanceof SpecialOperator) + { + obj = get(first, Symbol.MACROEXPAND_MACRO, NIL); + if (obj instanceof AutoloadMacro) + { + ((AutoloadMacro)obj).load(); + obj = get(first, Symbol.MACROEXPAND_MACRO, NIL); + } + if (obj instanceof MacroObject) + return ((MacroObject)obj).expander; + } + return NIL; + } + }; + + // ### defmacro + private static final SpecialOperator DEFMACRO = + new SpecialOperator(Symbol.DEFMACRO) + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + Symbol symbol = checkSymbol(args.car()); + LispObject lambdaList = checkList(args.cadr()); + LispObject body = args.cddr(); + LispObject block = new Cons(Symbol.BLOCK, new Cons(symbol, body)); + LispObject toBeApplied = + list2(Symbol.FUNCTION, list3(Symbol.LAMBDA, lambdaList, block)); + final LispThread thread = LispThread.currentThread(); + LispObject formArg = gensym("FORM-", thread); + LispObject envArg = gensym("ENV-", thread); // Ignored. + LispObject expander = + list3(Symbol.LAMBDA, list2(formArg, envArg), + list3(Symbol.APPLY, toBeApplied, + list2(Symbol.CDR, formArg))); + Closure expansionFunction = new Closure(expander, env); + MacroObject macroObject = + new MacroObject(symbol, expansionFunction); + if (symbol.getSymbolFunction() instanceof SpecialOperator) + put(symbol, Symbol.MACROEXPAND_MACRO, macroObject); + else + symbol.setSymbolFunction(macroObject); + macroObject.setLambdaList(lambdaList); + thread._values = null; + return symbol; + } + }; + + // ### make-macro + private static final Primitive MAKE_MACRO = + new Primitive("make-macro", PACKAGE_SYS, true, "name expansion-function") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return new MacroObject(first, second); + } + }; + + // ### make-symbol-macro + private static final Primitive MAKE_SYMBOL_MACRO = + new Primitive("make-symbol-macro", PACKAGE_SYS, true, "expansion") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new SymbolMacro(arg); + } + }; + + + // ### %defparameter + private static final Primitive _DEFPARAMETER = + new Primitive("%defparameter", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final Symbol symbol; + try + { + symbol = (Symbol) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + if (third instanceof AbstractString) + symbol.setDocumentation(Symbol.VARIABLE, third); + else if (third != NIL) + type_error(third, Symbol.STRING); + symbol.initializeSpecial(second); + return symbol; + } + }; + + // ### %defvar + private static final Primitive _DEFVAR = + new Primitive("%defvar", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final Symbol symbol; + try + { + symbol = (Symbol) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + symbol.setSpecial(true); + return symbol; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Symbol symbol; + try + { + symbol = (Symbol) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + symbol.initializeSpecial(second); + return symbol; + } + }; + + // ### %defconstant name initial-value documentation => name + private static final Primitive _DEFCONSTANT = + new Primitive("%defconstant", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final Symbol symbol; + try + { + symbol = (Symbol) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + if (third != NIL) + { + if (third instanceof AbstractString) + symbol.setDocumentation(Symbol.VARIABLE, third); + else + return type_error(third, Symbol.STRING); + } + symbol.initializeConstant(second); + return symbol; + } + }; + + // ### cond + private static final SpecialOperator COND = + new SpecialOperator(Symbol.COND, "&rest clauses") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = NIL; + while (args != NIL) + { + LispObject clause = args.car(); + result = eval(clause.car(), env, thread); + thread._values = null; + if (result != NIL) + { + LispObject body = clause.cdr(); + while (body != NIL) + { + result = eval(body.car(), env, thread); + body = ((Cons)body).cdr; + } + return result; + } + args = ((Cons)args).cdr; + } + return result; + } + }; + + // ### case + private static final SpecialOperator CASE = + new SpecialOperator(Symbol.CASE, "keyform &body cases") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject key = eval(args.car(), env, thread); + args = args.cdr(); + while (args != NIL) + { + LispObject clause = args.car(); + LispObject keys = clause.car(); + boolean match = false; + if (keys.listp()) + { + while (keys != NIL) + { + LispObject candidate = keys.car(); + if (key.eql(candidate)) + { + match = true; + break; + } + keys = keys.cdr(); + } + } + else + { + LispObject candidate = keys; + if (candidate == T || candidate == Symbol.OTHERWISE) + match = true; + else if (key.eql(candidate)) + match = true; + } + if (match) + { + return progn(clause.cdr(), env, thread); + } + args = args.cdr(); + } + return NIL; + } + }; + + // ### ecase + private static final SpecialOperator ECASE = + new SpecialOperator(Symbol.ECASE, "keyform &body cases") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject key = eval(args.car(), env, thread); + LispObject clauses = args.cdr(); + while (clauses != NIL) + { + LispObject clause = clauses.car(); + LispObject keys = clause.car(); + boolean match = false; + if (keys.listp()) + { + while (keys != NIL) + { + LispObject candidate = keys.car(); + if (key.eql(candidate)) + { + match = true; + break; + } + keys = keys.cdr(); + } + } + else + { + LispObject candidate = keys; + if (key.eql(candidate)) + match = true; + } + if (match) + { + return progn(clause.cdr(), env, thread); + } + clauses = clauses.cdr(); + } + LispObject expectedType = NIL; + clauses = args.cdr(); + while (clauses != NIL) + { + LispObject clause = clauses.car(); + LispObject keys = clause.car(); + if (keys.listp()) + { + while (keys != NIL) + { + expectedType = expectedType.push(keys.car()); + keys = keys.cdr(); + } + } + else + expectedType = expectedType.push(keys); + clauses = clauses.cdr(); + } + expectedType = expectedType.nreverse(); + expectedType = expectedType.push(Symbol.MEMBER); + return type_error(key, expectedType); + } + }; + + // ### upgraded-array-element-type typespec &optional environment + // => upgraded-typespec + private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE = + new Primitive(Symbol.UPGRADED_ARRAY_ELEMENT_TYPE, + "typespec &optional environment") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return getUpgradedArrayElementType(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + // Ignore environment. + return getUpgradedArrayElementType(first); + } + }; + + // ### array-rank array => rank + private static final Primitive ARRAY_RANK = + new Primitive(Symbol.ARRAY_RANK, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new Fixnum(((AbstractArray)arg).getRank()); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + // ### array-dimensions array => dimensions + // Returns a list of integers. Fill pointer (if any) is ignored. + private static final Primitive ARRAY_DIMENSIONS = + new Primitive(Symbol.ARRAY_DIMENSIONS, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((AbstractArray)arg).getDimensions(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + // ### array-dimension array axis-number => dimension + private static final Primitive ARRAY_DIMENSION = + new Primitive(Symbol.ARRAY_DIMENSION, "array axis-number") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final AbstractArray array; + try + { + array = (AbstractArray) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.ARRAY); + } + final int n; + try + { + n = ((Fixnum)second).value; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.FIXNUM); + } + return new Fixnum(array.getDimension(n)); + } + }; + + // ### array-total-size array => size + private static final Primitive ARRAY_TOTAL_SIZE = + new Primitive(Symbol.ARRAY_TOTAL_SIZE, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new Fixnum(((AbstractArray)arg).getTotalSize()); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + + // ### array-element-type + // array-element-type array => typespec + private static final Primitive ARRAY_ELEMENT_TYPE = + new Primitive(Symbol.ARRAY_ELEMENT_TYPE, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((AbstractArray)arg).getElementType(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + // ### adjustable-array-p + private static final Primitive ADJUSTABLE_ARRAY_P = + new Primitive(Symbol.ADJUSTABLE_ARRAY_P, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((AbstractArray)arg).isAdjustable() ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + // ### array-displacement array => displaced-to, displaced-index-offset + private static final Primitive ARRAY_DISPLACEMENT = + new Primitive(Symbol.ARRAY_DISPLACEMENT, "array") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((AbstractArray)arg).arrayDisplacement(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + } + }; + + // ### array-in-bounds-p array &rest subscripts => generalized-boolean + private static final Primitive ARRAY_IN_BOUNDS_P = + new Primitive(Symbol.ARRAY_IN_BOUNDS_P, "array &rest subscripts") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1) + return error(new WrongNumberOfArgumentsException(this)); + final AbstractArray array; + try + { + array = (AbstractArray) args[0]; + } + catch (ClassCastException e) + { + return type_error(args[0], Symbol.ARRAY); + } + int rank = array.getRank(); + if (rank != args.length - 1) + { + FastStringBuffer sb = + new FastStringBuffer("ARRAY-IN-BOUNDS-P: "); + sb.append("wrong number of subscripts ("); + sb.append(args.length - 1); + sb.append(") for array of rank "); + sb.append(rank); + error(new ProgramError(sb.toString())); + } + for (int i = 0; i < rank; i++) + { + LispObject arg = args[i+1]; + if (arg instanceof Fixnum) + { + int subscript = ((Fixnum)arg).value; + if (subscript < 0 || subscript >= array.getDimension(i)) + return NIL; + } + else if (arg instanceof Bignum) + return NIL; + else + type_error(arg, Symbol.INTEGER); + } + return T; + } + }; + + // ### %array-row-major-index array subscripts => index + private static final Primitive _ARRAY_ROW_MAJOR_INDEX = + new Primitive("%array-row-major-index", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final AbstractArray array; + try + { + array = (AbstractArray) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.ARRAY); + } + LispObject[] subscripts = second.copyToArray(); + return number(array.getRowMajorIndex(subscripts)); + } + }; + + // ### aref array &rest subscripts => element + private static final Primitive AREF = + new Primitive(Symbol.AREF, "array &rest subscripts") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final AbstractArray array; + try + { + array = (AbstractArray) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.ARRAY); + } + if (array.getRank() == 0) + return array.AREF(0); + FastStringBuffer sb = + new FastStringBuffer("Wrong number of subscripts (0) for array of rank "); + sb.append(array.getRank()); + sb.append('.'); + return error(new ProgramError(sb.toString())); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.AREF(second); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final AbstractArray array; + try + { + array = (AbstractArray) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.ARRAY); + } + final int[] subs = new int[2]; + try + { + subs[0] = ((Fixnum)second).value; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.FIXNUM); + } + try + { + subs[1] = ((Fixnum)third).value; + } + catch (ClassCastException e) + { + return type_error(third, Symbol.FIXNUM); + } + return array.get(subs); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final AbstractArray array; + try + { + array = (AbstractArray) args[0]; + } + catch (ClassCastException e) + { + return type_error(args[0], Symbol.ARRAY); + } + final int[] subs = new int[args.length - 1]; + for (int i = subs.length; i-- > 0;) + { + try + { + subs[i] = ((Fixnum)args[i+1]).value; + } + catch (ClassCastException e) + { + return type_error(args[i+i], Symbol.FIXNUM); + } + } + return array.get(subs); + } + }; + + // ### aset array subscripts new-element => new-element + private static final Primitive ASET = + new Primitive("aset", PACKAGE_SYS, true, + "array subscripts new-element") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + // Rank zero array. + final ZeroRankArray array; + try + { + array = (ZeroRankArray) first; + } + catch (ClassCastException e) + { + return error(new TypeError("The value " + + first.writeToString() + + " is not an array of rank 0.")); + } + array.aset(0, second); + return second; + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + first.aset(second, third); + return third; + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final AbstractArray array; + try + { + array = (AbstractArray) args[0]; + } + catch (ClassCastException e) + { + return type_error(args[0], Symbol.ARRAY); + } + final int nsubs = args.length - 2; + final int[] subs = new int[nsubs]; + for (int i = nsubs; i-- > 0;) + { + try + { + subs[i] = ((Fixnum)args[i+1]).value; + } + catch (ClassCastException e) + { + type_error(args[i+1], Symbol.FIXNUM); + } + } + final LispObject newValue = args[args.length - 1]; + array.set(subs, newValue); + return newValue; + } + }; + + // ### row-major-aref array index => element + private static final Primitive ROW_MAJOR_AREF = + new Primitive(Symbol.ROW_MAJOR_AREF, "array index") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return ((AbstractArray)first).AREF(((Fixnum)second).value); + } + catch (ClassCastException e) + { + if (first instanceof AbstractArray) + return type_error(second, Symbol.FIXNUM); + else + return type_error(first, Symbol.ARRAY); + } + } + }; + + // ### vector + private static final Primitive VECTOR = + new Primitive(Symbol.VECTOR, "&rest objects") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return new SimpleVector(args); + } + }; + + // ### fill-pointer + private static final Primitive FILL_POINTER = + new Primitive(Symbol.FILL_POINTER, "vector") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + try + { + return new Fixnum(((AbstractArray)arg).getFillPointer()); + } + catch (ClassCastException e) + { + return type_error(arg, list3(Symbol.AND, Symbol.VECTOR, + list2(Symbol.SATISFIES, + Symbol.ARRAY_HAS_FILL_POINTER_P))); + } + } + }; + + // ### %set-fill-pointer vector new-fill-pointer + private static final Primitive _SET_FILL_POINTER = + new Primitive("%set-fill-pointer", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + AbstractVector v = (AbstractVector) first; + if (v.hasFillPointer()) + v.setFillPointer(second); + else + v.noFillPointer(); + return second; + } + catch (ClassCastException e) + { + return type_error(first, list3(Symbol.AND, Symbol.VECTOR, + list2(Symbol.SATISFIES, + Symbol.ARRAY_HAS_FILL_POINTER_P))); + } + } + }; + + // ### vector-push new-element vector => index-of-new-element + private static final Primitive VECTOR_PUSH = + new Primitive(Symbol.VECTOR_PUSH, "new-element vector") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final AbstractVector v; + try + { + v = (AbstractVector) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.VECTOR); + } + int fillPointer = v.getFillPointer(); + if (fillPointer < 0) + v.noFillPointer(); + if (fillPointer >= v.capacity()) + return NIL; + v.aset(fillPointer, first); + v.setFillPointer(fillPointer + 1); + return new Fixnum(fillPointer); + } + }; + + // ### vector-push-extend new-element vector &optional extension + // => index-of-new-element + private static final Primitive VECTOR_PUSH_EXTEND = + new Primitive(Symbol.VECTOR_PUSH_EXTEND, + "new-element vector &optional extension") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return second.VECTOR_PUSH_EXTEND(first); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return second.VECTOR_PUSH_EXTEND(first, third); + } + }; + + // ### vector-pop vector => element + private static final Primitive VECTOR_POP = + new Primitive(Symbol.VECTOR_POP, "vector") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final AbstractVector v; + try + { + v = (AbstractVector) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.VECTOR); + } + int fillPointer = v.getFillPointer(); + if (fillPointer < 0) + v.noFillPointer(); + if (fillPointer == 0) + error(new LispError("nothing left to pop")); + int newFillPointer = v.checkIndex(fillPointer - 1); + LispObject element = v.AREF(newFillPointer); + v.setFillPointer(newFillPointer); + return element; + } + }; + + // ### type-of + private static final Primitive TYPE_OF = + new Primitive(Symbol.TYPE_OF, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.typeOf(); + } + }; + + // ### class-of + private static final Primitive CLASS_OF = + new Primitive(Symbol.CLASS_OF, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.classOf(); + } + }; + + // ### simple-typep + private static final Primitive SIMPLE_TYPEP = + new Primitive("simple-typep", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.typep(second); + } + }; + + // ### function-lambda-expression function => + // lambda-expression, closure-p, name + private static final Primitive FUNCTION_LAMBDA_EXPRESSION = + new Primitive(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispObject value1, value2, value3; + if (arg instanceof CompiledClosure) + { + value1 = NIL; + value2 = T; + LispObject name = ((CompiledClosure)arg).getLambdaName(); + value3 = name != null ? name : NIL; + } + else if (arg instanceof Closure && !(arg instanceof CompiledFunction)) + { + Closure closure = (Closure) arg; + LispObject expr = closure.getBody(); + expr = new Cons(closure.getLambdaList(), expr); + expr = new Cons(Symbol.LAMBDA, expr); + value1 = expr; + Environment env = closure.getEnvironment(); + if (env == null || env.isEmpty()) + value2 = NIL; + else + value2 = env; // Return environment as closure-p. + LispObject name = ((Closure)arg).getLambdaName(); + value3 = name != null ? name : NIL; + } + else if (arg instanceof Function) + { + value1 = NIL; + value2 = T; + value3 = ((Function)arg).getLambdaName(); + } + else if (arg instanceof StandardGenericFunction) + { + value1 = NIL; + value2 = T; + value3 = ((StandardGenericFunction)arg).getGenericFunctionName(); + } + else + return type_error(arg, Symbol.FUNCTION); + return LispThread.currentThread().setValues(value1, value2, value3); + } + }; + + // ### funcall + // This needs to be public for LispAPI.java. + public static final Primitive FUNCALL = + new Primitive(Symbol.FUNCALL, "function &rest args") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return LispThread.currentThread().execute(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second, third, + fourth); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second, third, + fourth, fifth); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second, third, + fourth, fifth, sixth); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second, third, + fourth, fifth, sixth, + seventh); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eigth) + throws ConditionThrowable + { + return LispThread.currentThread().execute(first, second, third, + fourth, fifth, sixth, + seventh, eigth); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + final int length = args.length - 1; // Number of arguments. + if (length == 8) + { + return LispThread.currentThread().execute(args[0], args[1], + args[2], args[3], + args[4], args[5], + args[6], args[7], + args[8]); + } + else + { + LispObject[] newArgs = new LispObject[length]; + System.arraycopy(args, 1, newArgs, 0, length); + return LispThread.currentThread().execute(args[0], newArgs); + } + } + }; + + // ### apply + public static final Primitive APPLY = + new Primitive(Symbol.APPLY, "function &rest args") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject fun, LispObject args) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final int length = args.length(); + switch (length) + { + case 0: + return thread.execute(fun); + case 1: + return thread.execute(fun, ((Cons)args).car); + case 2: + { + Cons cons = (Cons) args; + return thread.execute(fun, cons.car, ((Cons)cons.cdr).car); + } + case 3: + return thread.execute(fun, args.car(), args.cadr(), + args.cdr().cdr().car()); + default: + { + final LispObject[] funArgs = new LispObject[length]; + int j = 0; + while (args != NIL) + { + funArgs[j++] = args.car(); + args = args.cdr(); + } + return funcall(fun, funArgs, thread); + } + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (third.listp()) + { + final int numFunArgs = 1 + third.length(); + final LispObject[] funArgs = new LispObject[numFunArgs]; + funArgs[0] = second; + int j = 1; + while (third != NIL) + { + funArgs[j++] = third.car(); + third = third.cdr(); + } + return funcall(first, funArgs, LispThread.currentThread()); + } + return type_error(third, Symbol.LIST); + } + @Override + public LispObject execute(final LispObject[] args) throws ConditionThrowable + { + final int numArgs = args.length; + LispObject spread = args[numArgs - 1]; + if (spread.listp()) + { + final int numFunArgs = numArgs - 2 + spread.length(); + final LispObject[] funArgs = new LispObject[numFunArgs]; + int j = 0; + for (int i = 1; i < numArgs - 1; i++) + funArgs[j++] = args[i]; + while (spread != NIL) + { + funArgs[j++] = spread.car(); + spread = spread.cdr(); + } + return funcall(args[0], funArgs, LispThread.currentThread()); + } + return type_error(spread, Symbol.LIST); + } + }; + + // ### mapcar + private static final Primitive MAPCAR = + new Primitive(Symbol.MAPCAR, "function &rest lists") + { + @Override + public LispObject execute(LispObject fun, LispObject list) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = NIL; + Cons splice = null; + while (list != NIL) + { + Cons cons; + try + { + cons = (Cons) list; + } + catch (ClassCastException e) + { + return type_error(list, Symbol.LIST); + } + LispObject obj = thread.execute(fun, cons.car); + if (splice == null) + { + splice = new Cons(obj, result); + result = splice; + } + else + { + Cons c = new Cons(obj); + splice.cdr = c; + splice = c; + } + list = cons.cdr; + } + thread._values = null; + return result; + } + @Override + public LispObject execute(LispObject fun, LispObject list1, + LispObject list2) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = NIL; + Cons splice = null; + while (list1 != NIL && list2 != NIL) + { + LispObject obj = + thread.execute(fun, list1.car(), list2.car()); + if (splice == null) + { + splice = new Cons(obj, result); + result = splice; + } + else + { + Cons cons = new Cons(obj); + splice.cdr = cons; + splice = cons; + } + list1 = list1.cdr(); + list2 = list2.cdr(); + } + thread._values = null; + return result; + } + @Override + public LispObject execute(final LispObject[] args) + throws ConditionThrowable + { + final int numArgs = args.length; + if (numArgs < 2) + return error(new WrongNumberOfArgumentsException(this)); + int commonLength = -1; + for (int i = 1; i < numArgs; i++) + { + if (!args[i].listp()) + type_error(args[i], Symbol.LIST); + int len = args[i].length(); + if (commonLength < 0) + commonLength = len; + else if (commonLength > len) + commonLength = len; + } + final LispThread thread = LispThread.currentThread(); + LispObject[] results = new LispObject[commonLength]; + final int numFunArgs = numArgs - 1; + final LispObject[] funArgs = new LispObject[numFunArgs]; + for (int i = 0; i < commonLength; i++) + { + for (int j = 0; j < numFunArgs; j++) + funArgs[j] = args[j+1].car(); + results[i] = funcall(args[0], funArgs, thread); + for (int j = 1; j < numArgs; j++) + args[j] = args[j].cdr(); + } + thread._values = null; + LispObject result = NIL; + for (int i = commonLength; i-- > 0;) + result = new Cons(results[i], result); + return result; + } + }; + + // ### mapc + private static final Primitive MAPC = + new Primitive(Symbol.MAPC, "function &rest lists") + { + @Override + public LispObject execute(LispObject fun, LispObject list) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = list; + while (list != NIL) + { + Cons cons; + try + { + cons = (Cons) list; + } + catch (ClassCastException e) + { + return type_error(list, Symbol.LIST); + } + thread.execute(fun, cons.car); + list = cons.cdr; + } + thread._values = null; + return result; + } + @Override + public LispObject execute(LispObject fun, LispObject list1, + LispObject list2) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = list1; + while (list1 != NIL && list2 != NIL) + { + thread.execute(fun, list1.car(), list2.car()); + list1 = ((Cons)list1).cdr; + list2 = ((Cons)list2).cdr; + } + thread._values = null; + return result; + } + @Override + public LispObject execute(final LispObject[] args) + throws ConditionThrowable + { + final int numArgs = args.length; + if (numArgs < 2) + return error(new WrongNumberOfArgumentsException(this)); + int commonLength = -1; + for (int i = 1; i < numArgs; i++) + { + if (!args[i].listp()) + type_error(args[i], Symbol.LIST); + int len = args[i].length(); + if (commonLength < 0) + commonLength = len; + else if (commonLength > len) + commonLength = len; + } + final LispThread thread = LispThread.currentThread(); + LispObject result = args[1]; + final int numFunArgs = numArgs - 1; + final LispObject[] funArgs = new LispObject[numFunArgs]; + for (int i = 0; i < commonLength; i++) + { + for (int j = 0; j < numFunArgs; j++) + funArgs[j] = args[j+1].car(); + funcall(args[0], funArgs, thread); + for (int j = 1; j < numArgs; j++) + args[j] = args[j].cdr(); + } + thread._values = null; + return result; + } + }; + + // ### macroexpand + private static final Primitive MACROEXPAND = + new Primitive(Symbol.MACROEXPAND, "form &optional env") + { + @Override + public LispObject execute(LispObject form) throws ConditionThrowable + { + return macroexpand(form, + new Environment(), + LispThread.currentThread()); + } + @Override + public LispObject execute(LispObject form, LispObject env) + throws ConditionThrowable + { + return macroexpand(form, + env != NIL ? checkEnvironment(env) : new Environment(), + LispThread.currentThread()); + } + }; + + // ### macroexpand-1 + private static final Primitive MACROEXPAND_1 = + new Primitive(Symbol.MACROEXPAND_1, "form &optional env") + { + @Override + public LispObject execute(LispObject form) throws ConditionThrowable + { + return macroexpand_1(form, + new Environment(), + LispThread.currentThread()); + } + @Override + public LispObject execute(LispObject form, LispObject env) + throws ConditionThrowable + { + return macroexpand_1(form, + env != NIL ? checkEnvironment(env) : new Environment(), + LispThread.currentThread()); + } + }; + + // ### gensym + private static final Primitive GENSYM = + new Primitive(Symbol.GENSYM, "&optional x") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return gensym("G", LispThread.currentThread()); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum) + { + int n = ((Fixnum)arg).value; + if (n >= 0) + { + FastStringBuffer sb = new FastStringBuffer('G'); + sb.append(n); // Decimal representation. + return new Symbol(new SimpleString(sb)); + } + } + else if (arg instanceof Bignum) + { + BigInteger n = ((Bignum)arg).value; + if (n.signum() >= 0) + { + FastStringBuffer sb = new FastStringBuffer('G'); + sb.append(n.toString()); // Decimal representation. + return new Symbol(new SimpleString(sb)); + } + } + else if (arg instanceof AbstractString) + return gensym(arg.getStringValue(), LispThread.currentThread()); + return type_error(arg, + list3(Symbol.OR, + Symbol.STRING, + Symbol.UNSIGNED_BYTE)); + } + }; + + // ### string + private static final Primitive STRING = new Primitive(Symbol.STRING, "x") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.STRING(); + } + }; + + // ### intern string &optional package => symbol, status + // STATUS is one of :INHERITED, :EXTERNAL, :INTERNAL or NIL. + // "It is implementation-dependent whether the string that becomes the new + // symbol's name is the given string or a copy of it." + private static final Primitive INTERN = + new Primitive(Symbol.INTERN, "string &optional package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final SimpleString s; + if (arg instanceof SimpleString) + s = (SimpleString) arg; + else + s = new SimpleString(arg.getStringValue()); + final LispThread thread = LispThread.currentThread(); + Package pkg = (Package) Symbol._PACKAGE_.symbolValue(thread); + return pkg.intern(s, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final SimpleString s; + if (first instanceof SimpleString) + s = (SimpleString) first; + else + s = new SimpleString(first.getStringValue()); + Package pkg = coerceToPackage(second); + return pkg.intern(s, LispThread.currentThread()); + } + }; + + // ### unintern + // unintern symbol &optional package => generalized-boolean + private static final Primitive UNINTERN = + new Primitive(Symbol.UNINTERN, "symbol &optional package") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length == 0 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + Symbol symbol = checkSymbol(args[0]); + Package pkg; + if (args.length == 2) + pkg = coerceToPackage(args[1]); + else + pkg = getCurrentPackage(); + return pkg.unintern(symbol); + } + }; + + // ### find-package + private static final Primitive FIND_PACKAGE = + new Primitive(Symbol.FIND_PACKAGE, "name") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Package) + return arg; + if (arg instanceof AbstractString) + { + Package pkg = + Packages.findPackage(arg.getStringValue()); + return pkg != null ? pkg : NIL; + } + if (arg instanceof Symbol) + { + Package pkg = Packages.findPackage(((Symbol)arg).getName()); + return pkg != null ? pkg : NIL; + } + if (arg instanceof LispCharacter) + { + String packageName = + String.valueOf(new char[] {((LispCharacter)arg).getValue()}); + Package pkg = Packages.findPackage(packageName); + return pkg != null ? pkg : NIL; + } + return NIL; + } + }; + + // ### %make-package + // %make-package package-name nicknames use => package + private static final Primitive _MAKE_PACKAGE = + new Primitive("%make-package", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + String packageName = javaString(first); + Package pkg = Packages.findPackage(packageName); + if (pkg != null) + error(new LispError("Package " + packageName + + " already exists.")); + LispObject nicknames = checkList(second); + if (nicknames != NIL) + { + LispObject list = nicknames; + while (list != NIL) + { + String nick = javaString(list.car()); + if (Packages.findPackage(nick) != null) + { + error(new PackageError("A package named " + nick + + " already exists.")); + } + list = list.cdr(); + } + } + LispObject use = checkList(third); + if (use != NIL) + { + LispObject list = use; + while (list != NIL) + { + LispObject obj = list.car(); + if (obj instanceof Package) { + // OK. + } else + { + String s = javaString(obj); + Package p = Packages.findPackage(s); + if (p == null) + { + error(new LispError(obj.writeToString() + + " is not the name of a package.")); + return NIL; + } + } + list = list.cdr(); + } + } + // Now create the package. + pkg = Packages.createPackage(packageName); + // Add the nicknames. + while (nicknames != NIL) + { + String nick = javaString(nicknames.car()); + pkg.addNickname(nick); + nicknames = nicknames.cdr(); + } + // Create the use list. + while (use != NIL) + { + LispObject obj = use.car(); + if (obj instanceof Package) + pkg.usePackage((Package)obj); + else + { + String s = javaString(obj); + Package p = Packages.findPackage(s); + if (p == null) + { + error(new LispError(obj.writeToString() + + " is not the name of a package.")); + return NIL; + } + pkg.usePackage(p); + } + use = use.cdr(); + } + return pkg; + } + }; + + // ### %in-package + private static final Primitive _IN_PACKAGE = + new Primitive("%in-package", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final String packageName = javaString(arg); + final Package pkg = Packages.findPackage(packageName); + if (pkg == null) + return error(new PackageError("The name " + packageName + + " does not designate any package.")); + SpecialBinding binding = + LispThread.currentThread().getSpecialBinding(Symbol._PACKAGE_); + if (binding != null) + binding.value = pkg; + else + // No dynamic binding. + Symbol._PACKAGE_.setSymbolValue(pkg); + return pkg; + } + }; + + // ### use-package packages-to-use &optional package => t + private static final Primitive USE_PACKAGE = + new Primitive(Symbol.USE_PACKAGE, "packages-to-use &optional package") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1 || args.length > 2) + return error(new WrongNumberOfArgumentsException(this)); + Package pkg; + if (args.length == 2) + pkg = coerceToPackage(args[1]); + else + pkg = getCurrentPackage(); + if (args[0].listp()) + { + LispObject list = args[0]; + while (list != NIL) + { + pkg.usePackage(coerceToPackage(list.car())); + list = list.cdr(); + } + } + else + pkg.usePackage(coerceToPackage(args[0])); + return T; + } + }; + + // ### package-symbols + private static final Primitive PACKAGE_SYMBOLS = + new Primitive("package-symbols", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).getSymbols(); + } + }; + + // ### package-internal-symbols + private static final Primitive PACKAGE_INTERNAL_SYMBOLS = + new Primitive("package-internal-symbols", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS(); + } + }; + + // ### package-external-symbols + private static final Primitive PACKAGE_EXTERNAL_SYMBOLS = + new Primitive("package-external-symbols", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS(); + } + }; + + // ### package-inherited-symbols + private static final Primitive PACKAGE_INHERITED_SYMBOLS = + new Primitive("package-inherited-symbols", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS(); + } + }; + + // ### export symbols &optional package + private static final Primitive EXPORT = + new Primitive(Symbol.EXPORT, "symbols &optional package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final Package pkg = (Package) Symbol._PACKAGE_.symbolValue(); + if (arg instanceof Cons) + { + for (LispObject list = arg; list != NIL; list = list.cdr()) + pkg.export(checkSymbol(list.car())); + } + else + pkg.export(checkSymbol(arg)); + return T; + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Cons) + { + Package pkg = coerceToPackage(second); + for (LispObject list = first; list != NIL; list = list.cdr()) + pkg.export(checkSymbol(list.car())); + } + else + coerceToPackage(second).export(checkSymbol(first)); + return T; + } + }; + + // ### find-symbol string &optional package => symbol, status + private static final Primitive FIND_SYMBOL = + new Primitive(Symbol.FIND_SYMBOL, "string &optional package") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return getCurrentPackage().findSymbol(arg.getStringValue()); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return coerceToPackage(second).findSymbol(first.getStringValue()); + } + }; + + // ### fset name function &optional source-position arglist documentation + // => function + private static final Primitive FSET = + new Primitive("fset", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return execute(first, second, NIL, NIL, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return execute(first, second, third, NIL, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return execute(first, second, third, fourth, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + if (first instanceof Symbol) + { + checkRedefinition(first); + Symbol symbol = (Symbol) first; + symbol.setSymbolFunction(second); + final LispThread thread = LispThread.currentThread(); + LispObject sourcePathname = _SOURCE_.symbolValue(thread); + LispObject sourcePosition = third; + if (sourcePathname != NIL) + sourcePosition = _SOURCE_POSITION_.symbolValue(thread); + if (sourcePathname == NIL) + sourcePathname = Keyword.TOP_LEVEL; + if (sourcePathname != Keyword.TOP_LEVEL) + put(symbol, Symbol._SOURCE, new Cons(sourcePathname, third)); + else + put(symbol, Symbol._SOURCE, sourcePathname); + } + else if (isValidSetfFunctionName(first)) + { + // SETF function + checkRedefinition(first); + Symbol symbol = checkSymbol(first.cadr()); + put(symbol, Symbol.SETF_FUNCTION, second); + } + else + return type_error(first, FUNCTION_NAME); + if (second instanceof Operator) + { + Operator op = (Operator) second; + op.setLambdaName(first); + if (fourth != NIL) + op.setLambdaList(fourth); + if (fifth != NIL) + op.setDocumentation(Symbol.FUNCTION, fifth); + } + return second; + } + }; + + // ### %set-symbol-plist + private static final Primitive _SET_SYMBOL_PLIST = + new Primitive("%set-symbol-plist", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkSymbol(first).setPropertyList(checkList(second)); + return second; + } + }; + + // ### getf plist indicator &optional default => value + private static final Primitive GETF = + new Primitive(Symbol.GETF, "plist indicator &optional default") + { + @Override + public LispObject execute(LispObject plist, LispObject indicator) + throws ConditionThrowable + { + return getf(plist, indicator, NIL); + } + @Override + public LispObject execute(LispObject plist, LispObject indicator, + LispObject defaultValue) + throws ConditionThrowable + { + return getf(plist, indicator, defaultValue); + } + }; + + // ### get symbol indicator &optional default => value + private static final Primitive GET = + new Primitive(Symbol.GET, "symbol indicator &optional default") + { + @Override + public LispObject execute(LispObject symbol, LispObject indicator) + throws ConditionThrowable + { + return get(symbol, indicator, NIL); + } + @Override + public LispObject execute(LispObject symbol, LispObject indicator, + LispObject defaultValue) + throws ConditionThrowable + { + return get(symbol, indicator, defaultValue); + } + }; + + // ### put symbol indicator value => value + private static final Primitive PUT = + new Primitive("put", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject symbol, LispObject indicator, + LispObject value) + throws ConditionThrowable + { + try + { + return put((Symbol)symbol, indicator, value); + } + catch (ClassCastException e) + { + return type_error(symbol, Symbol.SYMBOL); + } + } + @Override + public LispObject execute(LispObject symbol, LispObject indicator, + LispObject defaultValue, LispObject value) + throws ConditionThrowable + { + try + { + return put((Symbol)symbol, indicator, value); + } + catch (ClassCastException e) + { + return type_error(symbol, Symbol.SYMBOL); + } + } + }; + + // ### macrolet + private static final SpecialOperator MACROLET = + new SpecialOperator(Symbol.MACROLET, "definitions &rest body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject defs = checkList(args.car()); + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + + try + { + Environment ext = new Environment(env); + while (defs != NIL) + { + LispObject def = checkList(defs.car()); + Symbol symbol = checkSymbol(def.car()); + Symbol make_expander_for_macrolet = + PACKAGE_SYS.intern("MAKE-EXPANDER-FOR-MACROLET"); + LispObject expander = + make_expander_for_macrolet.execute(def); + Closure expansionFunction = new Closure(expander, env); + MacroObject macroObject = + new MacroObject(symbol, expansionFunction); + ext.addFunctionBinding(symbol, macroObject); + defs = defs.cdr(); + } + return progn(ext.processDeclarations(args.cdr()), ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + }; + + private static final Primitive MAKE_EXPANDER_FOR_MACROLET = + new Primitive("make-expander-for-macrolet", PACKAGE_SYS, true, + "definition") + { + @Override + public LispObject execute(LispObject definition) + throws ConditionThrowable + { + Symbol symbol = checkSymbol(definition.car()); + LispObject lambdaList = definition.cadr(); + LispObject body = definition.cddr(); + LispObject block = + new Cons(Symbol.BLOCK, new Cons(symbol, body)); + LispObject toBeApplied = + list3(Symbol.LAMBDA, lambdaList, block); + final LispThread thread = LispThread.currentThread(); + LispObject formArg = gensym("WHOLE-", thread); + LispObject envArg = gensym("ENVIRONMENT-", thread); // Ignored. + LispObject expander = + list3(Symbol.LAMBDA, list2(formArg, envArg), + list3(Symbol.APPLY, toBeApplied, + list2(Symbol.CDR, formArg))); + return expander; + } + }; + + // ### tagbody + private static final SpecialOperator TAGBODY = + new SpecialOperator(Symbol.TAGBODY, "&rest statements") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + Environment ext = new Environment(env); + LispObject localTags = NIL; // Tags that are local to this TAGBODY. + LispObject body = args; + while (body != NIL) + { + LispObject current = body.car(); + body = ((Cons)body).cdr; + if (current instanceof Cons) + continue; + // It's a tag. + ext.addTagBinding(current, body); + localTags = new Cons(current, localTags); + } + final LispThread thread = LispThread.currentThread(); + final LispObject stack = thread.getStack(); + LispObject remaining = args; + while (remaining != NIL) + { + LispObject current = remaining.car(); + if (current instanceof Cons) + { + try + { + // Handle GO inline if possible. + if (((Cons)current).car == Symbol.GO) + { + if (interrupted) + handleInterrupt(); + LispObject tag = current.cadr(); + if (memql(tag, localTags)) + { + Binding binding = ext.getTagBinding(tag); + if (binding != null && binding.value != null) + { + remaining = binding.value; + continue; + } + } + throw new Go(tag); + } + eval(current, ext, thread); + } + catch (Go go) + { + LispObject tag = go.getTag(); + if (memql(tag, localTags)) + { + Binding binding = ext.getTagBinding(tag); + if (binding != null && binding.value != null) + { + remaining = binding.value; + thread.setStack(stack); + continue; + } + } + throw go; + } + } + remaining = ((Cons)remaining).cdr; + } + thread._values = null; + return NIL; + } + }; + + // ### go + private static final SpecialOperator GO = + new SpecialOperator(Symbol.GO, "tag") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() != 1) + return error(new WrongNumberOfArgumentsException(this)); + Binding binding = env.getTagBinding(args.car()); + if (binding == null) + return error(new ControlError("No tag named " + + args.car().writeToString() + + " is currently visible.")); + throw new Go(args.car()); + } + }; + + // ### block + private static final SpecialOperator BLOCK = + new SpecialOperator(Symbol.BLOCK, "name &rest forms") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + LispObject tag; + try + { + tag = (Symbol) args.car(); + } + catch (ClassCastException e) + { + return type_error(args.car(), Symbol.SYMBOL); + } + LispObject body = ((Cons)args).cdr(); + Environment ext = new Environment(env); + final LispObject block = new LispObject(); + ext.addBlock(tag, block); + LispObject result = NIL; + final LispThread thread = LispThread.currentThread(); + final LispObject stack = thread.getStack(); + try + { + return progn(body, ext, thread); + } + catch (Return ret) + { + if (ret.getBlock() == block) + { + thread.setStack(stack); + return ret.getResult(); + } + throw ret; + } + } + }; + + // ### return-from + private static final SpecialOperator RETURN_FROM = + new SpecialOperator(Symbol.RETURN_FROM, "name &optional value") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final int length = args.length(); + if (length < 1 || length > 2) + return error(new WrongNumberOfArgumentsException(this)); + Symbol symbol; + try + { + symbol = (Symbol) args.car(); + } + catch (ClassCastException e) + { + return type_error(args.car(), Symbol.SYMBOL); + } + LispObject block = env.lookupBlock(symbol); + if (block == null) + { + FastStringBuffer sb = new FastStringBuffer("No block named "); + sb.append(symbol.getName()); + sb.append(" is currently visible."); + error(new LispError(sb.toString())); + } + LispObject result; + if (length == 2) + result = eval(args.cadr(), env, LispThread.currentThread()); + else + result = NIL; + throw new Return(symbol, block, result); + } + }; + + // ### catch + private static final SpecialOperator CATCH = + new SpecialOperator(Symbol.CATCH, "tag &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() < 1) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + LispObject tag = eval(args.car(), env, thread); + thread.pushCatchTag(tag); + LispObject body = args.cdr(); + LispObject result = NIL; + final LispObject stack = thread.getStack(); + try + { + return progn(body, env, thread); + } + catch (Throw t) + { + if (t.tag == tag) + { + thread.setStack(stack); + return t.getResult(thread); + } + throw t; + } + catch (Return ret) + { + throw ret; + } + finally + { + thread.popCatchTag(); + } + } + }; + + // ### throw + private static final SpecialOperator THROW = + new SpecialOperator(Symbol.THROW, "tag result") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() != 2) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + thread.throwToTag(eval(args.car(), env, thread), + eval(args.cadr(), env, thread)); + // Not reached. + return NIL; + } + }; + + // ### unwind-protect + private static final SpecialOperator UNWIND_PROTECT = + new SpecialOperator(Symbol.UNWIND_PROTECT, "protected &body cleanup") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result; + LispObject[] values; + try + { + result = eval(args.car(), env, thread); + values = thread._values; + } + finally + { + LispObject body = args.cdr(); + while (body != NIL) + { + eval(body.car(), env, thread); + body = ((Cons)body).cdr; + } + } + if (values != null) + thread.setValues(values); + else + thread._values = null; + return result; + } + }; + + // ### eval-when + private static final SpecialOperator EVAL_WHEN = + new SpecialOperator(Symbol.EVAL_WHEN, "situations &rest forms") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject situations = args.car(); + if (situations != NIL) + { + if (memq(Keyword.EXECUTE, situations) || + memq(Symbol.EVAL, situations)) + { + return progn(args.cdr(), env, LispThread.currentThread()); + } + } + return NIL; + } + }; + + // ### multiple-value-bind + // multiple-value-bind (var*) values-form declaration* form* + // Should be a macro. + private static final SpecialOperator MULTIPLE_VALUE_BIND = + new SpecialOperator(Symbol.MULTIPLE_VALUE_BIND, + "vars value-form &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject vars = args.car(); + args = args.cdr(); + LispObject valuesForm = args.car(); + LispObject body = args.cdr(); + final LispThread thread = LispThread.currentThread(); + LispObject value = eval(valuesForm, env, thread); + LispObject[] values = thread._values; + if (values == null) + { + // eval() did not return multiple values. + values = new LispObject[1]; + values[0] = value; + } + // Process declarations. + LispObject specials = NIL; + while (body != NIL) + { + LispObject obj = body.car(); + if (obj instanceof Cons && ((Cons)obj).car == Symbol.DECLARE) + { + LispObject decls = ((Cons)obj).cdr; + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && ((Cons)decl).car == Symbol.SPECIAL) + { + LispObject declvars = ((Cons)decl).cdr; + while (declvars != NIL) + { + specials = new Cons(declvars.car(), specials); + declvars = ((Cons)declvars).cdr; + } + } + decls = ((Cons)decls).cdr; + } + body = ((Cons)body).cdr; + } + else + break; + } + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + final Environment ext = new Environment(env); + int i = 0; + LispObject var = vars.car(); + while (var != NIL) + { + final Symbol sym; + try + { + sym = (Symbol) var; + } + catch (ClassCastException e) + { + return type_error(var, Symbol.SYMBOL); + } + LispObject val = i < values.length ? values[i] : NIL; + if (specials != NIL && memq(sym, specials)) + { + thread.bindSpecial(sym, val); + ext.declareSpecial(sym); + } + else if (sym.isSpecialVariable()) + { + thread.bindSpecial(sym, val); + } + else + ext.bind(sym, val); + vars = vars.cdr(); + var = vars.car(); + ++i; + } + // Make sure free special declarations are visible in the body. + // "The scope of free declarations specifically does not include + // initialization forms for bindings established by the form + // containing the declarations." (3.3.4) + while (specials != NIL) + { + Symbol symbol = (Symbol) specials.car(); + ext.declareSpecial(symbol); + specials = ((Cons)specials).cdr; + } + thread._values = null; + LispObject result = NIL; + try + { + result = progn(body, ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + return result; + } + }; + + // ### multiple-value-prog1 + private static final SpecialOperator MULTIPLE_VALUE_PROG1 = + new SpecialOperator(Symbol.MULTIPLE_VALUE_PROG1, + "values-form &rest forms") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() == 0) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + LispObject result = eval(args.car(), env, thread); + LispObject[] values = thread._values; + while ((args = args.cdr()) != NIL) + eval(args.car(), env, thread); + if (values != null) + thread.setValues(values); + else + thread._values = null; + return result; + } + }; + + // ### multiple-value-call + private static final SpecialOperator MULTIPLE_VALUE_CALL = + new SpecialOperator(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() == 0) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + LispObject function; + LispObject obj = eval(args.car(), env, thread); + args = args.cdr(); + if (obj instanceof Symbol) + { + function = obj.getSymbolFunction(); + if (function == null) + error(new UndefinedFunction(obj)); + } + else if (obj instanceof Function) + { + function = obj; + } + else + { + error(new LispError(obj.writeToString() + + " is not a function name.")); + return NIL; + } + ArrayList arrayList = new ArrayList(); + while (args != NIL) + { + LispObject form = args.car(); + LispObject result = eval(form, env, thread); + LispObject[] values = thread._values; + if (values != null) + { + for (int i = 0; i < values.length; i++) + arrayList.add(values[i]); + } + else + arrayList.add(result); + args = ((Cons)args).cdr; + } + LispObject[] argv = new LispObject[arrayList.size()]; + arrayList.toArray(argv); + return funcall(function, argv, thread); + } + }; + + // ### and + // Should be a macro. + private static final SpecialOperator AND = + new SpecialOperator(Symbol.AND, "&rest forms") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = T; + while (args != NIL) + { + result = eval(args.car(), env, thread); + if (result == NIL) + { + if (((Cons)args).cdr != NIL) + { + // Not the last form. + thread._values = null; + } + break; + } + args = ((Cons)args).cdr; + } + return result; + } + }; + + // ### or + // Should be a macro. + private static final SpecialOperator OR = + new SpecialOperator(Symbol.OR, "&rest forms") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = NIL; + while (args != NIL) + { + result = eval(args.car(), env, thread); + if (result != NIL) + { + if (((Cons)args).cdr != NIL) + { + // Not the last form. + thread._values = null; + } + break; + } + args = ((Cons)args).cdr; + } + return result; + } + }; + + // ### multiple-value-list form => list + // Evaluates form and creates a list of the multiple values it returns. + // Should be a macro. + private static final SpecialOperator MULTIPLE_VALUE_LIST = + new SpecialOperator(Symbol.MULTIPLE_VALUE_LIST, "value-form") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() != 1) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + LispObject result = eval(((Cons)args).car, env, thread); + LispObject[] values = thread._values; + if (values == null) + return new Cons(result); + thread._values = null; + LispObject list = NIL; + for (int i = values.length; i-- > 0;) + list = new Cons(values[i], list); + return list; + } + }; + + // ### nth-value n form => object + // Evaluates n and then form and returns the nth value returned by form, or + // NIL if n >= number of values returned. + // Should be a macro. + private static final SpecialOperator NTH_VALUE = + new SpecialOperator(Symbol.NTH_VALUE, "n form") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() != 2) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + int n = Fixnum.getValue(eval(args.car(), env, thread)); + if (n < 0) + n = 0; + LispObject result = eval(args.cadr(), env, thread); + LispObject[] values = thread._values; + thread._values = null; + if (values == null) + { + // A single value was returned. + return n == 0 ? result : NIL; + } + if (n < values.length) + return values[n]; + return NIL; + } + }; + + // ### call-count + private static final Primitive CALL_COUNT = + new Primitive("call-count", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new Fixnum(arg.getCallCount()); + } + }; + + // ### set-call-count + private static final Primitive SET_CALL_COUNT = + new Primitive("set-call-count", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + first.setCallCount(Fixnum.getValue(second)); + return second; + } + }; + + // ### lambda-name + private static final Primitive LAMBDA_NAME = + new Primitive("lambda-name", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Operator) + { + return ((Operator)arg).getLambdaName(); + } + if (arg instanceof StandardGenericFunction) + { + return ((StandardGenericFunction)arg).getGenericFunctionName(); + } + return type_error(arg, Symbol.FUNCTION); + } + }; + + // ### %set-lambda-name + private static final Primitive _SET_LAMBDA_NAME = + new Primitive("%set-lambda-name", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Operator) + { + ((Operator)first).setLambdaName(second); + return second; + } + if (first instanceof StandardGenericFunction) + { + ((StandardGenericFunction)first).setGenericFunctionName(second); + return second; + } + return type_error(first, Symbol.FUNCTION); + } + }; + + // ### shrink-vector vector new-size => vector + // Destructively alters the vector, changing its length to NEW-SIZE, which + // must be less than or equal to its current length. + // shrink-vector vector new-size => vector + private static final Primitive SHRINK_VECTOR = + new Primitive("shrink-vector", PACKAGE_SYS, true, "vector new-size") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + checkVector(first).shrink(Fixnum.getValue(second)); + return first; + } + }; + + // ### subseq sequence start &optional end + private static final Primitive SUBSEQ = + new Primitive(Symbol.SUBSEQ, "sequence start &optional end") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final int start; + try + { + start = ((Fixnum)second).value; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.FIXNUM); + } + if (start < 0) + { + FastStringBuffer sb = new FastStringBuffer("Bad start index ("); + sb.append(start); + sb.append(") for SUBSEQ."); + error(new TypeError(sb.toString())); + } + if (first.listp()) + return list_subseq(first, start, -1); + if (first instanceof AbstractVector) + { + final AbstractVector v = (AbstractVector) first; + return v.subseq(start, v.length()); + } + return type_error(first, Symbol.SEQUENCE); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final int start; + try + { + start = ((Fixnum)second).value; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.FIXNUM); + } + if (start < 0) + { + FastStringBuffer sb = new FastStringBuffer("Bad start index ("); + sb.append(start); + sb.append(")."); + error(new TypeError(sb.toString())); + } + int end; + if (third != NIL) + { + end = Fixnum.getValue(third); + if (start > end) + { + FastStringBuffer sb = new FastStringBuffer("Start index ("); + sb.append(start); + sb.append(") is greater than end index ("); + sb.append(end); + sb.append(") for SUBSEQ."); + error(new TypeError(sb.toString())); + } + } + else + end = -1; + if (first.listp()) + return list_subseq(first, start, end); + if (first instanceof AbstractVector) + { + final AbstractVector v = (AbstractVector) first; + if (end < 0) + end = v.length(); + return v.subseq(start, end); + } + return type_error(first, Symbol.SEQUENCE); + } + }; + + private static final LispObject list_subseq(LispObject list, int start, + int end) + throws ConditionThrowable + { + int index = 0; + LispObject result = NIL; + while (list != NIL) + { + if (end >= 0 && index == end) + return result.nreverse(); + if (index++ >= start) + result = new Cons(list.car(), result); + list = list.cdr(); + } + return result.nreverse(); + } + + // ### list + private static final Primitive LIST = + new Primitive(Symbol.LIST, "&rest objects") + { + @Override + public LispObject execute() + { + return NIL; + } + @Override + public LispObject execute(LispObject arg) + { + return new Cons(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + return new Cons(first, new Cons(second)); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + { + return new Cons(first, new Cons(second, new Cons(third))); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + { + return new Cons(first, + new Cons(second, + new Cons(third, + new Cons(fourth)))); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = NIL; + for (int i = args.length; i-- > 0;) + result = new Cons(args[i], result); + return result; + } + }; + + // ### list* + private static final Primitive LIST_STAR = + new Primitive(Symbol.LIST_STAR, "&rest objects") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new WrongNumberOfArgumentsException(this)); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg; + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return new Cons(first, second); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return new Cons(first, new Cons(second, third)); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return new Cons(first, + new Cons(second, + new Cons(third, fourth))); + } + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int i = args.length - 1; + LispObject result = args[i]; + while (i-- > 0) + result = new Cons(args[i], result); + return result; + } + }; + + // ### nreverse + public static final Primitive NREVERSE = + new Primitive(Symbol.NREVERSE, "sequence") + { + @Override + public LispObject execute (LispObject arg) throws ConditionThrowable + { + return arg.nreverse(); + } + }; + + // ### nreconc + private static final Primitive NRECONC = + new Primitive(Symbol.NRECONC, "list tail") + { + @Override + public LispObject execute(LispObject list, LispObject obj) + throws ConditionThrowable + { + if (list instanceof Cons) + { + LispObject list3 = list.cdr(); + if (list3 instanceof Cons) + { + if (list3.cdr() instanceof Cons) + { + LispObject list1 = list3; + LispObject list2 = NIL; + do + { + LispObject h = list3.cdr(); + list3.setCdr(list2); + list2 = list3; + list3 = h; + } while (list3.cdr() instanceof Cons); + list.setCdr(list2); + list1.setCdr(list3); + } + LispObject h = list.car(); + list.setCar(list3.car()); + list3.setCar(h); + list3.setCdr(obj); + } + else if (list3 == NIL) + { + list.setCdr(obj); + } + else + type_error(list3, Symbol.LIST); + return list; + } + else if (list == NIL) + return obj; + else + return type_error(list, Symbol.LIST); + } + }; + + // ### reverse + private static final Primitive REVERSE = + new Primitive(Symbol.REVERSE, "sequence") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.reverse(); + } + }; + + // ### delete-eq item sequence => result-sequence + private static final Primitive DELETE_EQ = + new Primitive("delete-eq", PACKAGE_SYS, true, "item sequence") + { + @Override + public LispObject execute(LispObject item, LispObject sequence) + throws ConditionThrowable + { + if (sequence instanceof AbstractVector) + return ((AbstractVector)sequence).deleteEq(item); + else + return LIST_DELETE_EQ.execute(item, sequence); + } + }; + + // ### delete-eql item seqluence => result-seqluence + private static final Primitive DELETE_EQL = + new Primitive("delete-eql", PACKAGE_SYS, true, "item sequence") + { + @Override + public LispObject execute(LispObject item, LispObject sequence) + throws ConditionThrowable + { + if (sequence instanceof AbstractVector) + return ((AbstractVector)sequence).deleteEql(item); + else + return LIST_DELETE_EQL.execute(item, sequence); + } + }; + + // ### list-delete-eq item list => result-list + private static final Primitive LIST_DELETE_EQ = + new Primitive("list-delete-eq", PACKAGE_SYS, true, "item list") + { + @Override + public LispObject execute(LispObject item, LispObject list) + throws ConditionThrowable + { + if (list instanceof Cons) + { + LispObject tail = list; + LispObject splice = list; + while (tail instanceof Cons) + { + LispObject car = tail.car(); + if (car == item) + { + if (tail.cdr() != NIL) + { + LispObject temp = tail; + tail.setCar(temp.cadr()); + tail.setCdr(temp.cddr()); + } + else + { + // Last item. + if (tail == list) + return NIL; + splice.setCdr(NIL); + return list; + } + } + else + { + splice = tail; + tail = tail.cdr(); + } + } + if (tail == NIL) + return list; + else + return type_error(tail, Symbol.LIST); + } + else if (list == NIL) + return list; + else + return type_error(list, Symbol.LIST); + } + }; + + // ### list-delete-eql item list => result-list + private static final Primitive LIST_DELETE_EQL = + new Primitive("list-delete-eql", PACKAGE_SYS, true, "item list") + { + @Override + public LispObject execute(LispObject item, LispObject list) + throws ConditionThrowable + { + if (list instanceof Cons) + { + LispObject tail = list; + LispObject splice = list; + while (tail instanceof Cons) + { + LispObject car = tail.car(); + if (car.eql(item)) + { + if (tail.cdr() != NIL) + { + LispObject temp = tail; + tail.setCar(temp.cadr()); + tail.setCdr(temp.cddr()); + } + else + { + // Last item. + if (tail == list) + return NIL; + splice.setCdr(NIL); + return list; + } + } + else + { + splice = tail; + tail = tail.cdr(); + } + } + if (tail == NIL) + return list; + else + return type_error(tail, Symbol.LIST); + } + else if (list == NIL) + return list; + else + return type_error(list, Symbol.LIST); + } + }; + + // ### vector-delete-eq item vector => result-vector + private static final Primitive VECTOR_DELETE_EQ = + new Primitive("vector-delete-eq", PACKAGE_SYS, true, "item vector") + { + @Override + public LispObject execute(LispObject item, LispObject vector) + throws ConditionThrowable + { + try + { + ((AbstractVector)vector).deleteEq(item); + return vector; + } + catch (ClassCastException e) + { + return type_error(vector, Symbol.VECTOR); + } + } + }; + + // ### vector-delete-eql item vector => result-vector + private static final Primitive VECTOR_DELETE_EQL = + new Primitive("vector-delete-eql", PACKAGE_SYS, true, "item vector") + { + @Override + public LispObject execute(LispObject item, LispObject vector) + throws ConditionThrowable + { + try + { + ((AbstractVector)vector).deleteEql(item); + return vector; + } + catch (ClassCastException e) + { + return type_error(vector, Symbol.VECTOR); + } + } + }; + + // ### %set-elt + // %setelt sequence index newval => newval + private static final Primitive _SET_ELT = + new Primitive("%set-elt", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first instanceof AbstractVector) + { + ((AbstractVector)first).aset(Fixnum.getValue(second), third); + return third; + } + if (first instanceof Cons) + { + int index = Fixnum.getValue(second); + if (index < 0) + error(new TypeError()); + LispObject list = first; + int i = 0; + while (true) + { + if (i == index) + { + list.setCar(third); + return third; + } + list = list.cdr(); + if (list == NIL) + error(new TypeError()); + ++i; + } + } + return type_error(first, Symbol.SEQUENCE); + } + }; + + // ### %make-list + private static final Primitive _MAKE_LIST = + new Primitive("%make-list", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + int size = Fixnum.getValue(first); + if (size < 0) + return type_error(first, list3(Symbol.INTEGER, Fixnum.ZERO, + Symbol.MOST_POSITIVE_FIXNUM.getSymbolValue())); + LispObject result = NIL; + for (int i = size; i-- > 0;) + result = new Cons(second, result); + return result; + } + }; + + // ### %member item list key test test-not => tail + private static final Primitive _MEMBER = + new Primitive("%member", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject item, LispObject list, + LispObject key, LispObject test, + LispObject testNot) + throws ConditionThrowable + { + LispObject tail = checkList(list); + if (test != NIL && testNot != NIL) + error(new LispError("MEMBER: test and test-not both supplied")); + if (testNot == NIL) + { + if (test == NIL || test == Symbol.EQL) + test = EQL; + } + if (key == NIL) + { + if (test == EQL) + { + while (tail instanceof Cons) + { + if (item.eql(((Cons)tail).car)) + return tail; + tail = ((Cons)tail).cdr; + } + } + else if (test != NIL) + { + while (tail instanceof Cons) + { + LispObject candidate = ((Cons)tail).car; + if (test.execute(item, candidate) != NIL) + return tail; + tail = ((Cons)tail).cdr; + } + } + else + { + // test == NIL + while (tail instanceof Cons) + { + LispObject candidate = ((Cons)tail).car; + if (testNot.execute(item, candidate) == NIL) + return tail; + tail = ((Cons)tail).cdr; + } + } + } + else + { + // key != NIL + while (tail instanceof Cons) + { + LispObject candidate = key.execute(((Cons)tail).car); + if (test != NIL) + { + if (test.execute(item, candidate) != NIL) + return tail; + } + else + { + if (testNot.execute(item, candidate) == NIL) + return tail; + } + tail = ((Cons)tail).cdr; + } + } + if (tail != NIL) + type_error(tail, Symbol.LIST); + return NIL; + } + }; + + // ### funcall-key function-or-nil element + private static final Primitive FUNCALL_KEY = + new Primitive("funcall-key", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first != NIL) + return LispThread.currentThread().execute(first, second); + return second; + } + }; + + // ### coerce-to-function + private static final Primitive COERCE_TO_FUNCTION = + new Primitive("coerce-to-function", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return coerceToFunction(arg); + } + }; + + // ### make-closure lambda-form environment => closure + private static final Primitive MAKE_CLOSURE = + new Primitive("make-closure", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Cons && ((Cons)first).car == Symbol.LAMBDA) + { + final Environment env; + if (second == NIL) + env = new Environment(); + else + env = checkEnvironment(second); + return new Closure(first, env); + } + return error(new TypeError("The argument to MAKE-CLOSURE is not a lambda form.")); + } + }; + + // ### streamp + private static final Primitive STREAMP = + new Primitive(Symbol.STREAMP, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof Stream ? T : NIL; + } + }; + + // ### integerp + private static final Primitive INTEGERP = + new Primitive(Symbol.INTEGERP, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg.INTEGERP(); + } + }; + + // ### evenp + private static final Primitive EVENP = + new Primitive(Symbol.EVENP, "integer") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.EVENP(); + } + }; + + // ### oddp + private static final Primitive ODDP = new Primitive(Symbol.ODDP, "integer") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.ODDP(); + } + }; + + // ### numberp + private static final Primitive NUMBERP = + new Primitive(Symbol.NUMBERP, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg.NUMBERP(); + } + }; + + // ### realp + private static final Primitive REALP = + new Primitive(Symbol.REALP, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg.REALP(); + } + }; + + // ### rationalp + private static final Primitive RATIONALP = + new Primitive(Symbol.RATIONALP,"object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg.RATIONALP(); + } + }; + + // ### complex + private static final Primitive COMPLEX = + new Primitive(Symbol.COMPLEX, "realpart &optional imagpart") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) + return Complex.getInstance(arg, SingleFloat.ZERO); + if (arg instanceof DoubleFloat) + return Complex.getInstance(arg, DoubleFloat.ZERO); + if (arg.realp()) + return arg; + return type_error(arg, Symbol.REAL); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return Complex.getInstance(first, second); + } + }; + + // ### complexp + private static final Primitive COMPLEXP = + new Primitive(Symbol.COMPLEXP, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg.COMPLEXP(); + } + }; + + // ### numerator + private static final Primitive NUMERATOR = + new Primitive(Symbol.NUMERATOR, "rational") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.NUMERATOR(); + } + }; + + // ### denominator + private static final Primitive DENOMINATOR = + new Primitive(Symbol.DENOMINATOR, "rational") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.DENOMINATOR(); + } + }; + + // ### realpart + private static final Primitive REALPART = + new Primitive(Symbol.REALPART, "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) + return ((Complex)arg).getRealPart(); + if (arg.numberp()) + return arg; + return type_error(arg, Symbol.NUMBER); + } + }; + + // ### imagpart + private static final Primitive IMAGPART = + new Primitive(Symbol.IMAGPART, "number") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Complex) + return ((Complex)arg).getImaginaryPart(); + return arg.multiplyBy(Fixnum.ZERO); + } + }; + + // ### integer-length + private static final Primitive INTEGER_LENGTH = + new Primitive(Symbol.INTEGER_LENGTH, "integer") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum) + { + int n = ((Fixnum)arg).value; + if (n < 0) + n = ~n; + int count = 0; + while (n > 0) + { + n = n >>> 1; + ++count; + } + return new Fixnum(count); + } + if (arg instanceof Bignum) + return new Fixnum(((Bignum)arg).value.bitLength()); + return type_error(arg, Symbol.INTEGER); + } + }; + + // ### gcd-2 + private static final Primitive GCD_2 = + new Primitive("gcd-2", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + BigInteger n1, n2; + if (first instanceof Fixnum) + n1 = BigInteger.valueOf(((Fixnum)first).value); + else if (first instanceof Bignum) + n1 = ((Bignum)first).value; + else + return type_error(first, Symbol.INTEGER); + if (second instanceof Fixnum) + n2 = BigInteger.valueOf(((Fixnum)second).value); + else if (second instanceof Bignum) + n2 = ((Bignum)second).value; + else + return type_error(second, Symbol.INTEGER); + return number(n1.gcd(n2)); + } + }; + + // ### identity-hash-code + private static final Primitive IDENTITY_HASH_CODE = + new Primitive("identity-hash-code", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new Fixnum(System.identityHashCode(arg)); + } + }; + + // ### simple-vector-search pattern vector => position + // Searches vector for pattern. + private static final Primitive SIMPLE_VECTOR_SEARCH = + new Primitive("simple-vector-search", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + AbstractVector v = checkVector(second); + if (first.length() == 0) + return Fixnum.ZERO; + final int patternLength = first.length(); + final int limit = v.length() - patternLength; + if (first instanceof AbstractVector) + { + AbstractVector pattern = (AbstractVector) first; + LispObject element = pattern.AREF(0); + for (int i = 0; i <= limit; i++) + { + if (v.AREF(i).eql(element)) + { + // Found match for first element of pattern. + boolean match = true; + // We've already checked the first element. + int j = i + 1; + for (int k = 1; k < patternLength; k++) + { + if (v.AREF(j).eql(pattern.AREF(k))) + { + ++j; + } + else + { + match = false; + break; + } + } + if (match) + return new Fixnum(i); + } + } + } + else + { + // Pattern is a list. + LispObject element = first.car(); + for (int i = 0; i <= limit; i++) + { + if (v.AREF(i).eql(element)) + { + // Found match for first element of pattern. + boolean match = true; + // We've already checked the first element. + int j = i + 1; + for (LispObject rest = first.cdr(); rest != NIL; rest = rest.cdr()) + { + if (v.AREF(j).eql(rest.car())) + { + ++j; + } + else + { + match = false; + break; + } + } + if (match) + return new Fixnum(i); + } + } + } + return NIL; + } + }; + + // ### uptime + private static final Primitive UPTIME = + new Primitive("uptime", PACKAGE_EXT, true) + { + @Override + public LispObject execute() throws ConditionThrowable + { + return number(System.currentTimeMillis() - Main.startTimeMillis); + } + }; + + // ### built-in-function-p + private static final Primitive BUILT_IN_FUNCTION_P = + new Primitive("built-in-function-p", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Symbol)arg).isBuiltInFunction() ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### inspected-parts + private static final Primitive INSPECTED_PARTS = + new Primitive("inspected-parts", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.getParts(); + } + }; + + // ### inspected-description + private static final Primitive INSPECTED_DESCRIPTION = + new Primitive("inspected-description", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.getDescription(); + } + }; + + // ### symbol-name + public static final Primitive SYMBOL_NAME = + new Primitive(Symbol.SYMBOL_NAME, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Symbol)arg).name; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### symbol-package + public static final Primitive SYMBOL_PACKAGE = + new Primitive(Symbol.SYMBOL_PACKAGE, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Symbol)arg).getPackage(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### symbol-function + public static final Primitive SYMBOL_FUNCTION = + new Primitive(Symbol.SYMBOL_FUNCTION, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + LispObject function = ((Symbol)arg).getSymbolFunction(); + if (function != null) + return function; + return error(new UndefinedFunction(arg)); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### %set-symbol-function + public static final Primitive _SET_SYMBOL_FUNCTION = + new Primitive("%set-symbol-function", PACKAGE_SYS, false, "symbol function") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((Symbol)first).setSymbolFunction(second); + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + }; + + // ### symbol-plist + public static final Primitive SYMBOL_PLIST = + new Primitive(Symbol.SYMBOL_PLIST, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Symbol)arg).getPropertyList(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### keywordp + public static final Primitive KEYWORDP = + new Primitive(Symbol.KEYWORDP, "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Symbol) + { + if (((Symbol)arg).getPackage() == PACKAGE_KEYWORD) + return T; + } + return NIL; + } + }; + + // ### make-symbol + public static final Primitive MAKE_SYMBOL = + new Primitive(Symbol.MAKE_SYMBOL, "name") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SimpleString) + return new Symbol((SimpleString)arg); + // Not a simple string. + if (arg instanceof AbstractString) + return new Symbol(arg.getStringValue()); + return type_error(arg, Symbol.STRING); + } + }; + + // ### makunbound + public static final Primitive MAKUNBOUND = + new Primitive(Symbol.MAKUNBOUND, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + ((Symbol)arg).setSymbolValue(null); + return arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### %class-name + private static final Primitive _CLASS_NAME = + new Primitive("%class-name", PACKAGE_SYS, true, "class") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((LispClass)arg).symbol; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-name + private static final Primitive _SET_CLASS_NAME = + new Primitive("%set-class-name", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).symbol = checkSymbol(second); + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### class-layout + private static final Primitive CLASS_LAYOUT = + new Primitive("class-layout", PACKAGE_SYS, true, "class") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + Layout layout = ((LispClass)arg).getClassLayout(); + return layout != null ? layout : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-layout + private static final Primitive _SET_CLASS_LAYOUT = + new Primitive("%set-class-layout", PACKAGE_SYS, true, "class layout") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).setClassLayout((Layout)second); + return second; + } + catch (ClassCastException e) + { + if (!(first instanceof LispClass)) + return type_error(first, Symbol.CLASS); + if (!(second instanceof Layout)) + return type_error(second, Symbol.LAYOUT); + // Not reached. + return NIL; + } + } + }; + + // ### class-direct-superclasses + private static final Primitive CLASS_DIRECT_SUPERCLASSES = + new Primitive("class-direct-superclasses", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((LispClass)arg).getDirectSuperclasses(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-direct-superclasses + private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES = + new Primitive("%set-class-direct-superclasses", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).setDirectSuperclasses(second); + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### class-direct-subclasses + private static final Primitive CLASS_DIRECT_SUBCLASSES = + new Primitive("class-direct-subclasses", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((LispClass)arg).getDirectSubclasses(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-direct-subclasses + private static final Primitive _SET_CLASS_DIRECT_SUBCLASSES = + new Primitive("%set-class-direct-subclasses", PACKAGE_SYS, true, + "class direct-subclasses") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).setDirectSubclasses(second); + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### %class-precedence-list + private static final Primitive _CLASS_PRECEDENCE_LIST = + new Primitive("%class-precedence-list", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((LispClass)arg).getCPL(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### set-class-precedence-list + private static final Primitive SET_CLASS_PRECEDENCE_LIST = + new Primitive("set-class-precedence-list", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).classPrecedenceList = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### class-direct-methods + private static final Primitive CLASS_DIRECT_METHODS = + new Primitive("class-direct-methods", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + try + { + return ((LispClass)arg).directMethods; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-direct-methods + private static final Primitive _SET_CLASS_DIRECT_METHODS = + new Primitive("%set-class-direct-methods", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).directMethods = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### class-documentation + private static final Primitive CLASS_DOCUMENTATION = + new Primitive("class-documentation", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + try + { + return ((LispClass)arg).documentation; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-documentation + private static final Primitive _SET_CLASS_DOCUMENTATION = + new Primitive("%set-class-documentation", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).documentation = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### class-finalized-p + private static final Primitive CLASS_FINALIZED_P = + new Primitive("class-finalized-p", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((LispClass)arg).isFinalized() ? T : NIL; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CLASS); + } + } + }; + + // ### %set-class-finalized-p + private static final Primitive _SET_CLASS_FINALIZED_P = + new Primitive("%set-class-finalized-p", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((LispClass)first).setFinalized(second != NIL); + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CLASS); + } + } + }; + + // ### classp + private static final Primitive CLASSP = + new Primitive("classp", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof LispClass ? T : NIL; + } + }; + + // ### char-to-utf8 char => octets + private static final Primitive CHAR_TO_UTF8 = + new Primitive("char-to-utf8", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispCharacter c; + try + { + c = (LispCharacter) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.CHARACTER); + } + char[] chars = new char[1]; + chars[0] = c.value; + String s = new String(chars); + final byte[] bytes; + try + { + bytes = s.getBytes("UTF8"); + } + catch (java.io.UnsupportedEncodingException e) + { + return error(new LispError("UTF8 is not a supported encoding.")); + } + LispObject[] objects = new LispObject[bytes.length]; + for (int i = bytes.length; i-- > 0;) + { + int n = bytes[i]; + if (n < 0) + n += 256; + objects[i] = new Fixnum(n); + } + return new SimpleVector(objects); + } + }; + + // ### %documentation + private static final Primitive _DOCUMENTATION = + new Primitive("%documentation", PACKAGE_SYS, true, + "object doc-type") + { + @Override + public LispObject execute(LispObject object, LispObject docType) + throws ConditionThrowable + { + LispObject doc = object.getDocumentation(docType); + if (doc == NIL) + { + if (docType == Symbol.FUNCTION && object instanceof Symbol) + { + LispObject function = object.getSymbolFunction(); + if (function != null) + doc = function.getDocumentation(docType); + } + } + return doc; + } + }; + + // ### %set-documentation + private static final Primitive _SET_DOCUMENTATION = + new Primitive("%set-documentation", PACKAGE_SYS, true, + "object doc-type documentation") + { + @Override + public LispObject execute(LispObject object, LispObject docType, + LispObject documentation) + throws ConditionThrowable + { + object.setDocumentation(docType, documentation); + return documentation; + } + }; + + // ### %putf + private static final Primitive _PUTF = + new Primitive("%putf", PACKAGE_SYS, true, + "plist indicator new-value") + { + @Override + public LispObject execute(LispObject plist, LispObject indicator, + LispObject newValue) + throws ConditionThrowable + { + return putf(plist, indicator, newValue); + } + }; + + // ### function-plist + private static final Primitive FUNCTION_PLIST = + new Primitive("function-plist", PACKAGE_SYS, true, "function") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Function)arg).getPropertyList(); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.FUNCTION); + } + } + }; + + // ### make-keyword + private static final Primitive MAKE_KEYWORD = + new Primitive("make-keyword", PACKAGE_SYS, true, "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return PACKAGE_KEYWORD.intern(((Symbol)arg).name); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SYMBOL); + } + } + }; + + // ### standard-object-p object => generalized-boolean + private static final Primitive STANDARD_OBJECT_P = + new Primitive("standard-object-p", PACKAGE_SYS, true, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof StandardObject ? T : NIL; + } + }; + + // ### copy-tree + private static final Primitive COPY_TREE = + new Primitive(Symbol.COPY_TREE, "object") + { + @Override + public LispObject execute(LispObject arg) + { + if (arg instanceof Cons) + { + Cons cons = (Cons) arg; + return new Cons(execute(cons.car), execute(cons.cdr)); + } + else + return arg; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/PrintNotReadable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/PrintNotReadable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,125 @@ +/* + * PrintNotReadable.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: PrintNotReadable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class PrintNotReadable extends LispError +{ + public PrintNotReadable(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.PRINT_NOT_READABLE); + super.initialize(initArgs); + LispObject object = null; + while (initArgs != NIL) { + LispObject first = initArgs.car(); + initArgs = initArgs.cdr(); + LispObject second = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.OBJECT) { + object = second; + break; + } + } + if (object != null) + setInstanceSlotValue(Symbol.OBJECT, object); + } + + @Override + public LispObject typeOf() + { + return Symbol.PRINT_NOT_READABLE; + } + + @Override + public LispObject classOf() + { + return StandardClass.PRINT_NOT_READABLE; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.PRINT_NOT_READABLE) + return T; + if (type == StandardClass.PRINT_NOT_READABLE) + return T; + return super.typep(type); + } + + @Override + public String getMessage() + { + FastStringBuffer sb = new FastStringBuffer(); + LispObject object = UNBOUND_VALUE; + try { + object = getInstanceSlotValue(Symbol.OBJECT); + } + catch (Throwable t) { + Debug.trace(t); + } + if (object != UNBOUND_VALUE) { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_READABLY, NIL); + thread.bindSpecial(Symbol.PRINT_ARRAY, NIL); + try { + sb.append(object.writeToString()); + } + catch (Throwable t) { + sb.append("Object"); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } else + sb.append("Object"); + sb.append(" cannot be printed readably."); + return sb.toString(); + } + + // ### print-not-readable-object + private static final Primitive PRINT_NOT_READABLE_OBJECT = + new Primitive("print-not-readable-object", "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((PrintNotReadable)arg).getInstanceSlotValue(Symbol.OBJECT); + } + catch (ClassCastException e) { + return type_error(arg, Symbol.PRINT_NOT_READABLE); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Profiler.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Profiler.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,140 @@ +/* + * Profiler.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Profiler.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Profiler extends Lisp +{ + private static int sleep = 1; + + public static final void sample(LispThread thread) + throws ConditionThrowable + { + sampleNow = false; + thread.incrementCallCounts(); + } + + private static final Runnable profilerRunnable = new Runnable() { + public void run() + { + while (profiling) { + sampleNow = true; + try { + Thread.sleep(sleep); + } + catch (InterruptedException e) { + Debug.trace(e); + } + } + } + }; + + // ### %start-profiler + // %start-profiler type granularity + public static final Primitive _START_PROFILER = + new Primitive("%start-profiler", PACKAGE_PROF, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + Stream out = getStandardOutput(); + out.freshLine(); + if (profiling) { + out._writeLine("; Profiler already started."); + } else { + if (first == Keyword.TIME) + sampling = true; + else if (first == Keyword.COUNT_ONLY) + sampling = false; + else + return error(new LispError( + "%START-PROFILER: argument must be either :TIME or :COUNT-ONLY")); + Package[] packages = Packages.getAllPackages(); + for (int i = 0; i < packages.length; i++) { + Package pkg = packages[i]; + Symbol[] symbols = pkg.symbols(); + for (int j = 0; j < symbols.length; j++) { + Symbol symbol = symbols[j]; + LispObject object = symbol.getSymbolFunction(); + if (object != null) { + object.setCallCount(0); + if (object instanceof StandardGenericFunction) { + LispObject methods = + PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS").execute(object); + while (methods != NIL) { + StandardMethod method = (StandardMethod) methods.car(); + method.getFunction().setCallCount(0); + methods = methods.cdr(); + } + } + } + } + } + if (sampling) { + sleep = Fixnum.getValue(second); + thread.resetStack(); + Thread t = new Thread(profilerRunnable); + int priority = + Math.min(Thread.currentThread().getPriority() + 1, + Thread.MAX_PRIORITY); + t.setPriority(priority); + new Thread(profilerRunnable).start(); + } + out._writeLine("; Profiler started."); + profiling = true; + } + return thread.nothing(); + } + }; + + // ### stop-profiler + public static final Primitive STOP_PROFILER = + new Primitive("stop-profiler", PACKAGE_PROF, true) + { + @Override + public LispObject execute() throws ConditionThrowable + { + Stream out = getStandardOutput(); + out.freshLine(); + if (profiling) { + profiling = false; + out._writeLine("; Profiler stopped."); + } else + out._writeLine("; Profiler was not started."); + out._finishOutput(); + return LispThread.currentThread().nothing(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/ProgramError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ProgramError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,83 @@ +/* + * ProgramError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ProgramError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class ProgramError extends LispError +{ + protected ProgramError(LispClass cls) throws ConditionThrowable + { + super(cls); + } + + public ProgramError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.PROGRAM_ERROR); + initialize(initArgs); + + if (initArgs.listp() && initArgs.car().stringp()) { + setFormatControl(initArgs.car().getStringValue()); + setFormatArguments(initArgs.cdr()); + } + + } + + public ProgramError(String message) throws ConditionThrowable + { + super(StandardClass.PROGRAM_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + } + + @Override + public LispObject typeOf() + { + return Symbol.PROGRAM_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.PROGRAM_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.PROGRAM_ERROR) + return T; + if (type == StandardClass.PROGRAM_ERROR) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/RandomState.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/RandomState.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,190 @@ +/* + * RandomState.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: RandomState.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.FileInputStream; +import java.io.FileOutputStream; +import java.io.ObjectInputStream; +import java.io.ObjectOutputStream; +import java.math.BigInteger; +import java.util.Random; + +public final class RandomState extends LispObject +{ + private Random random; + + public RandomState() + { + random = new Random(); + } + + public RandomState(RandomState rs) throws ConditionThrowable + { + try { + File file = File.createTempFile("MAKE-RANDOM-STATE", null); + FileOutputStream fileOut = new FileOutputStream(file); + ObjectOutputStream out = new ObjectOutputStream(fileOut); + out.writeObject(rs.random); + out.close(); + FileInputStream fileIn = new FileInputStream(file); + ObjectInputStream in = new ObjectInputStream(fileIn); + random = (Random) in.readObject(); + in.close(); + file.delete(); + } + catch (Throwable t) { + error(new LispError("Unable to copy random state.")); + } + } + + @Override + public LispObject typeOf() + { + return Symbol.RANDOM_STATE; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.RANDOM_STATE; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.RANDOM_STATE) + return T; + if (type == BuiltInClass.RANDOM_STATE) + return T; + return super.typep(type); + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.RANDOM_STATE); + } + + public LispObject random(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum) { + int limit = ((Fixnum)arg).value; + if (limit > 0) { + int n = random.nextInt((int)limit); + return new Fixnum(n); + } + } else if (arg instanceof Bignum) { + BigInteger limit = ((Bignum)arg).value; + if (limit.signum() > 0) { + int bitLength = limit.bitLength(); + BigInteger rand = new BigInteger(bitLength + 1, random); + BigInteger remainder = rand.remainder(limit); + return number(remainder); + } + } else if (arg instanceof SingleFloat) { + float limit = ((SingleFloat)arg).value; + if (limit > 0) { + float rand = random.nextFloat(); + return new SingleFloat(rand * limit); + } + } else if (arg instanceof DoubleFloat) { + double limit = ((DoubleFloat)arg).value; + if (limit > 0) { + double rand = random.nextDouble(); + return new DoubleFloat(rand * limit); + } + } + return type_error(arg, list3(Symbol.OR, + list2(Symbol.INTEGER, Fixnum.ONE), + list2(Symbol.FLOAT, list1(Fixnum.ZERO)))); + } + + // ### random limit &optional random-state => random-number + private static final Primitive RANDOM = + new Primitive(Symbol.RANDOM, "limit &optional random-state") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + RandomState randomState = + (RandomState) Symbol._RANDOM_STATE_.symbolValue(); + return randomState.random(arg); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (second instanceof RandomState) { + RandomState randomState = (RandomState) second; + return randomState.random(first); + } + return type_error(first, Symbol.RANDOM_STATE); + } + }; + + // ### make-random-state &optional state + private static final Primitive MAKE_RANDOM_STATE = + new Primitive(Symbol.MAKE_RANDOM_STATE, "&optional state") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new RandomState((RandomState)Symbol._RANDOM_STATE_.symbolValue()); + } + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg == NIL) + return new RandomState((RandomState)Symbol._RANDOM_STATE_.symbolValue()); + if (arg == T) + return new RandomState(); + if (arg instanceof RandomState) + return new RandomState((RandomState)arg); + return type_error(arg, Symbol.RANDOM_STATE); + } + }; + + // ### random-state-p + private static final Primitive RANDOM_STATE_P = + new Primitive(Symbol.RANDOM_STATE_P, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof RandomState ? T : NIL; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Ratio.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Ratio.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,591 @@ +/* + * Ratio.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Ratio.java 11579 2009-01-24 10:24:34Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class Ratio extends LispObject +{ + private BigInteger numerator; + private BigInteger denominator; + + public Ratio(BigInteger numerator, BigInteger denominator) + { + this.numerator = numerator; + this.denominator = denominator; + } + + public BigInteger numerator() + { + return numerator; + } + + @Override + public LispObject NUMERATOR() + { + return number(numerator); + } + + public BigInteger denominator() + { + return denominator; + } + + @Override + public LispObject DENOMINATOR() + { + return number(denominator); + } + + @Override + public LispObject typeOf() + { + return Symbol.RATIO; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.RATIO; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.RATIO) + return T; + if (type == Symbol.RATIONAL) + return T; + if (type == Symbol.REAL) + return T; + if (type == Symbol.NUMBER) + return T; + if (type == BuiltInClass.RATIO) + return T; + return super.typep(type); + } + + @Override + public LispObject NUMBERP() + { + return T; + } + + @Override + public boolean numberp() + { + return true; + } + + @Override + public boolean rationalp() + { + return true; + } + + @Override + public boolean realp() + { + return true; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof Ratio) { + return (numerator.equals(((Ratio)obj).numerator) && + denominator.equals(((Ratio)obj).denominator)); + } + return false; + } + + @Override + public boolean equal(LispObject obj) + { + return eql(obj); + } + + @Override + public boolean equalp(LispObject obj) + { + if (obj instanceof Ratio) { + return numerator.equals(((Ratio)obj).numerator) && + denominator.equals(((Ratio)obj).denominator); + } + if (obj instanceof SingleFloat) { + return floatValue() == ((SingleFloat)obj).value; + } + if (obj instanceof DoubleFloat) { + return doubleValue() == ((DoubleFloat)obj).value; + } + return false; + } + + @Override + public LispObject ABS() + { + if (numerator.signum() > 0 && denominator.signum() > 0) + return this; + if (numerator.signum() < 0 && denominator.signum() < 0) + return this; + return new Ratio(numerator.negate(), denominator); + } + + @Override + public boolean plusp() + { + return numerator.signum() == denominator.signum(); + } + + @Override + public boolean minusp() + { + return numerator.signum() != denominator.signum(); + } + + @Override + public boolean zerop() + { + return false; + } + + @Override + public float floatValue() + { + return (float) doubleValue(); + } + + @Override + public double doubleValue() + { + double result = numerator.doubleValue() / denominator.doubleValue(); + if (result != 0 && !Double.isNaN(result) && !Double.isInfinite(result)) + return result; + final boolean negative = numerator.signum() < 0; + final BigInteger num = negative ? numerator.negate() : numerator; + final BigInteger den = denominator; + final int numLen = num.bitLength(); + final int denLen = den.bitLength(); + int length = Math.min(numLen, denLen); + if (length <= 1) + return result; + BigInteger n = num; + BigInteger d = den; + final int digits = 54; + if (length > digits) { + n = n.shiftRight(length - digits); + d = d.shiftRight(length - digits); + length -= digits; + } else { + n = n.shiftRight(1); + d = d.shiftRight(1); + --length; + } + for (int i = 0; i < length; i++) { + result = n.doubleValue() / d.doubleValue(); + if (result != 0 && !Double.isNaN(result) && !Double.isInfinite(result)) + break; + n = n.shiftRight(1); + d = d.shiftRight(1); + } + return negative ? -result : result; + } + + @Override + public final LispObject incr() throws ConditionThrowable + { + return new Ratio(numerator.add(denominator), denominator); + } + + @Override + public final LispObject decr() throws ConditionThrowable + { + return new Ratio(numerator.subtract(denominator), denominator); + } + + @Override + public LispObject add(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n = + numerator.add(BigInteger.valueOf(((Fixnum)obj).value).multiply(denominator)); + return number(n, denominator); + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value; + return number(numerator.add(n.multiply(denominator)), + denominator); + } + if (obj instanceof Ratio) { + BigInteger n = ((Ratio)obj).numerator; + BigInteger d = ((Ratio)obj).denominator; + if (denominator.equals(d)) + return number(numerator.add(n), denominator); + BigInteger common = denominator.multiply(d); + return number(numerator.multiply(d).add(n.multiply(denominator)), + common); + } + if (obj instanceof SingleFloat) { + return new SingleFloat(floatValue() + ((SingleFloat)obj).value); + } + if (obj instanceof DoubleFloat) { + return new DoubleFloat(doubleValue() + ((DoubleFloat)obj).value); + } + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(add(c.getRealPart()), c.getImaginaryPart()); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n = + numerator.subtract(BigInteger.valueOf(((Fixnum)obj).value).multiply(denominator)); + return number(n, denominator); + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value; + return number(numerator.subtract(n.multiply(denominator)), + denominator); + } + if (obj instanceof Ratio) { + BigInteger n = ((Ratio)obj).numerator; + BigInteger d = ((Ratio)obj).denominator; + if (denominator.equals(d)) + return number(numerator.subtract(n), denominator); + BigInteger common = denominator.multiply(d); + return number(numerator.multiply(d).subtract(n.multiply(denominator)), + common); + } + if (obj instanceof SingleFloat) { + return new SingleFloat(floatValue() - ((SingleFloat)obj).value); + } + if (obj instanceof DoubleFloat) { + return new DoubleFloat(doubleValue() - ((DoubleFloat)obj).value); + } + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(subtract(c.getRealPart()), + Fixnum.ZERO.subtract(c.getImaginaryPart())); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n = ((Fixnum)obj).getBigInteger(); + return number(numerator.multiply(n), denominator); + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value; + return number(numerator.multiply(n), denominator); + } + if (obj instanceof Ratio) { + BigInteger n = ((Ratio)obj).numerator; + BigInteger d = ((Ratio)obj).denominator; + return number(numerator.multiply(n), denominator.multiply(d)); + } + if (obj instanceof SingleFloat) { + return new SingleFloat(floatValue() * ((SingleFloat)obj).value); + } + if (obj instanceof DoubleFloat) { + return new DoubleFloat(doubleValue() * ((DoubleFloat)obj).value); + } + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(multiplyBy(c.getRealPart()), + multiplyBy(c.getImaginaryPart())); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n = ((Fixnum)obj).getBigInteger(); + return number(numerator, denominator.multiply(n)); + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value; + return number(numerator, denominator.multiply(n)); + } + if (obj instanceof Ratio) { + BigInteger n = ((Ratio)obj).numerator; + BigInteger d = ((Ratio)obj).denominator; + return number(numerator.multiply(d), denominator.multiply(n)); + } + if (obj instanceof SingleFloat) { + if (obj.zerop()) + return error(new DivisionByZero()); + return new SingleFloat(floatValue() / ((SingleFloat)obj).value); + } + if (obj instanceof DoubleFloat) { + if (obj.zerop()) + return error(new DivisionByZero()); + return new DoubleFloat(doubleValue() / ((DoubleFloat)obj).value); + } + if (obj instanceof Complex) { + Complex c = (Complex) obj; + // numerator + LispObject realPart = this.multiplyBy(c.getRealPart()); + LispObject imagPart = + Fixnum.ZERO.subtract(this).multiplyBy(c.getImaginaryPart()); + // denominator + LispObject d = + c.getRealPart().multiplyBy(c.getRealPart()); + d = d.add(c.getImaginaryPart().multiplyBy(c.getImaginaryPart())); + return Complex.getInstance(realPart.divideBy(d), + imagPart.divideBy(d)); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Ratio) + return (numerator.equals(((Ratio)obj).numerator) && + denominator.equals(((Ratio)obj).denominator)); + if (obj instanceof SingleFloat) + return isEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isEqualTo(((DoubleFloat)obj).rational()); + if (obj.numberp()) + return false; + error(new TypeError(obj, Symbol.NUMBER)); + // Not reached. + return false; + } + + @Override + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + return !isEqualTo(obj); + } + + @Override + public boolean isLessThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n2 = ((Fixnum)obj).getBigInteger().multiply(denominator); + return numerator.compareTo(n2) < 0; + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value.multiply(denominator); + return numerator.compareTo(n) < 0; + } + if (obj instanceof Ratio) { + BigInteger n1 = numerator.multiply(((Ratio)obj).denominator); + BigInteger n2 = ((Ratio)obj).numerator.multiply(denominator); + return n1.compareTo(n2) < 0; + } + if (obj instanceof SingleFloat) + return isLessThan(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isLessThan(((DoubleFloat)obj).rational()); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n2 = ((Fixnum)obj).getBigInteger().multiply(denominator); + return numerator.compareTo(n2) > 0; + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value.multiply(denominator); + return numerator.compareTo(n) > 0; + } + if (obj instanceof Ratio) { + BigInteger n1 = numerator.multiply(((Ratio)obj).denominator); + BigInteger n2 = ((Ratio)obj).numerator.multiply(denominator); + return n1.compareTo(n2) > 0; + } + if (obj instanceof SingleFloat) + return isGreaterThan(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isGreaterThan(((DoubleFloat)obj).rational()); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public boolean isLessThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n2 = ((Fixnum)obj).getBigInteger().multiply(denominator); + return numerator.compareTo(n2) <= 0; + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value.multiply(denominator); + return numerator.compareTo(n) <= 0; + } + if (obj instanceof Ratio) { + BigInteger n1 = numerator.multiply(((Ratio)obj).denominator); + BigInteger n2 = ((Ratio)obj).numerator.multiply(denominator); + return n1.compareTo(n2) <= 0; + } + if (obj instanceof SingleFloat) + return isLessThanOrEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isLessThanOrEqualTo(((DoubleFloat)obj).rational()); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) { + BigInteger n2 = ((Fixnum)obj).getBigInteger().multiply(denominator); + return numerator.compareTo(n2) >= 0; + } + if (obj instanceof Bignum) { + BigInteger n = ((Bignum)obj).value.multiply(denominator); + return numerator.compareTo(n) >= 0; + } + if (obj instanceof Ratio) { + BigInteger n1 = numerator.multiply(((Ratio)obj).denominator); + BigInteger n2 = ((Ratio)obj).numerator.multiply(denominator); + return n1.compareTo(n2) >= 0; + } + if (obj instanceof SingleFloat) + return isGreaterThanOrEqualTo(((SingleFloat)obj).rational()); + if (obj instanceof DoubleFloat) + return isGreaterThanOrEqualTo(((DoubleFloat)obj).rational()); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public LispObject truncate(LispObject obj) throws ConditionThrowable + { + // "When rationals and floats are combined by a numerical function, + // the rational is first converted to a float of the same format." + // 12.1.4.1 + if (obj instanceof SingleFloat) + return new SingleFloat(floatValue()).truncate(obj); + if (obj instanceof DoubleFloat) + return new DoubleFloat(doubleValue()).truncate(obj); + BigInteger n, d; + try { + if (obj instanceof Fixnum) { + n = ((Fixnum)obj).getBigInteger(); + d = BigInteger.ONE; + } else if (obj instanceof Bignum) { + n = ((Bignum)obj).value; + d = BigInteger.ONE; + } else if (obj instanceof Ratio) { + n = ((Ratio)obj).numerator(); + d = ((Ratio)obj).denominator(); + } else { + return error(new TypeError(obj, Symbol.NUMBER)); + } + // Invert and multiply. + BigInteger num = numerator.multiply(d); + BigInteger den = denominator.multiply(n); + BigInteger quotient = num.divide(den); + // Multiply quotient by divisor. + LispObject product = number(quotient.multiply(n), d); + // Subtract to get remainder. + LispObject remainder = subtract(product); + return LispThread.currentThread().setValues(number(quotient), remainder); + } + catch (ArithmeticException e) { + if (obj.zerop()) + return error(new DivisionByZero()); + return error(new ArithmeticError(e.getMessage())); + } + } + + @Override + public int hashCode() + { + return numerator.hashCode() ^ denominator.hashCode(); + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + int base = Fixnum.getValue(Symbol.PRINT_BASE.symbolValue(thread)); + StringBuffer sb = new StringBuffer(numerator.toString(base)); + sb.append('/'); + sb.append(denominator.toString(base)); + String s = sb.toString().toUpperCase(); + if (Symbol.PRINT_RADIX.symbolValue(thread) != NIL) { + sb.setLength(0); + switch (base) { + case 2: + sb.append("#b"); + sb.append(s); + break; + case 8: + sb.append("#o"); + sb.append(s); + break; + case 10: + sb.append("#10r"); + sb.append(s); + break; + case 16: + sb.append("#x"); + sb.append(s); + break; + default: + sb.append('#'); + sb.append(String.valueOf(base)); + sb.append('r'); + sb.append(s); + break; + } + s = sb.toString(); + } + return s; + } +} Added: branches/save-image/src/org/armedbear/lisp/ReaderError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ReaderError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,90 @@ +/* + * ReaderError.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: ReaderError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ReaderError extends StreamError +{ + public ReaderError(String message) throws ConditionThrowable + { + super(StandardClass.READER_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + } + + public ReaderError(String message, Stream stream) throws ConditionThrowable + { + super(StandardClass.READER_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + setStream(stream); + } + + public ReaderError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.READER_ERROR); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.READER_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.READER_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.READER_ERROR) + return T; + if (type == StandardClass.READER_ERROR) + return T; + if (type == Symbol.PARSE_ERROR) + return T; + if (type == StandardClass.PARSE_ERROR) + return T; + return super.typep(type); + } + + @Override + public String getMessage() + { + return message; + } +} Added: branches/save-image/src/org/armedbear/lisp/ReaderMacroFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ReaderMacroFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,75 @@ +/* + * ReaderMacroFunction.java + * + * Copyright (C) 2004 Peter Graves + * $Id: ReaderMacroFunction.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public abstract class ReaderMacroFunction extends Function +{ + public ReaderMacroFunction(String name) + { + super(name); + } + + public ReaderMacroFunction(String name, String arglist) + { + super(name, arglist); + } + + public ReaderMacroFunction(String name, Package pkg) + { + super(name, pkg); + } + + public ReaderMacroFunction(String name, Package pkg, boolean exported) + { + super(name, pkg, exported); + } + + public ReaderMacroFunction(String name, Package pkg, boolean exported, + String arglist) + { + super(name, pkg, exported, arglist); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Stream stream = inSynonymOf(first); + char c = LispCharacter.getValue(second); + return execute(stream, c); + } + + public abstract LispObject execute(Stream stream, char c) + throws ConditionThrowable; +} Added: branches/save-image/src/org/armedbear/lisp/Readtable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Readtable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,595 @@ +/* + * Readtable.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Readtable.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Readtable extends LispObject +{ + public static final byte SYNTAX_TYPE_CONSTITUENT = 0; + public static final byte SYNTAX_TYPE_WHITESPACE = 1; + public static final byte SYNTAX_TYPE_TERMINATING_MACRO = 2; + public static final byte SYNTAX_TYPE_NON_TERMINATING_MACRO = 3; + public static final byte SYNTAX_TYPE_SINGLE_ESCAPE = 4; + public static final byte SYNTAX_TYPE_MULTIPLE_ESCAPE = 5; + + protected final byte[] syntax = new byte[CHAR_MAX]; + protected final LispObject[] readerMacroFunctions = new LispObject[CHAR_MAX]; + protected final DispatchTable[] dispatchTables = new DispatchTable[CHAR_MAX]; + + protected LispObject readtableCase; + + public Readtable() + { + initialize(); + } + + protected void initialize() + { + syntax[9] = SYNTAX_TYPE_WHITESPACE; // tab + syntax[10] = SYNTAX_TYPE_WHITESPACE; // linefeed + syntax[12] = SYNTAX_TYPE_WHITESPACE; // form feed + syntax[13] = SYNTAX_TYPE_WHITESPACE; // return + syntax[' '] = SYNTAX_TYPE_WHITESPACE; + + syntax['"'] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax['\''] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax['('] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax[')'] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax[','] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax[';'] = SYNTAX_TYPE_TERMINATING_MACRO; + syntax['`'] = SYNTAX_TYPE_TERMINATING_MACRO; + + syntax['#'] = SYNTAX_TYPE_NON_TERMINATING_MACRO; + + syntax['\\'] = SYNTAX_TYPE_SINGLE_ESCAPE; + syntax['|'] = SYNTAX_TYPE_MULTIPLE_ESCAPE; + + readerMacroFunctions[';'] = LispReader.READ_COMMENT; + readerMacroFunctions['"'] = LispReader.READ_STRING; + readerMacroFunctions['('] = LispReader.READ_LIST; + readerMacroFunctions[')'] = LispReader.READ_RIGHT_PAREN; + readerMacroFunctions['\''] = LispReader.READ_QUOTE; + readerMacroFunctions['#'] = LispReader.READ_DISPATCH_CHAR; + + // BACKQUOTE-MACRO and COMMA-MACRO are defined in backquote.lisp. + readerMacroFunctions['`'] = Symbol.BACKQUOTE_MACRO; + readerMacroFunctions[','] = Symbol.COMMA_MACRO; + + DispatchTable dt = new DispatchTable(); + + dt.functions['('] = LispReader.SHARP_LEFT_PAREN; + dt.functions['*'] = LispReader.SHARP_STAR; + dt.functions['.'] = LispReader.SHARP_DOT; + dt.functions[':'] = LispReader.SHARP_COLON; + dt.functions['A'] = LispReader.SHARP_A; + dt.functions['B'] = LispReader.SHARP_B; + dt.functions['C'] = LispReader.SHARP_C; + dt.functions['O'] = LispReader.SHARP_O; + dt.functions['P'] = LispReader.SHARP_P; + dt.functions['R'] = LispReader.SHARP_R; + dt.functions['S'] = LispReader.SHARP_S; + dt.functions['X'] = LispReader.SHARP_X; + dt.functions['\''] = LispReader.SHARP_QUOTE; + dt.functions['\\'] = LispReader.SHARP_BACKSLASH; + dt.functions['|'] = LispReader.SHARP_VERTICAL_BAR; + dt.functions[')'] = LispReader.SHARP_ILLEGAL; + dt.functions['<'] = LispReader.SHARP_ILLEGAL; + dt.functions[' '] = LispReader.SHARP_ILLEGAL; + dt.functions[8] = LispReader.SHARP_ILLEGAL; // backspace + dt.functions[9] = LispReader.SHARP_ILLEGAL; // tab + dt.functions[10] = LispReader.SHARP_ILLEGAL; // newline, linefeed + dt.functions[12] = LispReader.SHARP_ILLEGAL; // page + dt.functions[13] = LispReader.SHARP_ILLEGAL; // return + + dispatchTables['#'] = dt; + + readtableCase = Keyword.UPCASE; + } + + public Readtable(LispObject obj) throws ConditionThrowable + { + Readtable rt; + if (obj == NIL) + rt = checkReadtable(STANDARD_READTABLE.symbolValue()); + else + rt = checkReadtable(obj); + synchronized (rt) + { + System.arraycopy(rt.syntax, 0, syntax, 0, CHAR_MAX); + System.arraycopy(rt.readerMacroFunctions, 0, readerMacroFunctions, 0, + CHAR_MAX); + // Deep copy. + for (int i = dispatchTables.length; i-- > 0;) + { + DispatchTable dt = rt.dispatchTables[i]; + if (dt != null) + dispatchTables[i] = new DispatchTable(dt); + } + readtableCase = rt.readtableCase; + } + } + + // FIXME synchronization + private static void copyReadtable(Readtable from, Readtable to) + { + System.arraycopy(from.syntax, 0, to.syntax, 0, CHAR_MAX); + System.arraycopy(from.readerMacroFunctions, 0, to.readerMacroFunctions, 0, + CHAR_MAX); + for (int i = from.dispatchTables.length; i-- > 0;) + { + DispatchTable dt = from.dispatchTables[i]; + if (dt != null) + to.dispatchTables[i] = new DispatchTable(dt); + else + to.dispatchTables[i] = null; + } + to.readtableCase = from.readtableCase; + } + + @Override + public LispObject typeOf() + { + return Symbol.READTABLE; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.READTABLE; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.READTABLE) + return T; + if (type == BuiltInClass.READTABLE) + return T; + return super.typep(type); + } + + @Override + public String toString() + { + return unreadableString("READTABLE"); + } + + public LispObject getReadtableCase() + { + return readtableCase; + } + + public boolean isWhitespace(char c) + { + if (c < CHAR_MAX) + return syntax[c] == SYNTAX_TYPE_WHITESPACE; + return false; + } + + public byte getSyntaxType(char c) + { + if (c < CHAR_MAX) + return syntax[c]; + return SYNTAX_TYPE_CONSTITUENT; + } + + public boolean isInvalid(char c) + { + switch (c) + { + case 8: + case 9: + case 10: + case 12: + case 13: + case 32: + case 127: + return true; + default: + return false; + } + } + + public void checkInvalid(char c, Stream stream) throws ConditionThrowable + { + // "... no mechanism is provided for changing the constituent trait of a + // character." (2.1.4.2) + if (isInvalid(c)) + { + String name = LispCharacter.charToName(c); + FastStringBuffer sb = new FastStringBuffer("Invalid character"); + if (name != null) + { + sb.append(" #\\"); + sb.append(name); + } + error(new ReaderError(sb.toString(), stream)); + } + } + + public LispObject getReaderMacroFunction(char c) + { + if (c < CHAR_MAX) + return readerMacroFunctions[c]; + else + return null; + } + + private LispObject getMacroCharacter(char c) throws ConditionThrowable + { + LispObject function = getReaderMacroFunction(c); + LispObject non_terminating_p; + if (function != null) + { + if (syntax[c] == SYNTAX_TYPE_NON_TERMINATING_MACRO) + non_terminating_p = T; + else + non_terminating_p = NIL; + } + else + { + function = NIL; + non_terminating_p = NIL; + } + return LispThread.currentThread().setValues(function, non_terminating_p); + } + + private void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) + { + byte syntaxType; + if (non_terminating_p != NIL) + syntaxType = SYNTAX_TYPE_NON_TERMINATING_MACRO; + else + syntaxType = SYNTAX_TYPE_TERMINATING_MACRO; + // FIXME synchronization + syntax[dispChar] = syntaxType; + readerMacroFunctions[dispChar] = LispReader.READ_DISPATCH_CHAR; + dispatchTables[dispChar] = new DispatchTable(); + } + + public LispObject getDispatchMacroCharacter(char dispChar, char subChar) + throws ConditionThrowable + { + DispatchTable dispatchTable = dispatchTables[dispChar]; + if (dispatchTable == null) + { + LispCharacter c = LispCharacter.getInstance(dispChar); + return error(new LispError(c.writeToString() + + " is not a dispatch character.")); + } + LispObject function = + dispatchTable.functions[LispCharacter.toUpperCase(subChar)]; + return (function != null) ? function : NIL; + } + + public void setDispatchMacroCharacter(char dispChar, char subChar, + LispObject function) + throws ConditionThrowable + { + DispatchTable dispatchTable = dispatchTables[dispChar]; + if (dispatchTable == null) + { + LispCharacter c = LispCharacter.getInstance(dispChar); + error(new LispError(c.writeToString() + + " is not a dispatch character.")); + } + dispatchTable.functions[LispCharacter.toUpperCase(subChar)] = function; + } + + protected static class DispatchTable implements java.io.Serializable + { + public LispObject[] functions = new LispObject[CHAR_MAX]; + + public DispatchTable() + { + } + + public DispatchTable(DispatchTable dt) + { + for (int i = 0; i < functions.length; i++) + functions[i] = dt.functions[i]; + } + } + + // ### readtablep + private static final Primitive READTABLEP = + new Primitive("readtablep", "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof Readtable ? T : NIL; + } + }; + + // ### copy-readtable + private static final Primitive COPY_READTABLE = + new Primitive("copy-readtable", "&optional from-readtable to-readtable") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new Readtable(currentReadtable()); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new Readtable(arg); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Readtable from = designator_readtable(first); + if (second == NIL) + return new Readtable(from); + Readtable to = checkReadtable(second); + copyReadtable(from, to); + return to; + } + }; + + // ### get-macro-character char &optional readtable + // => function, non-terminating-p + private static final Primitive GET_MACRO_CHARACTER = + new Primitive("get-macro-character", "char &optional readtable") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + char c = LispCharacter.getValue(arg); + Readtable rt = currentReadtable(); + return rt.getMacroCharacter(c); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char c = LispCharacter.getValue(first); + Readtable rt = designator_readtable(second); + return rt.getMacroCharacter(c); + } + }; + + // ### set-macro-character char new-function &optional non-terminating-p readtable + // => t + private static final Primitive SET_MACRO_CHARACTER = + new Primitive("set-macro-character", + "char new-function &optional non-terminating-p readtable") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return execute(first, second, NIL, currentReadtable()); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return execute(first, second, third, currentReadtable()); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + char c = LispCharacter.getValue(first); + final LispObject designator; + if (second instanceof Function + || second instanceof StandardGenericFunction) + designator = second; + else if (second instanceof Symbol) + designator = second; + else + return error(new LispError(second.writeToString() + + " does not designate a function.")); + byte syntaxType; + if (third != NIL) + syntaxType = SYNTAX_TYPE_NON_TERMINATING_MACRO; + else + syntaxType = SYNTAX_TYPE_TERMINATING_MACRO; + Readtable rt = designator_readtable(fourth); + // REVIEW synchronization + rt.syntax[c] = syntaxType; + rt.readerMacroFunctions[c] = designator; + return T; + } + }; + + // ### make-dispatch-macro-character char &optional non-terminating-p readtable + // => t + private static final Primitive MAKE_DISPATCH_MACRO_CHARACTER = + new Primitive("make-dispatch-macro-character", + "char &optional non-terminating-p readtable") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 1 || args.length > 3) + return error(new WrongNumberOfArgumentsException(this)); + char dispChar = LispCharacter.getValue(args[0]); + LispObject non_terminating_p; + if (args.length > 1) + non_terminating_p = args[1]; + else + non_terminating_p = NIL; + Readtable readtable; + if (args.length == 3) + readtable = checkReadtable(args[2]); + else + readtable = currentReadtable(); + readtable.makeDispatchMacroCharacter(dispChar, non_terminating_p); + return T; + } + }; + + // ### get-dispatch-macro-character disp-char sub-char &optional readtable + // => function + private static final Primitive GET_DISPATCH_MACRO_CHARACTER = + new Primitive("get-dispatch-macro-character", + "disp-char sub-char &optional readtable") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2 || args.length > 3) + return error(new WrongNumberOfArgumentsException(this)); + char dispChar = LispCharacter.getValue(args[0]); + char subChar = LispCharacter.getValue(args[1]); + Readtable readtable; + if (args.length == 3) + readtable = designator_readtable(args[2]); + else + readtable = currentReadtable(); + return readtable.getDispatchMacroCharacter(dispChar, subChar); + } + }; + + // ### set-dispatch-macro-character disp-char sub-char new-function &optional readtable + // => t + private static final Primitive SET_DISPATCH_MACRO_CHARACTER = + new Primitive("set-dispatch-macro-character", + "disp-char sub-char new-function &optional readtable") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 3 || args.length > 4) + return error(new WrongNumberOfArgumentsException(this)); + char dispChar = LispCharacter.getValue(args[0]); + char subChar = LispCharacter.getValue(args[1]); + LispObject function = coerceToFunction(args[2]); + Readtable readtable; + if (args.length == 4) + readtable = designator_readtable(args[3]); + else + readtable = currentReadtable(); + readtable.setDispatchMacroCharacter(dispChar, subChar, function); + return T; + } + }; + + // ### set-syntax-from-char to-char from-char &optional to-readtable from-readtable + // => t + private static final Primitive SET_SYNTAX_FROM_CHAR = + new Primitive("set-syntax-from-char", + "to-char from-char &optional to-readtable from-readtable") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length < 2 || args.length > 4) + return error(new WrongNumberOfArgumentsException(this)); + char toChar = LispCharacter.getValue(args[0]); + char fromChar = LispCharacter.getValue(args[1]); + Readtable toReadtable; + if (args.length > 2) + toReadtable = checkReadtable(args[2]); + else + toReadtable = currentReadtable(); + Readtable fromReadtable; + if (args.length > 3) + fromReadtable = designator_readtable(args[3]); + else + fromReadtable = checkReadtable(STANDARD_READTABLE.symbolValue()); + // REVIEW synchronization + toReadtable.syntax[toChar] = fromReadtable.syntax[fromChar]; + toReadtable.readerMacroFunctions[toChar] = + fromReadtable.readerMacroFunctions[fromChar]; + // "If the character is a dispatching macro character, its entire + // dispatch table of reader macro functions is copied." + if (fromReadtable.dispatchTables[fromChar] != null) + { + toReadtable.dispatchTables[toChar] = + new DispatchTable(fromReadtable.dispatchTables[fromChar]); + } + return T; + } + }; + + // ### readtable-case readtable => mode + private static final Primitive READTABLE_CASE = + new Primitive("readtable-case", "readtable") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Readtable)arg).readtableCase; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.READTABLE); + } + } + }; + + // ### %set-readtable-case readtable new-mode => new-mode + private static final Primitive _SET_READTABLE_CASE = + new Primitive("%set-readtable-case", PACKAGE_SYS, false, + "readtable new-mode") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + Readtable readtable = (Readtable) first; + if (second == Keyword.UPCASE || second == Keyword.DOWNCASE || + second == Keyword.INVERT || second == Keyword.PRESERVE) + { + readtable.readtableCase = second; + return second; + } + return type_error(second, list5(Symbol.MEMBER, + Keyword.INVERT, + Keyword.PRESERVE, + Keyword.DOWNCASE, + Keyword.UPCASE)); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.READTABLE); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Return.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Return.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,85 @@ +/* + * Return.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Return.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Return extends ConditionThrowable +{ + public final LispObject tag; + public final LispObject block; + public final LispObject result; + + public Return(LispObject tag, LispObject block, LispObject result) + { + this.tag = tag; + this.block = block; + this.result = result; + } + + public Return(LispObject tag, LispObject result) + { + this.tag = tag; + this.block = null; + this.result = result; + } + + public LispObject getTag() + { + return tag; + } + + public LispObject getBlock() + { + return block; + } + + public LispObject getResult() + { + return result; + } + + @Override + public LispObject getCondition() throws ConditionThrowable + { + try { + FastStringBuffer sb = new FastStringBuffer("No block named "); + sb.append(tag.writeToString()); + sb.append(" is currently visible."); + return new ControlError(sb.toString()); + } + catch (Throwable t) { + Debug.trace(t); + return new Condition(); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/RuntimeClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/RuntimeClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,196 @@ +/* + * RuntimeClass.java + * + * Copyright (C) 2004 Peter Graves + * $Id: RuntimeClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.util.Map; +import java.util.HashMap; + +public class RuntimeClass extends Lisp +{ + private static Map classes = new HashMap(); + + private Map methods = new HashMap(); + + // ### %jnew-runtime-class + // %jnew-runtime-class class-name &rest method-names-and-defs + private static final Primitive _JNEW_RUNTIME_CLASS = + new Primitive("%jnew-runtime-class", PACKAGE_JAVA, false, "class-name &rest method-names-and-defs") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length < 3 || length % 2 != 1) + return error(new WrongNumberOfArgumentsException(this)); + RuntimeClass rc = new RuntimeClass(); + String className = args[0].getStringValue(); + for (int i = 1; i < length; i = i+2) { + String methodName = args[i].getStringValue(); + rc.addLispMethod(methodName, (Function)args[i+1]); + } + classes.put(className, rc); + return T; + } + }; + + // ### jredefine-method + // %jredefine-method class-name method-name method-def + private static final Primitive _JREDEFINE_METHOD = + new Primitive("%jredefine-method", PACKAGE_JAVA, false, + "class-name method-name method-def") + { + @Override + public LispObject execute(LispObject className, LispObject methodName, + LispObject methodDef) + throws ConditionThrowable + { + + String cn = className.getStringValue(); + String mn = methodName.getStringValue(); + Function def = (Function) methodDef; + RuntimeClass rc = null; + if (classes.containsKey(cn)) { + rc = (RuntimeClass) classes.get(cn); + rc.addLispMethod(mn, def); + return T; + } + else { + error(new LispError("undefined Java class: " + cn)); + return NIL; + } + } + }; + + // ### %load-java-class-from-byte-array + private static final Primitive _LOAD_JAVA_CLASS_FROM_BYTE_ARRAY = + new Primitive("%load-java-class-from-byte-array", PACKAGE_JAVA, false, + "classname bytearray") + { + @Override + public LispObject execute(LispObject className, LispObject classBytes) + throws ConditionThrowable + { + String cn = className.getStringValue(); + String pn = cn.substring(0,cn.lastIndexOf('.')); + byte[] cb = (byte[]) classBytes.javaInstance(); + try { + JavaClassLoader loader = JavaClassLoader.getPersistentInstance(pn); + Class c = loader.loadClassFromByteArray(cn, cb); + if (c != null) { + return T; + } + } + catch (VerifyError e) { + return error(new LispError("class verification failed: " + + e.getMessage())); + } + catch (LinkageError e) { + return error(new LispError("class could not be linked: " + + e.getMessage())); + } + catch (Throwable t) { + Debug.trace(t); + } + return error( + new LispError("unable to load ".concat(cn))); + } + }; + + public static final LispObject evalC(LispObject function, + LispObject args, + Environment env, + LispThread thread) + throws ConditionThrowable + { + return evalCall(function, args, env, thread); + } + + public static RuntimeClass getRuntimeClass(String className) { + return (RuntimeClass) classes.get(className); + } + + public Function getLispMethod(String methodName) { + return (Function) methods.get(methodName); + } + + private void addLispMethod(String methodName, Function def) { + methods.put(methodName, def); + } + + public static final LispObject makeLispObject(Object obj) throws ConditionThrowable + { + return new JavaObject(obj); + } + + public static final Fixnum makeLispObject(byte i) throws ConditionThrowable + { + return new Fixnum(i); + } + + public static final Fixnum makeLispObject(short i) throws ConditionThrowable + { + return new Fixnum(i); + } + + public static final Fixnum makeLispObject(int i) throws ConditionThrowable + { + return new Fixnum(i); + } + + public static final Bignum makeLispObject(long i) throws ConditionThrowable + { + return new Bignum(i); + } + + public static final SingleFloat makeLispObject(float i) throws ConditionThrowable + { + return new SingleFloat(i); + } + + public static final DoubleFloat makeLispObject(double i) throws ConditionThrowable + { + return new DoubleFloat(i); + } + + public static final LispCharacter makeLispObject(char i) throws ConditionThrowable + { + return LispCharacter.getInstance(i); + } + + public static final LispObject makeLispObject(boolean i) throws ConditionThrowable + { + return i ? T : NIL; + } +} Added: branches/save-image/src/org/armedbear/lisp/SeriousCondition.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SeriousCondition.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,84 @@ +/* + * SeriousCondition.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: SeriousCondition.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class SeriousCondition extends Condition +{ + public SeriousCondition() throws ConditionThrowable + { + } + + protected SeriousCondition(LispClass cls) throws ConditionThrowable + { + super(cls); + } + + public SeriousCondition(LispObject initArgs) throws ConditionThrowable + { + super(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + } + + public SeriousCondition(String message) + { + super(message); + } + + @Override + public LispObject typeOf() + { + return Symbol.SERIOUS_CONDITION; + } + + @Override + public LispObject classOf() + { + return StandardClass.SERIOUS_CONDITION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SERIOUS_CONDITION) + return T; + if (type == StandardClass.SERIOUS_CONDITION) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/ShellCommand.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ShellCommand.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,273 @@ +/* + * ShellCommand.java + * + * Copyright (C) 2000-2005 Peter Graves + * $Id: ShellCommand.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStream; +import java.io.InputStreamReader; +import java.util.ArrayList; +import java.util.List; + +public final class ShellCommand extends Lisp implements Runnable +{ + private final String command; + private final String directory; + private final Stream outputStream; + private final StringBuffer output; + + private int exitValue = -1; + + public ShellCommand(String command, String directory, Stream outputStream) + throws ConditionThrowable + { + this.command = command; + this.directory = directory; + this.outputStream = outputStream; + this.output = (outputStream == null) ? new StringBuffer() : null; + } + + public final String getOutput() + { + return (output != null) ? output.toString() : ""; + } + + private final int exitValue() + { + return exitValue; + } + + private void processOutput(String s) throws ConditionThrowable + { + if (outputStream != null) + outputStream._writeString(s); + else + output.append(s); + } + + public void run() + { + Process process = null; + try { + if (command != null) { + if (Utilities.isPlatformUnix) { + if (directory != null) { + FastStringBuffer sb = new FastStringBuffer("\\cd \""); + sb.append(directory); + sb.append("\" && "); + sb.append(command); + String[] cmdarray = {"/bin/sh", "-c", sb.toString()}; + process = Runtime.getRuntime().exec(cmdarray); + } else { + String[] cmdarray = {"/bin/sh", "-c", command}; + process = Runtime.getRuntime().exec(cmdarray); + } + } else if (Utilities.isPlatformWindows) { + ArrayList list = new ArrayList(); + list.add("cmd.exe"); + list.add("/c"); + if (directory != null) { + FastStringBuffer sb = new FastStringBuffer("cd /d \""); + sb.append(directory); + sb.append("\" && "); + sb.append(command); + list.addAll(tokenize(sb.toString())); + } else + list.addAll(tokenize(command)); + final int size = list.size(); + String[] cmdarray = new String[size]; + for (int i = 0; i < size; i++) + cmdarray[i] = (String) list.get(i); + process = Runtime.getRuntime().exec(cmdarray); + } + } + } + catch (IOException e) { + Debug.trace(e); + } + if (process != null) { + ReaderThread stdoutThread = + new ReaderThread(process.getInputStream()); + stdoutThread.start(); + ReaderThread stderrThread = + new ReaderThread(process.getErrorStream()); + stderrThread.start(); + try { + exitValue = process.waitFor(); + } + catch (InterruptedException e) { + Debug.trace(e); + } + try { + stdoutThread.join(); + } + catch (InterruptedException e) { + Debug.trace(e); + } + try { + stderrThread.join(); + } + catch (InterruptedException e) { + Debug.trace(e); + } + } + } + + // Does not handle embedded single-quoted strings. + private static List tokenize(String s) + { + ArrayList list = new ArrayList(); + StringBuffer sb = new StringBuffer(); + boolean inQuote = false; + final int limit = s.length(); + for (int i = 0; i < limit; i++) { + char c = s.charAt(i); + switch (c) { + case ' ': + if (inQuote) + sb.append(c); + else if (sb.length() > 0) { + list.add(sb.toString()); + sb.setLength(0); + } + break; + case '"': + if (inQuote) { + if (sb.length() > 0) { + list.add(sb.toString()); + sb.setLength(0); + } + inQuote = false; + } else + inQuote = true; + break; + default: + sb.append(c); + break; + } + } + if (sb.length() > 0) + list.add(sb.toString()); + return list; + } + + private class ReaderThread extends Thread + { + private char[] buf = new char[4096]; + private final InputStream inputStream; + private final BufferedReader reader; + private boolean done = false; + + public ReaderThread(InputStream inputStream) + { + this.inputStream = inputStream; + reader = new BufferedReader(new InputStreamReader(inputStream)); + } + + @Override + public void run() + { + while (!done) { + String s = read(); + if (s == null) + return; + try { + processOutput(s); + } + catch (Throwable t) { + Debug.trace(t); + } + } + } + + private String read() + { + StringBuffer sb = new StringBuffer(); + try { + do { + int numChars = reader.read(buf, 0, buf.length); // Blocks. + if (numChars < 0) { + done = true; + break; + } + if (numChars > 0) + sb.append(buf, 0, numChars); + Thread.sleep(10); + } while (reader.ready()); + } + catch (IOException e) { + return null; + } + catch (InterruptedException e) { + return null; + } + catch (Throwable t) { + return null; + } + return sb.toString(); + } + } + + // run-shell-command command &key directory (output *standard-output*) + // ### %run-shell-command command directory output => exit-code + private static final Primitive _RUN_SHELL_COMMAND = + new Primitive("%run-shell-command", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + String command = first.getStringValue(); + String namestring = null; + Stream outputStream = null; + if (second != NIL) { + Pathname pathname = coerceToPathname(second); + namestring = pathname.getNamestring(); + if (namestring == null) { + return error(new FileError("Pathname has no namestring: " + pathname.writeToString(), + pathname)); + } + } + if (third != NIL) + outputStream = checkStream(third); + ShellCommand shellCommand = new ShellCommand(command, namestring, + outputStream); + shellCommand.run(); + if (outputStream != null) + outputStream._finishOutput(); + return number(shellCommand.exitValue()); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SimpleArray_T.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleArray_T.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,386 @@ +/* + * SimpleArray_T.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: SimpleArray_T.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleArray_T extends AbstractArray +{ + private final int[] dimv; + private final LispObject elementType; + private final int totalSize; + final LispObject[] data; + + public SimpleArray_T(int[] dimv, LispObject elementType) + { + this.dimv = dimv; + this.elementType = elementType; + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + for (int i = totalSize; i-- > 0;) + data[i] = Fixnum.ZERO; + } + + public SimpleArray_T(int[] dimv, + LispObject elementType, + LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + this.elementType = elementType; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) + { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public SimpleArray_T(int rank, LispObject initialContents) + throws ConditionThrowable + { + if (rank < 2) + Debug.assertTrue(false); + dimv = new int[rank]; + this.elementType = T; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) + { + dimv[i] = rest.length(); + if (rest == NIL || rest.length() == 0) + break; + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public SimpleArray_T(final int[] dimv, final LispObject[] initialData, + final LispObject elementType) { + this.dimv = dimv; + this.elementType = elementType; + this.data = initialData; + this.totalSize = computeTotalSize(dimv); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) + { + try + { + data[index] = contents; + } + catch (ArrayIndexOutOfBoundsException e) + { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } + else + { + int dim = dims[0]; + if (dim != contents.length()) + { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) + { + for (int i = contents.length();i-- > 0;) + { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } + else + { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) + { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, elementType, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_ARRAY; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.SIMPLE_ARRAY) + return T; + if (typeSpecifier == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(typeSpecifier); + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try + { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) + { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return elementType; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try + { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + try + { + data[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) + { + error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public int getRowMajorIndex(int[] subscripts) throws ConditionThrowable + { + final int rank = dimv.length; + if (rank != subscripts.length) + { + FastStringBuffer sb = new FastStringBuffer("Wrong number of subscripts ("); + sb.append(subscripts.length); + sb.append(") for array of rank "); + sb.append(rank); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + int sum = 0; + int size = 1; + for (int i = rank; i-- > 0;) + { + final int dim = dimv[i]; + final int lastSize = size; + size *= dim; + int n = subscripts[i]; + if (n < 0 || n >= dim) + { + FastStringBuffer sb = new FastStringBuffer("Invalid index "); + sb.append(n); + sb.append(" for array "); + sb.append(this); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + sum += n * lastSize; + } + return sum; + } + + @Override + public LispObject get(int[] subscripts) throws ConditionThrowable + { + try + { + return data[getRowMajorIndex(subscripts)]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void set(int[] subscripts, LispObject newValue) + throws ConditionThrowable + { + try + { + data[getRowMajorIndex(subscripts)] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) + { + error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void fill(LispObject obj) + { + for (int i = totalSize; i-- > 0;) + data[i] = obj; + } + + @Override + public String writeToString() throws ConditionThrowable + { + return writeToString(dimv); + } + + @Override + public AbstractArray adjustArray(int[] dimv, LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + return new SimpleArray_T(dimv, elementType, initialContents); + for (int i = 0; i < dimv.length; i++) + { + if (dimv[i] != this.dimv[i]) + { + SimpleArray_T newArray = new SimpleArray_T(dimv, elementType); + if (initialElement != null) + newArray.fill(initialElement); + copyArray(this, newArray); + return newArray; + } + } + // New dimensions are identical to old dimensions, yet + // we're not mutable, so, we need to return a new array + return new SimpleArray_T(dimv, data.clone(), elementType); + } + + // Copy a1 to a2 for index tuples that are valid for both arrays. + static void copyArray(AbstractArray a1, AbstractArray a2) + throws ConditionThrowable + { + Debug.assertTrue(a1.getRank() == a2.getRank()); + int[] subscripts = new int[a1.getRank()]; + int axis = 0; + copySubArray(a1, a2, subscripts, axis); + } + + private static void copySubArray(AbstractArray a1, AbstractArray a2, + int[] subscripts, int axis) + throws ConditionThrowable + { + if (axis < subscripts.length) + { + final int limit = + Math.min(a1.getDimension(axis), a2.getDimension(axis)); + for (int i = 0; i < limit; i++) + { + subscripts[axis] = i; + copySubArray(a1, a2, subscripts, axis + 1); + } + } + else + { + int i1 = a1.getRowMajorIndex(subscripts); + int i2 = a2.getRowMajorIndex(subscripts); + a2.aset(i2, a1.AREF(i1)); + } + } + + @Override + public AbstractArray adjustArray(int[] dimv, AbstractArray displacedTo, + int displacement) + { + return new ComplexArray(dimv, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte16.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,355 @@ +/* + * SimpleArray_UnsignedByte16.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SimpleArray_UnsignedByte16.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleArray_UnsignedByte16 extends AbstractArray +{ + private final int[] dimv; + private final int totalSize; + private final int[] data; + + public SimpleArray_UnsignedByte16(int[] dimv) + { + this.dimv = dimv; + totalSize = computeTotalSize(dimv); + data = new int[totalSize]; + } + + public SimpleArray_UnsignedByte16(int[] dimv, LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new int[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public SimpleArray_UnsignedByte16(int rank, LispObject initialContents) + throws ConditionThrowable + { + if (rank < 2) + Debug.assertTrue(false); + dimv = new int[rank]; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + if (rest == NIL || rest.length() == 0) + break; + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new int[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) { + try { + data[index] = coerceLispObjectToJavaByte(contents); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } else { + int dim = dims[0]; + if (dim != contents.length()) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) { + for (int i = contents.length();i-- > 0;) { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } else { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, UNSIGNED_BYTE_16, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_ARRAY; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.SIMPLE_ARRAY) + return T; + if (typeSpecifier == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(typeSpecifier); + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_16; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public int aref(int index) throws ConditionThrowable + { + try { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + // Not reached. + return 0; + } + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try { + return new Fixnum(data[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public void aset(int index, LispObject obj) throws ConditionThrowable + { + try { + data[index] = Fixnum.getValue(obj); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public int getRowMajorIndex(int[] subscripts) throws ConditionThrowable + { + final int rank = dimv.length; + if (rank != subscripts.length) { + StringBuffer sb = new StringBuffer("Wrong number of subscripts ("); + sb.append(subscripts.length); + sb.append(") for array of rank "); + sb.append(rank); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + int sum = 0; + int size = 1; + for (int i = rank; i-- > 0;) { + final int dim = dimv[i]; + final int lastSize = size; + size *= dim; + int n = subscripts[i]; + if (n < 0 || n >= dim) { + StringBuffer sb = new StringBuffer("Invalid index "); + sb.append(n); + sb.append(" for array "); + sb.append(this); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + sum += n * lastSize; + } + return sum; + } + + @Override + public LispObject get(int[] subscripts) throws ConditionThrowable + { + try { + return new Fixnum(data[getRowMajorIndex(subscripts)]); + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void set(int[] subscripts, LispObject obj) + throws ConditionThrowable + { + try { + data[getRowMajorIndex(subscripts)] = Fixnum.getValue(obj); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + int n = Fixnum.getValue(obj); + for (int i = totalSize; i-- > 0;) + data[i] = n; + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (Symbol.PRINT_READABLY.symbolValue() != NIL) { + error(new PrintNotReadable(list2(Keyword.OBJECT, this))); + // Not reached. + return null; + } + return writeToString(dimv); + } + + public AbstractArray adjustArray(int[] dimv, LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + return new SimpleArray_UnsignedByte16(dimv, initialContents); + for (int i = 0; i < dimv.length; i++) { + if (dimv[i] != this.dimv[i]) { + SimpleArray_UnsignedByte16 newArray = + new SimpleArray_UnsignedByte16(dimv); + if (initialElement != null) + newArray.fill(initialElement); + copyArray(this, newArray); + return newArray; + } + } + // New dimensions are identical to old dimensions. + return this; + } + + // Copy a1 to a2 for index tuples that are valid for both arrays. + private static void copyArray(AbstractArray a1, AbstractArray a2) + throws ConditionThrowable + { + Debug.assertTrue(a1.getRank() == a2.getRank()); + int[] subscripts = new int[a1.getRank()]; + int axis = 0; + copySubArray(a1, a2, subscripts, axis); + } + + private static void copySubArray(AbstractArray a1, AbstractArray a2, + int[] subscripts, int axis) + throws ConditionThrowable + { + if (axis < subscripts.length) { + final int limit = + Math.min(a1.getDimension(axis), a2.getDimension(axis)); + for (int i = 0; i < limit; i++) { + subscripts[axis] = i; + copySubArray(a1, a2, subscripts, axis + 1); + } + } else { + int i1 = a1.getRowMajorIndex(subscripts); + int i2 = a2.getRowMajorIndex(subscripts); + a2.aset(i2, a1.AREF(i1)); + } + } + + public AbstractArray adjustArray(int[] dimv, AbstractArray displacedTo, + int displacement) + { + return new ComplexArray(dimv, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte32.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,345 @@ +/* + * SimpleArray_UnsignedByte32.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SimpleArray_UnsignedByte32.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleArray_UnsignedByte32 extends AbstractArray +{ + private final int[] dimv; + private final int totalSize; + + // FIXME We should really use an array of unboxed values! + final LispObject[] data; + + public SimpleArray_UnsignedByte32(int[] dimv) + { + this.dimv = dimv; + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + for (int i = totalSize; i-- > 0;) + data[i] = Fixnum.ZERO; + } + + public SimpleArray_UnsignedByte32(int[] dimv, LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public SimpleArray_UnsignedByte32(int rank, LispObject initialContents) + throws ConditionThrowable + { + if (rank < 2) + Debug.assertTrue(false); + dimv = new int[rank]; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + if (rest == NIL || rest.length() == 0) + break; + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new LispObject[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) { + try { + data[index] = contents; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } else { + int dim = dims[0]; + if (dim != contents.length()) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) { + for (int i = contents.length();i-- > 0;) { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } else { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, UNSIGNED_BYTE_32, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_ARRAY; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.SIMPLE_ARRAY) + return T; + if (typeSpecifier == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(typeSpecifier); + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_32; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + try { + data[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public int getRowMajorIndex(int[] subscripts) throws ConditionThrowable + { + final int rank = dimv.length; + if (rank != subscripts.length) { + StringBuffer sb = new StringBuffer("Wrong number of subscripts ("); + sb.append(subscripts.length); + sb.append(") for array of rank "); + sb.append(rank); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + int sum = 0; + int size = 1; + for (int i = rank; i-- > 0;) { + final int dim = dimv[i]; + final int lastSize = size; + size *= dim; + int n = subscripts[i]; + if (n < 0 || n >= dim) { + StringBuffer sb = new StringBuffer("Invalid index "); + sb.append(n); + sb.append(" for array "); + sb.append(this); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + sum += n * lastSize; + } + return sum; + } + + @Override + public LispObject get(int[] subscripts) throws ConditionThrowable + { + try { + return data[getRowMajorIndex(subscripts)]; + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void set(int[] subscripts, LispObject newValue) + throws ConditionThrowable + { + try { + data[getRowMajorIndex(subscripts)] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void fill(LispObject obj) + { + for (int i = totalSize; i-- > 0;) + data[i] = obj; + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (Symbol.PRINT_READABLY.symbolValue() != NIL) { + error(new PrintNotReadable(list2(Keyword.OBJECT, this))); + // Not reached. + return null; + } + return writeToString(dimv); + } + + public AbstractArray adjustArray(int[] dimv, LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + return new SimpleArray_UnsignedByte32(dimv, initialContents); + for (int i = 0; i < dimv.length; i++) { + if (dimv[i] != this.dimv[i]) { + SimpleArray_UnsignedByte32 newArray = + new SimpleArray_UnsignedByte32(dimv); + if (initialElement != null) + newArray.fill(initialElement); + copyArray(this, newArray); + return newArray; + } + } + // New dimensions are identical to old dimensions. + return this; + } + + // Copy a1 to a2 for index tuples that are valid for both arrays. + static void copyArray(AbstractArray a1, AbstractArray a2) + throws ConditionThrowable + { + Debug.assertTrue(a1.getRank() == a2.getRank()); + int[] subscripts = new int[a1.getRank()]; + int axis = 0; + copySubArray(a1, a2, subscripts, axis); + } + + private static void copySubArray(AbstractArray a1, AbstractArray a2, + int[] subscripts, int axis) + throws ConditionThrowable + { + if (axis < subscripts.length) { + final int limit = + Math.min(a1.getDimension(axis), a2.getDimension(axis)); + for (int i = 0; i < limit; i++) { + subscripts[axis] = i; + copySubArray(a1, a2, subscripts, axis + 1); + } + } else { + int i1 = a1.getRowMajorIndex(subscripts); + int i2 = a2.getRowMajorIndex(subscripts); + a2.aset(i2, a1.AREF(i1)); + } + } + + public AbstractArray adjustArray(int[] dimv, AbstractArray displacedTo, + int displacement) + { + return new ComplexArray(dimv, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleArray_UnsignedByte8.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,342 @@ +/* + * SimpleArray_UnsignedByte8.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SimpleArray_UnsignedByte8.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleArray_UnsignedByte8 extends AbstractArray +{ + private final int[] dimv; + private final int totalSize; + final byte[] data; + + public SimpleArray_UnsignedByte8(int[] dimv) + { + this.dimv = dimv; + totalSize = computeTotalSize(dimv); + data = new byte[totalSize]; + } + + public SimpleArray_UnsignedByte8(int[] dimv, LispObject initialContents) + throws ConditionThrowable + { + this.dimv = dimv; + final int rank = dimv.length; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new byte[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + public SimpleArray_UnsignedByte8(int rank, LispObject initialContents) + throws ConditionThrowable + { + if (rank < 2) + Debug.assertTrue(false); + dimv = new int[rank]; + LispObject rest = initialContents; + for (int i = 0; i < rank; i++) { + dimv[i] = rest.length(); + if (rest == NIL || rest.length() == 0) + break; + rest = rest.elt(0); + } + totalSize = computeTotalSize(dimv); + data = new byte[totalSize]; + setInitialContents(0, dimv, initialContents, 0); + } + + private int setInitialContents(int axis, int[] dims, LispObject contents, + int index) + throws ConditionThrowable + { + if (dims.length == 0) { + try { + data[index] = coerceLispObjectToJavaByte(contents); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + ++index; + } else { + int dim = dims[0]; + if (dim != contents.length()) { + error(new LispError("Bad initial contents for array.")); + return -1; + } + int[] newDims = new int[dims.length-1]; + for (int i = 1; i < dims.length; i++) + newDims[i-1] = dims[i]; + if (contents.listp()) { + for (int i = contents.length();i-- > 0;) { + LispObject content = contents.car(); + index = + setInitialContents(axis + 1, newDims, content, index); + contents = contents.cdr(); + } + } else { + AbstractVector v = checkVector(contents); + final int length = v.length(); + for (int i = 0; i < length; i++) { + LispObject content = v.AREF(i); + index = + setInitialContents(axis + 1, newDims, content, index); + } + } + } + return index; + } + + @Override + public LispObject typeOf() + { + return list3(Symbol.SIMPLE_ARRAY, UNSIGNED_BYTE_8, getDimensions()); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_ARRAY; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.SIMPLE_ARRAY) + return T; + if (typeSpecifier == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(typeSpecifier); + } + + @Override + public int getRank() + { + return dimv.length; + } + + @Override + public LispObject getDimensions() + { + LispObject result = NIL; + for (int i = dimv.length; i-- > 0;) + result = new Cons(new Fixnum(dimv[i]), result); + return result; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + try { + return dimv[n]; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad array dimension " + n + ".")); + return -1; + } + } + + @Override + public LispObject getElementType() + { + return UNSIGNED_BYTE_8; + } + + @Override + public int getTotalSize() + { + return totalSize; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try { + return coerceJavaByteToLispObject(data[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + try { + data[index] = coerceLispObjectToJavaByte(newValue); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + index + ".")); + } + } + + @Override + public int getRowMajorIndex(int[] subscripts) throws ConditionThrowable + { + final int rank = dimv.length; + if (rank != subscripts.length) { + StringBuffer sb = new StringBuffer("Wrong number of subscripts ("); + sb.append(subscripts.length); + sb.append(") for array of rank "); + sb.append(rank); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + int sum = 0; + int size = 1; + for (int i = rank; i-- > 0;) { + final int dim = dimv[i]; + final int lastSize = size; + size *= dim; + int n = subscripts[i]; + if (n < 0 || n >= dim) { + StringBuffer sb = new StringBuffer("Invalid index "); + sb.append(n); + sb.append(" for array "); + sb.append(this); + sb.append('.'); + error(new ProgramError(sb.toString())); + } + sum += n * lastSize; + } + return sum; + } + + @Override + public LispObject get(int[] subscripts) throws ConditionThrowable + { + try { + return coerceJavaByteToLispObject(data[getRowMajorIndex(subscripts)]); + } + catch (ArrayIndexOutOfBoundsException e) { + return error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void set(int[] subscripts, LispObject newValue) + throws ConditionThrowable + { + try { + data[getRowMajorIndex(subscripts)] = coerceLispObjectToJavaByte(newValue); + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Bad row major index " + + getRowMajorIndex(subscripts) + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + byte b = coerceLispObjectToJavaByte(obj); + for (int i = totalSize; i-- > 0;) + data[i] = b; + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (Symbol.PRINT_READABLY.symbolValue() != NIL) { + error(new PrintNotReadable(list2(Keyword.OBJECT, this))); + // Not reached. + return null; + } + return writeToString(dimv); + } + + public AbstractArray adjustArray(int[] dimv, LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + return new SimpleArray_UnsignedByte8(dimv, initialContents); + for (int i = 0; i < dimv.length; i++) { + if (dimv[i] != this.dimv[i]) { + SimpleArray_UnsignedByte8 newArray = + new SimpleArray_UnsignedByte8(dimv); + if (initialElement != null) + newArray.fill(initialElement); + copyArray(this, newArray); + return newArray; + } + } + // New dimensions are identical to old dimensions. + return this; + } + + // Copy a1 to a2 for index tuples that are valid for both arrays. + static void copyArray(AbstractArray a1, AbstractArray a2) + throws ConditionThrowable + { + Debug.assertTrue(a1.getRank() == a2.getRank()); + int[] subscripts = new int[a1.getRank()]; + int axis = 0; + copySubArray(a1, a2, subscripts, axis); + } + + private static void copySubArray(AbstractArray a1, AbstractArray a2, + int[] subscripts, int axis) + throws ConditionThrowable + { + if (axis < subscripts.length) { + final int limit = + Math.min(a1.getDimension(axis), a2.getDimension(axis)); + for (int i = 0; i < limit; i++) { + subscripts[axis] = i; + copySubArray(a1, a2, subscripts, axis + 1); + } + } else { + int i1 = a1.getRowMajorIndex(subscripts); + int i2 = a2.getRowMajorIndex(subscripts); + a2.aset(i2, a1.AREF(i1)); + } + } + + public AbstractArray adjustArray(int[] dimv, AbstractArray displacedTo, + int displacement) + { + return new ComplexArray(dimv, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleBitVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleBitVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,509 @@ +/* + * SimpleBitVector.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: SimpleBitVector.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// "The type of a bit vector that is not displaced to another array, has no +// fill pointer, and is not expressly adjustable is a subtype of type SIMPLE- +// BIT-VECTOR." +public final class SimpleBitVector extends AbstractBitVector +{ + public SimpleBitVector(int capacity) + { + this.capacity = capacity; + int size = capacity >>> 6; // 64 bits in a long + // If the capacity is not an integral multiple of 64, we'll need one + // more long. + if ((capacity & LONG_MASK) != 0) + ++size; + bits = new long[size]; + } + + public SimpleBitVector(String s) throws ConditionThrowable + { + this(s.length()); + for (int i = capacity; i-- > 0;) { + char c = s.charAt(i); + if (c == '0') { + } else if (c == '1') + setBit(i); + else + Debug.assertTrue(false); + } + } + + @Override + public LispObject typeOf() + { + return list2(Symbol.SIMPLE_BIT_VECTOR, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_BIT_VECTOR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_BIT_VECTOR) + return T; + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.SIMPLE_BIT_VECTOR) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(type); + } + + @Override + public boolean hasFillPointer() + { + return false; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public boolean isSimpleVector() + { + return true; + } + + @Override + public int length() + { + return capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + if (index < 0 || index >= length()) + badIndex(index, length()); + int offset = index >> 6; // Divide by 64. + return (bits[offset] & (1L << (index & LONG_MASK))) != 0 ? Fixnum.ONE : Fixnum.ZERO; + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (index < 0 || index >= capacity) + badIndex(index, capacity); + int offset = index >> 6; + return (bits[offset] & (1L << (index & LONG_MASK))) != 0 ? Fixnum.ONE : Fixnum.ZERO; + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + if (index < 0 || index >= capacity) + badIndex(index, capacity); + final int offset = index >> 6; + try { + switch (((Fixnum)newValue).value) { + case 0: + bits[offset] &= ~(1L << (index & LONG_MASK)); + return; + case 1: + bits[offset] |= 1L << (index & LONG_MASK); + return; + } + } + catch (ClassCastException e) { + // Fall through... + } + error(new TypeError(newValue, Symbol.BIT)); + } + + @Override + protected int getBit(int index) + { + int offset = index >> 6; + return (bits[offset] & (1L << (index & LONG_MASK))) != 0 ? 1 : 0; + } + + @Override + protected void setBit(int index) + { + int offset = index >> 6; + bits[offset] |= 1L << (index & LONG_MASK); + } + + @Override + protected void clearBit(int index) + { + int offset = index >> 6; + bits[offset] &= ~(1L << (index & LONG_MASK)); + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (n < capacity) { + int size = n >>> 6; + if ((n & LONG_MASK) != 0) + ++size; + if (size < bits.length) { + long[] newbits = new long[size]; + System.arraycopy(bits, 0, newbits, 0, size); + bits = newbits; + } + capacity = n; + return; + } + if (n == capacity) + return; + error(new LispError()); + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) { + SimpleBitVector v = new SimpleBitVector(newCapacity); + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + v.aset(i, list.car()); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + v.aset(i, initialContents.elt(i)); + } else + error(new TypeError(initialContents, Symbol.SEQUENCE)); + return v; + } + if (capacity != newCapacity) { + SimpleBitVector v = new SimpleBitVector(newCapacity); + final int limit = Math.min(capacity, newCapacity); + for (int i = limit; i-- > 0;) { + if (getBit(i) == 1) + v.setBit(i); + else + v.clearBit(i); + } + if (initialElement != null && capacity < newCapacity) { + int n = Fixnum.getValue(initialElement); + if (n == 1) + for (int i = capacity; i < newCapacity; i++) + v.setBit(i); + else + for (int i = capacity; i < newCapacity; i++) + v.clearBit(i); + } + return v; + } + // No change. + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + return new ComplexBitVector(newCapacity, displacedTo, displacement); + } + + private SimpleBitVector and(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = bits[i] & v.bits[i]; + return result; + } + + private SimpleBitVector ior(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = bits[i] | v.bits[i]; + return result; + } + + private SimpleBitVector xor(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = bits[i] ^ v.bits[i]; + return result; + } + + private SimpleBitVector eqv(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = ~(bits[i] ^ v.bits[i]); + return result; + } + + private SimpleBitVector nand(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = ~(bits[i] & v.bits[i]); + return result; + } + + private SimpleBitVector nor(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = ~(bits[i] | v.bits[i]); + return result; + } + + private SimpleBitVector andc1(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = ~bits[i] & v.bits[i]; + return result; + } + + private SimpleBitVector andc2(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = bits[i] & ~v.bits[i]; + return result; + } + + private SimpleBitVector orc1(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = ~bits[i] | v.bits[i]; + return result; + } + + private SimpleBitVector orc2(SimpleBitVector v, SimpleBitVector result) + { + if (result == null) + result = new SimpleBitVector(capacity); + for (int i = bits.length; i-- > 0;) + result.bits[i] = bits[i] | ~v.bits[i]; + return result; + } + + // ### %simple-bit-vector-bit-and + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_AND = + new Primitive("%simple-bit-vector-bit-and", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).and((SimpleBitVector)second, + ((SimpleBitVector)third)); + } + }; + + // ### %simple-bit-vector-bit-ior + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_IOR = + new Primitive("%simple-bit-vector-bit-ior", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).ior((SimpleBitVector)second, + (SimpleBitVector)third); + + } + }; + + // ### %simple-bit-vector-bit-xor + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_XOR = + new Primitive("%simple-bit-vector-bit-xor", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).xor((SimpleBitVector)second, + (SimpleBitVector)third); + + } + }; + + // ### %simple-bit-vector-bit-eqv + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_EQV = + new Primitive("%simple-bit-vector-bit-eqv", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).eqv((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + // ### %simple-bit-vector-bit-nand + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_NAND = + new Primitive("%simple-bit-vector-bit-nand", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).nand((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + // ### %simple-bit-vector-bit-nor + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_NOR = + new Primitive("%simple-bit-vector-bit-nor", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).nor((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + // ### %simple-bit-vector-bit-andc1 + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_ANDC1 = + new Primitive("%simple-bit-vector-bit-andc1", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).andc1((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + // ### %simple-bit-vector-bit-andc2 + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_ANDC2 = + new Primitive("%simple-bit-vector-bit-andc2", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).andc2((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + + // ### %simple-bit-vector-bit-orc1 + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_ORC1 = + new Primitive("%simple-bit-vector-bit-orc1", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).orc1((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + // ### %simple-bit-vector-bit-orc2 + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_ORC2 = + new Primitive("%simple-bit-vector-bit-orc2", PACKAGE_SYS, false, + "bit-vector1 bit-vector2 result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return ((SimpleBitVector)first).orc2((SimpleBitVector)second, + (SimpleBitVector)third); + } + }; + + // ### %simple-bit-vector-bit-not + private static final Primitive _SIMPLE_BIT_VECTOR_BIT_NOT = + new Primitive("%simple-bit-vector-bit-not", PACKAGE_SYS, false, + "bit-vector result-bit-vector") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + SimpleBitVector v = (SimpleBitVector) first; + SimpleBitVector result = (SimpleBitVector) second; + for (int i = v.bits.length; i-- > 0;) + result.bits[i] = ~v.bits[i]; + return result; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SimpleCondition.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleCondition.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,104 @@ +/* + * SimpleCondition.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SimpleCondition.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class SimpleCondition extends Condition +{ + public SimpleCondition() throws ConditionThrowable + { + setFormatControl(NIL); + setFormatArguments(NIL); + } + + public SimpleCondition(LispObject formatControl, LispObject formatArguments) + throws ConditionThrowable + { + setFormatControl(formatControl); + setFormatArguments(formatArguments); + } + + public SimpleCondition(LispObject initArgs) throws ConditionThrowable + { + super(initArgs); + } + + public SimpleCondition(String message) + { + super(message); + } + + @Override + public LispObject typeOf() + { + return Symbol.SIMPLE_CONDITION; + } + + @Override + public LispObject classOf() + { + return StandardClass.SIMPLE_CONDITION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_CONDITION) + return T; + if (type == StandardClass.SIMPLE_CONDITION) + return T; + return super.typep(type); + } + + // ### simple-condition-format-control + private static final Primitive SIMPLE_CONDITION_FORMAT_CONTROL = + new Primitive(Symbol.SIMPLE_CONDITION_FORMAT_CONTROL, "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Symbol.STD_SLOT_VALUE.execute(arg, Symbol.FORMAT_CONTROL); + } + }; + + // ### simple-condition-format-arguments + private static final Primitive SIMPLE_CONDITION_FORMAT_ARGUMENTS = + new Primitive(Symbol.SIMPLE_CONDITION_FORMAT_ARGUMENTS, "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Symbol.STD_SLOT_VALUE.execute(arg, Symbol.FORMAT_ARGUMENTS); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SimpleError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,84 @@ +/* + * SimpleError.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SimpleError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleError extends LispError +{ + public SimpleError(LispObject formatControl, LispObject formatArguments) + throws ConditionThrowable + { + super(StandardClass.SIMPLE_ERROR); + setFormatControl(formatControl); + setFormatArguments(formatArguments); + } + + public SimpleError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.SIMPLE_ERROR); + initialize(initArgs); + } + + public SimpleError(String message) throws ConditionThrowable + { + super(StandardClass.SIMPLE_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + } + + @Override + public LispObject typeOf() + { + return Symbol.SIMPLE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.SIMPLE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_ERROR) + return T; + if (type == StandardClass.SIMPLE_ERROR) + return T; + if (type == Symbol.SIMPLE_CONDITION) + return T; + if (type == StandardClass.SIMPLE_CONDITION) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleString.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleString.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,505 @@ +/* + * SimpleString.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: SimpleString.java 11587 2009-01-24 20:38:24Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleString extends AbstractString +{ + private int capacity; + private char[] chars; + + public SimpleString(LispCharacter c) + { + chars = new char[1]; + chars[0] = c.value; + capacity = 1; + } + + public SimpleString(char c) + { + chars = new char[1]; + chars[0] = c; + capacity = 1; + } + + public SimpleString(int capacity) + { + this.capacity = capacity; + chars = new char[capacity]; + } + + public SimpleString(String s) + { + capacity = s.length(); + chars = s.toCharArray(); + } + + public SimpleString(StringBuffer sb) + { + chars = new char[capacity = sb.length()]; + sb.getChars(0, capacity, chars, 0); + } + + public SimpleString(FastStringBuffer sb) + { + chars = sb.toCharArray(); + capacity = chars.length; + } + + private SimpleString(char[] chars) + { + this.chars = chars; + capacity = chars.length; + } + + @Override + public char[] chars() + { + return chars; + } + + @Override + public char[] getStringChars() + { + return chars; + } + + @Override + public LispObject typeOf() + { + return list2(Symbol.SIMPLE_BASE_STRING, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_BASE_STRING; + } + + @Override + public LispObject getDescription() + { + FastStringBuffer sb = new FastStringBuffer("A simple-string ("); + sb.append(capacity); + sb.append(") \""); + sb.append(chars); + sb.append('"'); + return new SimpleString(sb); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_STRING) + return T; + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == Symbol.SIMPLE_BASE_STRING) + return T; + if (type == BuiltInClass.SIMPLE_STRING) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.SIMPLE_BASE_STRING) + return T; + return super.typep(type); + } + + @Override + public LispObject SIMPLE_STRING_P() + { + return T; + } + + @Override + public boolean hasFillPointer() + { + return false; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public boolean equal(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof SimpleString) { + SimpleString string = (SimpleString) obj; + if (string.capacity != capacity) + return false; + for (int i = capacity; i-- > 0;) + if (string.chars[i] != chars[i]) + return false; + return true; + } + if (obj instanceof AbstractString) { + AbstractString string = (AbstractString) obj; + if (string.length() != capacity) + return false; + for (int i = length(); i-- > 0;) + if (string.charAt(i) != chars[i]) + return false; + return true; + } + if (obj instanceof NilVector) + return obj.equal(this); + return false; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof SimpleString) { + SimpleString string = (SimpleString) obj; + if (string.capacity != capacity) + return false; + for (int i = capacity; i-- > 0;) { + if (string.chars[i] != chars[i]) { + if (LispCharacter.toLowerCase(string.chars[i]) != LispCharacter.toLowerCase(chars[i])) + return false; + } + } + return true; + } + if (obj instanceof AbstractString) { + AbstractString string = (AbstractString) obj; + if (string.length() != capacity) + return false; + for (int i = length(); i-- > 0;) { + if (string.charAt(i) != chars[i]) { + if (LispCharacter.toLowerCase(string.charAt(i)) != LispCharacter.toLowerCase(chars[i])) + return false; + } + } + return true; + } + if (obj instanceof AbstractBitVector) + return false; + if (obj instanceof AbstractArray) + return obj.equalp(this); + return false; + } + + public final SimpleString substring(int start) throws ConditionThrowable + { + return substring(start, capacity); + } + + public final SimpleString substring(int start, int end) + throws ConditionThrowable + { + SimpleString s = new SimpleString(end - start); + int i = start, j = 0; + try { + while (i < end) + s.chars[j++] = chars[i++]; + return s; + } + catch (ArrayIndexOutOfBoundsException e) { + error(new TypeError("Array index out of bounds: " + i)); + // Not reached. + return null; + } + } + + @Override + public final LispObject subseq(int start, int end) throws ConditionThrowable + { + return substring(start, end); + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + fill(LispCharacter.getValue(obj)); + } + + @Override + public void fill(char c) + { + for (int i = capacity; i-- > 0;) + chars[i] = c; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (n < capacity) { + char[] newArray = new char[n]; + System.arraycopy(chars, 0, newArray, 0, n); + chars = newArray; + capacity = n; + return; + } + if (n == capacity) + return; + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + SimpleString result = new SimpleString(capacity); + int i, j; + for (i = 0, j = capacity - 1; i < capacity; i++, j--) + result.chars[i] = chars[j]; + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = capacity - 1; + while (i < j) { + char temp = chars[i]; + chars[i] = chars[j]; + chars[j] = temp; + ++i; + --j; + } + return this; + } + + @Override + public String getStringValue() + { + return String.valueOf(chars); + } + + @Override + public Object javaInstance() + { + return String.valueOf(chars); + } + + @Override + public Object javaInstance(Class c) + { + return javaInstance(); + } + + @Override + public final int capacity() + { + return capacity; + } + + @Override + public final int length() + { + return capacity; + } + + @Override + public char charAt(int index) throws ConditionThrowable + { + try { + return chars[index]; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + return 0; // Not reached. + } + } + + @Override + public void setCharAt(int index, char c) throws ConditionThrowable + { + try { + chars[index] = c; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + } + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + try { + return LispCharacter.getInstance(chars[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public LispObject CHAR(int index) throws ConditionThrowable + { + try { + return LispCharacter.getInstance(chars[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public LispObject SCHAR(int index) throws ConditionThrowable + { + try { + return LispCharacter.getInstance(chars[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try { + return LispCharacter.getInstance(chars[index]); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try { + return LispCharacter.getInstance(chars[((Fixnum)index).value]); + } + catch (ClassCastException e) { + return type_error(index, Symbol.FIXNUM); + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(((Fixnum)index).value, capacity); + return NIL; // Not reached. + } + } + + @Override + public void aset(int index, LispObject obj) throws ConditionThrowable + { + try { + chars[index] = ((LispCharacter)obj).value; + } + catch (ArrayIndexOutOfBoundsException e) { + badIndex(index, capacity); + } + catch (ClassCastException e) { + type_error(obj, Symbol.CHARACTER); + } + } + + @Override + public int sxhash() + { + int hashCode = 0; + for (int i = 0; i < capacity; i++) { + hashCode += chars[i]; + hashCode += (hashCode << 10); + hashCode ^= (hashCode >> 6); + } + hashCode += (hashCode << 3); + hashCode ^= (hashCode >> 11); + hashCode += (hashCode << 15); + return (hashCode & 0x7fffffff); + } + + // For EQUALP hash tables. + @Override + public int psxhash() + { + int hashCode = 0; + for (int i = 0; i < capacity; i++) { + hashCode += Character.toUpperCase(chars[i]); + hashCode += (hashCode << 10); + hashCode ^= (hashCode >> 6); + } + hashCode += (hashCode << 3); + hashCode ^= (hashCode >> 11); + hashCode += (hashCode << 15); + return (hashCode & 0x7fffffff); + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) { + char[] newChars = new char[newCapacity]; + if (initialContents.listp()) { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) { + newChars[i] = LispCharacter.getValue(list.car()); + list = list.cdr(); + } + } else if (initialContents.vectorp()) { + for (int i = 0; i < newCapacity; i++) + newChars[i] = LispCharacter.getValue(initialContents.elt(i)); + } else + type_error(initialContents, Symbol.SEQUENCE); + return new SimpleString(newChars); + } + if (capacity != newCapacity) { + char[] newChars = new char[newCapacity]; + System.arraycopy(chars, 0, newChars, 0, Math.min(newCapacity, capacity)); + if (initialElement != null && capacity < newCapacity) { + final char c = LispCharacter.getValue(initialElement); + for (int i = capacity; i < newCapacity; i++) + newChars[i] = c; + } + return new SimpleString(newChars); + } + // No change. + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable + { + return new ComplexString(newCapacity, displacedTo, displacement); + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleTypeError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleTypeError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,90 @@ +/* + * SimpleTypeError.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: SimpleTypeError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleTypeError extends TypeError +{ + public SimpleTypeError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.SIMPLE_TYPE_ERROR); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.SIMPLE_TYPE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.SIMPLE_TYPE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_TYPE_ERROR) + return T; + if (type == StandardClass.SIMPLE_TYPE_ERROR) + return T; + if (type == Symbol.SIMPLE_CONDITION) + return T; + if (type == StandardClass.SIMPLE_CONDITION) + return T; + return super.typep(type); + } + + @Override + public String getMessage() + { + try { + LispObject formatControl = getFormatControl(); + if (formatControl != NIL) { + LispObject formatArguments = getFormatArguments(); + // (apply 'format (append '(nil format-control) format-arguments)) + LispObject result = + Primitives.APPLY.execute(Symbol.FORMAT, + Primitives.APPEND.execute(list2(NIL, + formatControl), + formatArguments)); + return result.getStringValue(); + } + return super.getMessage(); + } + catch (Throwable t) {} + return null; + } +} Added: branches/save-image/src/org/armedbear/lisp/SimpleVector.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleVector.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,436 @@ +/* + * SimpleVector.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: SimpleVector.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// "The type of a vector that is not displaced to another array, has no fill +// pointer, is not expressly adjustable and is able to hold elements of any +// type is a subtype of type SIMPLE-VECTOR." +public final class SimpleVector extends AbstractVector +{ + private int capacity; + private LispObject[] data; + + public SimpleVector(int capacity) + { + data = new LispObject[capacity]; + for (int i = capacity; i-- > 0;) + data[i] = Fixnum.ZERO; + this.capacity = capacity; + } + + public SimpleVector(LispObject obj) throws ConditionThrowable + { + if (obj.listp()) + { + data = obj.copyToArray(); + capacity = data.length; + } + else if (obj instanceof AbstractVector) + { + capacity = obj.length(); + data = new LispObject[capacity]; + for (int i = 0; i < capacity; i++) + data[i] = obj.elt(i); + } + else + Debug.assertTrue(false); + } + + public SimpleVector(LispObject[] array) + { + data = array; + capacity = array.length; + } + + @Override + public LispObject typeOf() + { + return list2(Symbol.SIMPLE_VECTOR, new Fixnum(capacity)); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SIMPLE_VECTOR; + } + + @Override + public LispObject getDescription() + { + StringBuffer sb = new StringBuffer("A simple vector with "); + sb.append(capacity); + sb.append(" elements"); + return new SimpleString(sb); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_VECTOR) + return T; + if (type == Symbol.SIMPLE_ARRAY) + return T; + if (type == BuiltInClass.SIMPLE_VECTOR) + return T; + if (type == BuiltInClass.SIMPLE_ARRAY) + return T; + return super.typep(type); + } + + @Override + public LispObject getElementType() + { + return T; + } + + @Override + public boolean isSimpleVector() + { + return true; + } + + @Override + public boolean hasFillPointer() + { + return false; + } + + @Override + public boolean isAdjustable() + { + return false; + } + + @Override + public int capacity() + { + return capacity; + } + + @Override + public int length() + { + return capacity; + } + + @Override + public LispObject elt(int index) throws ConditionThrowable + { + try + { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + return NIL; // Not reached. + } + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + try + { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, data.length); + return NIL; // Not reached. + } + } + + @Override + public LispObject AREF(LispObject index) throws ConditionThrowable + { + try + { + return data[((Fixnum)index).value]; + } + catch (ClassCastException e) + { + return error(new TypeError(index, Symbol.FIXNUM)); + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(((Fixnum)index).value, data.length); + return NIL; // Not reached. + } + } + + @Override + public void aset(int index, LispObject newValue) throws ConditionThrowable + { + try + { + data[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + } + } + + @Override + public LispObject SVREF(int index) throws ConditionThrowable + { + try + { + return data[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, data.length); + return NIL; // Not reached. + } + } + + @Override + public void svset(int index, LispObject newValue) throws ConditionThrowable + { + try + { + data[index] = newValue; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index, capacity); + } + } + + @Override + public LispObject subseq(int start, int end) throws ConditionThrowable + { + SimpleVector v = new SimpleVector(end - start); + int i = start, j = 0; + try + { + while (i < end) + v.data[j++] = data[i++]; + return v; + } + catch (ArrayIndexOutOfBoundsException e) + { + return error(new TypeError("Array index out of bounds: " + i + ".")); + } + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + for (int i = capacity; i-- > 0;) + data[i] = obj; + } + + @Override + public LispObject deleteEq(LispObject item) throws ConditionThrowable + { + final int limit = capacity; + int i = 0; + int j = 0; + while (i < limit) + { + LispObject obj = data[i++]; + if (obj != item) + data[j++] = obj; + } + if (j < limit) + shrink(j); + return this; + } + + @Override + public LispObject deleteEql(LispObject item) throws ConditionThrowable + { + final int limit = capacity; + int i = 0; + int j = 0; + while (i < limit) + { + LispObject obj = data[i++]; + if (!obj.eql(item)) + data[j++] = obj; + } + if (j < limit) + shrink(j); + return this; + } + + @Override + public void shrink(int n) throws ConditionThrowable + { + if (n < capacity) + { + LispObject[] newData = new LispObject[n]; + System.arraycopy(data, 0, newData, 0, n); + data = newData; + capacity = n; + return; + } + if (n == capacity) + return; + error(new LispError()); + } + + @Override + public LispObject reverse() throws ConditionThrowable + { + SimpleVector result = new SimpleVector(capacity); + int i, j; + for (i = 0, j = capacity - 1; i < capacity; i++, j--) + result.data[i] = data[j]; + return result; + } + + @Override + public LispObject nreverse() throws ConditionThrowable + { + int i = 0; + int j = capacity - 1; + while (i < j) + { + LispObject temp = data[i]; + data[i] = data[j]; + data[j] = temp; + ++i; + --j; + } + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable + { + if (initialContents != null) + { + LispObject[] newData = new LispObject[newCapacity]; + if (initialContents.listp()) + { + LispObject list = initialContents; + for (int i = 0; i < newCapacity; i++) + { + newData[i] = list.car(); + list = list.cdr(); + } + } + else if (initialContents.vectorp()) + { + for (int i = 0; i < newCapacity; i++) + newData[i] = initialContents.elt(i); + } + else + error(new TypeError(initialContents, Symbol.SEQUENCE)); + return new SimpleVector(newData); + } + if (capacity != newCapacity) + { + LispObject[] newData = new LispObject[newCapacity]; + System.arraycopy(data, 0, newData, 0, + Math.min(capacity, newCapacity)); + if (initialElement != null) + for (int i = capacity; i < newCapacity; i++) + newData[i] = initialElement; + return new SimpleVector(newData); + } + // No change. + return this; + } + + @Override + public AbstractVector adjustArray(int newCapacity, + AbstractArray displacedTo, + int displacement) + { + return new ComplexVector(newCapacity, displacedTo, displacement); + } + + // ### svref + // svref simple-vector index => element + private static final Primitive SVREF = + new Primitive("svref", "simple-vector index") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return ((SimpleVector)first).data[((Fixnum)second).value]; + } + catch (ClassCastException e) + { + if (first instanceof SimpleVector) + return error(new TypeError(second, Symbol.FIXNUM)); + else + return error(new TypeError(first, Symbol.SIMPLE_VECTOR)); + } + } + }; + + // ### svset simple-vector index new-value => new-value + private static final Primitive SVSET = + new Primitive("svset", PACKAGE_SYS, true, "simple-vector index new-value") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try + { + ((SimpleVector)first).data[((Fixnum)second).value] = third; + return third; + } + catch (ClassCastException e) + { + if (first instanceof SimpleVector) + return error(new TypeError(second, Symbol.FIXNUM)); + else + return error(new TypeError(first, Symbol.SIMPLE_VECTOR)); + } + catch (ArrayIndexOutOfBoundsException e) + { + int index = ((Fixnum)second).value; + int capacity = ((SimpleVector)first).capacity; + ((SimpleVector)first).badIndex(index, capacity); + // Not reached. + return NIL; + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SimpleWarning.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SimpleWarning.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,77 @@ +/* + * SimpleWarning.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SimpleWarning.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SimpleWarning extends Warning +{ + public SimpleWarning(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.SIMPLE_WARNING); + initialize(initArgs); + } + + public SimpleWarning(LispObject formatControl, LispObject formatArguments) + throws ConditionThrowable + { + super(StandardClass.SIMPLE_WARNING); + setFormatControl(formatControl); + setFormatArguments(formatArguments); + } + + @Override + public LispObject typeOf() + { + return Symbol.SIMPLE_WARNING; + } + + @Override + public LispObject classOf() + { + return StandardClass.SIMPLE_WARNING; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_WARNING) + return T; + if (type == StandardClass.SIMPLE_WARNING) + return T; + if (type == Symbol.SIMPLE_CONDITION) + return T; + if (type == StandardClass.SIMPLE_CONDITION) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/SingleFloat.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SingleFloat.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,642 @@ +/* + * SingleFloat.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: SingleFloat.java 11579 2009-01-24 10:24:34Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class SingleFloat extends LispObject +{ + public static final SingleFloat ZERO = new SingleFloat(0); + public static final SingleFloat MINUS_ZERO = new SingleFloat(-0.0f); + public static final SingleFloat ONE = new SingleFloat(1); + public static final SingleFloat MINUS_ONE = new SingleFloat(-1); + + public static final SingleFloat SINGLE_FLOAT_POSITIVE_INFINITY = + new SingleFloat(Float.POSITIVE_INFINITY); + + public static final SingleFloat SINGLE_FLOAT_NEGATIVE_INFINITY = + new SingleFloat(Float.NEGATIVE_INFINITY); + + static { + Symbol.SINGLE_FLOAT_POSITIVE_INFINITY.initializeConstant(SINGLE_FLOAT_POSITIVE_INFINITY); + Symbol.SINGLE_FLOAT_NEGATIVE_INFINITY.initializeConstant(SINGLE_FLOAT_NEGATIVE_INFINITY); + } + + public static SingleFloat getInstance(float f) { + if (f == 0) + return ZERO; + else if (f == -0.0f ) + return MINUS_ZERO; + else if (f == 1) + return ONE; + else if (f == -1) + return MINUS_ONE; + else + return new SingleFloat(f); + } + + public final float value; + + public SingleFloat(float value) + { + this.value = value; + } + + @Override + public LispObject typeOf() + { + return Symbol.SINGLE_FLOAT; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SINGLE_FLOAT; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.FLOAT) + return T; + if (typeSpecifier == Symbol.REAL) + return T; + if (typeSpecifier == Symbol.NUMBER) + return T; + if (typeSpecifier == Symbol.SINGLE_FLOAT) + return T; + if (typeSpecifier == Symbol.SHORT_FLOAT) + return T; + if (typeSpecifier == BuiltInClass.FLOAT) + return T; + if (typeSpecifier == BuiltInClass.SINGLE_FLOAT) + return T; + return super.typep(typeSpecifier); + } + + @Override + public LispObject NUMBERP() + { + return T; + } + + @Override + public boolean numberp() + { + return true; + } + + @Override + public boolean realp() + { + return true; + } + + @Override + public boolean eql(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof SingleFloat) { + if (value == 0) { + // "If an implementation supports positive and negative zeros + // as distinct values, then (EQL 0.0 -0.0) returns false." + float f = ((SingleFloat)obj).value; + int bits = Float.floatToRawIntBits(f); + return bits == Float.floatToRawIntBits(value); + } + if (value == ((SingleFloat)obj).value) + return true; + } + return false; + } + + @Override + public boolean equal(LispObject obj) + { + if (this == obj) + return true; + if (obj instanceof SingleFloat) { + if (value == 0) { + // same as EQL + float f = ((SingleFloat)obj).value; + int bits = Float.floatToRawIntBits(f); + return bits == Float.floatToRawIntBits(value); + } + if (value == ((SingleFloat)obj).value) + return true; + } + return false; + } + + @Override + public boolean equalp(int n) + { + // "If two numbers are the same under =." + return value == n; + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (obj instanceof SingleFloat) + return value == ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value == ((DoubleFloat)obj).value; + if (obj instanceof Fixnum) + return value == ((Fixnum)obj).value; + if (obj instanceof Bignum) + return value == ((Bignum)obj).floatValue(); + if (obj instanceof Ratio) + return value == ((Ratio)obj).floatValue(); + return false; + } + + @Override + public LispObject ABS() + { + if (value > 0) + return this; + if (value == 0) // 0.0 or -0.0 + return ZERO; + return new SingleFloat(- value); + } + + @Override + public boolean plusp() + { + return value > 0; + } + + @Override + public boolean minusp() + { + return value < 0; + } + + @Override + public boolean zerop() + { + return value == 0; + } + + @Override + public LispObject FLOATP() + { + return T; + } + + @Override + public boolean floatp() + { + return true; + } + + public static double getValue(LispObject obj) throws ConditionThrowable + { + try { + return ((SingleFloat)obj).value; + } + catch (ClassCastException e) { + error(new TypeError(obj, Symbol.FLOAT)); + // Not reached. + return 0; + } + } + + public final float getValue() + { + return value; + } + + @Override + public float floatValue() { + return value; + } + + @Override + public double doubleValue() { + return value; + } + + @Override + public Object javaInstance() + { + return Float.valueOf(value); + } + + @Override + public Object javaInstance(Class c) + { + String cn = c.getName(); + if (cn.equals("java.lang.Float") || cn.equals("float")) + return Float.valueOf(value); + return javaInstance(); + } + + @Override + public final LispObject incr() + { + return new SingleFloat(value + 1); + } + + @Override + public final LispObject decr() + { + return new SingleFloat(value - 1); + } + + @Override + public LispObject add(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new SingleFloat(value + ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new SingleFloat(value + ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value + ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new SingleFloat(value + ((Bignum)obj).floatValue()); + if (obj instanceof Ratio) + return new SingleFloat(value + ((Ratio)obj).floatValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(add(c.getRealPart()), c.getImaginaryPart()); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public LispObject negate() + { + if (value == 0) { + int bits = Float.floatToRawIntBits(value); + return (bits < 0) ? ZERO : MINUS_ZERO; + } + return new SingleFloat(-value); + } + + @Override + public LispObject subtract(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new SingleFloat(value - ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new SingleFloat(value - ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value - ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new SingleFloat(value - ((Bignum)obj).floatValue()); + if (obj instanceof Ratio) + return new SingleFloat(value - ((Ratio)obj).floatValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(subtract(c.getRealPart()), + ZERO.subtract(c.getImaginaryPart())); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public LispObject multiplyBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new SingleFloat(value * ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new SingleFloat(value * ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value * ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new SingleFloat(value * ((Bignum)obj).floatValue()); + if (obj instanceof Ratio) + return new SingleFloat(value * ((Ratio)obj).floatValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + return Complex.getInstance(multiplyBy(c.getRealPart()), + multiplyBy(c.getImaginaryPart())); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public LispObject divideBy(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new SingleFloat(value / ((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return new SingleFloat(value / ((SingleFloat)obj).value); + if (obj instanceof DoubleFloat) + return new DoubleFloat(value / ((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new SingleFloat(value / ((Bignum)obj).floatValue()); + if (obj instanceof Ratio) + return new SingleFloat(value / ((Ratio)obj).floatValue()); + if (obj instanceof Complex) { + Complex c = (Complex) obj; + LispObject re = c.getRealPart(); + LispObject im = c.getImaginaryPart(); + LispObject denom = re.multiplyBy(re).add(im.multiplyBy(im)); + LispObject resX = multiplyBy(re).divideBy(denom); + LispObject resY = + multiplyBy(Fixnum.MINUS_ONE).multiplyBy(im).divideBy(denom); + return Complex.getInstance(resX, resY); + } + return error(new TypeError(obj, Symbol.NUMBER)); + } + + @Override + public boolean isEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return rational().isEqualTo(obj); + if (obj instanceof SingleFloat) + return value == ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value == ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isEqualTo(obj); + if (obj instanceof Ratio) + return rational().isEqualTo(obj); + if (obj instanceof Complex) + return obj.isEqualTo(this); + error(new TypeError(obj, Symbol.NUMBER)); + // Not reached. + return false; + } + + @Override + public boolean isNotEqualTo(LispObject obj) throws ConditionThrowable + { + return !isEqualTo(obj); + } + + @Override + public boolean isLessThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return rational().isLessThan(obj); + if (obj instanceof SingleFloat) + return value < ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value < ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isLessThan(obj); + if (obj instanceof Ratio) + return rational().isLessThan(obj); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThan(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return rational().isGreaterThan(obj); + if (obj instanceof SingleFloat) + return value > ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value > ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isGreaterThan(obj); + if (obj instanceof Ratio) + return rational().isGreaterThan(obj); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public boolean isLessThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return rational().isLessThanOrEqualTo(obj); + if (obj instanceof SingleFloat) + return value <= ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value <= ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isLessThanOrEqualTo(obj); + if (obj instanceof Ratio) + return rational().isLessThanOrEqualTo(obj); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public boolean isGreaterThanOrEqualTo(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return rational().isGreaterThanOrEqualTo(obj); + if (obj instanceof SingleFloat) + return value >= ((SingleFloat)obj).value; + if (obj instanceof DoubleFloat) + return value >= ((DoubleFloat)obj).value; + if (obj instanceof Bignum) + return rational().isGreaterThanOrEqualTo(obj); + if (obj instanceof Ratio) + return rational().isGreaterThanOrEqualTo(obj); + error(new TypeError(obj, Symbol.REAL)); + // Not reached. + return false; + } + + @Override + public LispObject truncate(LispObject obj) throws ConditionThrowable + { + // "When rationals and floats are combined by a numerical function, + // the rational is first converted to a float of the same format." + // 12.1.4.1 + if (obj instanceof Fixnum) { + return truncate(new SingleFloat(((Fixnum)obj).value)); + } + if (obj instanceof Bignum) { + return truncate(new SingleFloat(((Bignum)obj).floatValue())); + } + if (obj instanceof Ratio) { + return truncate(new SingleFloat(((Ratio)obj).floatValue())); + } + if (obj instanceof SingleFloat) { + final LispThread thread = LispThread.currentThread(); + float divisor = ((SingleFloat)obj).value; + float quotient = value / divisor; + if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { + int q = (int) quotient; + return thread.setValues(new Fixnum(q), + new SingleFloat(value - q * divisor)); + } + // We need to convert the quotient to a bignum. + int bits = Float.floatToRawIntBits(quotient); + int s = ((bits >> 31) == 0) ? 1 : -1; + int e = (int) ((bits >> 23) & 0xff); + long m; + if (e == 0) + m = (bits & 0x7fffff) << 1; + else + m = (bits & 0x7fffff) | 0x800000; + LispObject significand = number(m); + Fixnum exponent = new Fixnum(e - 150); + Fixnum sign = new Fixnum(s); + LispObject result = significand; + result = + result.multiplyBy(MathFunctions.EXPT.execute(Fixnum.TWO, exponent)); + result = result.multiplyBy(sign); + // Calculate remainder. + LispObject product = result.multiplyBy(obj); + LispObject remainder = subtract(product); + return thread.setValues(result, remainder); + } + if (obj instanceof DoubleFloat) { + final LispThread thread = LispThread.currentThread(); + double divisor = ((DoubleFloat)obj).value; + double quotient = value / divisor; + if (quotient >= Integer.MIN_VALUE && quotient <= Integer.MAX_VALUE) { + int q = (int) quotient; + return thread.setValues(new Fixnum(q), + new DoubleFloat(value - q * divisor)); + } + // We need to convert the quotient to a bignum. + long bits = Double.doubleToRawLongBits((double)quotient); + int s = ((bits >> 63) == 0) ? 1 : -1; + int e = (int) ((bits >> 52) & 0x7ffL); + long m; + if (e == 0) + m = (bits & 0xfffffffffffffL) << 1; + else + m = (bits & 0xfffffffffffffL) | 0x10000000000000L; + LispObject significand = number(m); + Fixnum exponent = new Fixnum(e - 1075); + Fixnum sign = new Fixnum(s); + LispObject result = significand; + result = + result.multiplyBy(MathFunctions.EXPT.execute(Fixnum.TWO, exponent)); + result = result.multiplyBy(sign); + // Calculate remainder. + LispObject product = result.multiplyBy(obj); + LispObject remainder = subtract(product); + return thread.setValues(result, remainder); + } + return error(new TypeError(obj, Symbol.REAL)); + } + + @Override + public int hashCode() + { + return Float.floatToIntBits(value); + } + + @Override + public int psxhash() + { + if ((value % 1) == 0) + return (((int)value) & 0x7fffffff); + else + return (hashCode() & 0x7fffffff); + } + + @Override + public String writeToString() throws ConditionThrowable + { + if (value == Float.POSITIVE_INFINITY) { + StringBuffer sb = new StringBuffer("#."); + sb.append(Symbol.SINGLE_FLOAT_POSITIVE_INFINITY.writeToString()); + return sb.toString(); + } + if (value == Float.NEGATIVE_INFINITY) { + StringBuffer sb = new StringBuffer("#."); + sb.append(Symbol.SINGLE_FLOAT_NEGATIVE_INFINITY.writeToString()); + return sb.toString(); + } + if (value != value) + return "#"; + String s1 = String.valueOf(value); + LispThread thread = LispThread.currentThread(); + if (Symbol.PRINT_READABLY.symbolValue(thread) != NIL || + !memq(Symbol.READ_DEFAULT_FLOAT_FORMAT.symbolValue(thread), + list2(Symbol.SINGLE_FLOAT, Symbol.SHORT_FLOAT))) + { + if (s1.indexOf('E') >= 0) + return s1.replace('E', 'f'); + else + return s1.concat("f0"); + } else + return s1; + } + + public LispObject rational() throws ConditionThrowable + { + final int bits = Float.floatToRawIntBits(value); + int sign = ((bits >> 31) == 0) ? 1 : -1; + int storedExponent = ((bits >> 23) & 0xff); + long mantissa; + if (storedExponent == 0) + mantissa = (bits & 0x7fffff) << 1; + else + mantissa = (bits & 0x7fffff) | 0x800000; + if (mantissa == 0) + return Fixnum.ZERO; + if (sign < 0) + mantissa = -mantissa; + // Subtract bias. + final int exponent = storedExponent - 127; + BigInteger numerator, denominator; + if (exponent < 0) { + numerator = BigInteger.valueOf(mantissa); + denominator = BigInteger.valueOf(1).shiftLeft(23 - exponent); + } else { + numerator = BigInteger.valueOf(mantissa).shiftLeft(exponent); + denominator = BigInteger.valueOf(0x800000); // (ash 1 23) + } + return number(numerator, denominator); + } + + public static SingleFloat coerceToFloat(LispObject obj) throws ConditionThrowable + { + if (obj instanceof Fixnum) + return new SingleFloat(((Fixnum)obj).value); + if (obj instanceof SingleFloat) + return (SingleFloat) obj; + if (obj instanceof DoubleFloat) + return new SingleFloat((float)((DoubleFloat)obj).value); + if (obj instanceof Bignum) + return new SingleFloat(((Bignum)obj).floatValue()); + if (obj instanceof Ratio) + return new SingleFloat(((Ratio)obj).floatValue()); + error(new TypeError("The value " + obj.writeToString() + + " cannot be converted to type SINGLE-FLOAT.")); + // Not reached. + return null; + } +} Added: branches/save-image/src/org/armedbear/lisp/Site.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Site.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,83 @@ +/* + * Site.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Site.java 11676 2009-02-21 19:14:48Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.net.URL; + +public final class Site extends Lisp +{ + private static final String LISP_HOME; + + static { + String lispHome = null; + URL url = Lisp.class.getResource("boot.lisp"); + if (url != null) { + String protocol = url.getProtocol(); + if (protocol != null && protocol.equals("file")) { + String path = url.getPath(); + int index = path.lastIndexOf('/'); + if (index >= 0) { + lispHome = path.substring(0, index + 1); + if (Utilities.isPlatformWindows) { + if (lispHome.length() > 0 && lispHome.charAt(0) == '/') + lispHome = lispHome.substring(1); + } + } + } + } else + lispHome = System.getProperty("abcl.home"); + LISP_HOME = lispHome; + } + + public static final String getLispHome() + { + return LISP_HOME; + } + + // ### *lisp-home* + private static final Symbol _LISP_HOME_ = + exportSpecial("*LISP-HOME*", PACKAGE_EXT, NIL); + + static { + try { + String s = Site.getLispHome(); + if (s != null) + _LISP_HOME_.setSymbolValue(new Pathname(s)); + } + catch (Throwable t) { + Debug.trace(t); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/SiteName.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SiteName.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,81 @@ +/* + * SiteName.java + * + * Copyright (C) 2004 Peter Graves + * $Id: SiteName.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.InetAddress; + +public final class SiteName extends Lisp +{ + private static LispObject getHostName() + { + String hostName = null; + try { + InetAddress addr = InetAddress.getLocalHost(); + if (addr != null) + hostName = addr.getHostName(); + } + catch (Throwable t) {} + return hostName != null ? new SimpleString(hostName) : NIL; + } + + private static final Primitive MACHINE_INSTANCE = + new Primitive("machine-instance") + { + @Override + public LispObject execute() + { + return getHostName(); + } + }; + + private static final Primitive LONG_SITE_NAME = + new Primitive("long-site-name") + { + @Override + public LispObject execute() + { + return getHostName(); + } + }; + + private static final Primitive SHORT_SITE_NAME = + new Primitive("short-site-name") + { + @Override + public LispObject execute() + { + return getHostName(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SlimeInputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SlimeInputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,170 @@ +/* + * SlimeInputStream.java + * + * Copyright (C) 2004 Andras Simon, Peter Graves + * $Id: SlimeInputStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class SlimeInputStream extends Stream +{ + String s; + int length; + final Function f; + final Stream ostream; + + public SlimeInputStream(Function f, Stream ostream) + { + elementType = Symbol.CHARACTER; + isInputStream = true; + isOutputStream = false; + isCharacterStream = true; + isBinaryStream = false; + this.f = f; + this.ostream = ostream; + } + + @Override + public LispObject typeOf() + { + return Symbol.SLIME_INPUT_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SLIME_INPUT_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SLIME_INPUT_STREAM) + return T; + if (type == Symbol.STRING_STREAM) + return T; + if (type == BuiltInClass.SLIME_INPUT_STREAM) + return T; + if (type == BuiltInClass.STRING_STREAM) + return T; + return super.typep(type); + } + + @Override + public LispObject close(LispObject abort) throws ConditionThrowable + { + setOpen(false); + return T; + } + + @Override + public LispObject listen() + { + return offset < length ? T : NIL; + } + + @Override + protected int _readChar() + { + if (offset >= length) { + try { + ostream.finishOutput(); + s = LispThread.currentThread().execute(f).getStringValue(); + } + catch (Throwable t) { + return -1; + } + if (s.length() == 0) + return -1; + offset = 0; + length = s.length(); + } + int n = s.charAt(offset); + ++offset; + if (n == '\n') + ++lineNumber; + return n; + } + + @Override + protected void _unreadChar(int n) + { + if (offset > 0) { + --offset; + if (n == '\n') + --lineNumber; + } + } + + @Override + protected boolean _charReady() + { + return offset < length ? true : false; + } + + + @Override + public void _clearInput() throws ConditionThrowable + { + super._clearInput(); + s = ""; + offset = 0; + length = 0; + lineNumber = 0; + } + + + @Override + public String toString() + { + return unreadableString("SLIME-INPUT-STREAM"); + } + + // ### make-slime-input-stream + // make-slime-input-stream function output-stream => slime-input-stream + private static final Primitive MAKE_SLIME_INPUT_STREAM = + new Primitive("make-slime-input-stream", PACKAGE_EXT, true, + "function output-stream") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Function fun; + final Stream os; + if (first instanceof Symbol) + fun = (Function)first.getSymbolFunction(); + else + fun = (Function)first; + os = checkCharacterOutputStream(second); + return new SlimeInputStream(fun, os); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SlimeOutputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SlimeOutputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,159 @@ +/* + * SlimeOutputStream.java + * + * Copyright (C) 2004-2005 Andras Simon, Peter Graves + * $Id: SlimeOutputStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.StringWriter; + +public final class SlimeOutputStream extends Stream +{ + private final StringWriter stringWriter; + final Function f; + + private SlimeOutputStream(Function f) + { + this.elementType = Symbol.CHARACTER; + isInputStream = false; + isOutputStream = true; + isCharacterStream = true; + isBinaryStream = false; + setWriter(stringWriter = new StringWriter()); + this.f = f; + } + + @Override + public LispObject typeOf() + { + return Symbol.SLIME_OUTPUT_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SLIME_OUTPUT_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SLIME_OUTPUT_STREAM) + return T; + if (type == Symbol.STRING_STREAM) + return T; + if (type == BuiltInClass.SLIME_OUTPUT_STREAM) + return T; + if (type == BuiltInClass.STRING_STREAM) + return T; + return super.typep(type); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + if (elementType == NIL) + writeError(); + super._writeChar(c); + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + if (elementType == NIL) + writeError(); + super._writeChars(chars, start, end); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + if (elementType == NIL) + writeError(); + super._writeString(s); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + if (elementType == NIL) + writeError(); + super._writeLine(s); + } + + private void writeError() throws ConditionThrowable + { + error(new TypeError("Attempt to write to a string output stream of element type NIL.")); + } + + @Override + protected long _getFilePosition() throws ConditionThrowable + { + if (elementType == NIL) + return 0; + return stringWriter.toString().length(); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + super._finishOutput (); + if (stringWriter.getBuffer().length() > 0) { + String s = stringWriter.toString(); + stringWriter.getBuffer().setLength(0); + LispThread.currentThread().execute(f, new SimpleString(s)); + } + } + + @Override + public String toString() + { + return unreadableString("SLIME-OUTPUT-STREAM"); + } + + // ### %make-slime-output-stream + // %make-slime-output-stream function => stream + private static final Primitive MAKE_SLIME_OUTPUT_STREAM = + new Primitive("make-slime-output-stream", PACKAGE_EXT, true, "function") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final Function fun; + if (arg instanceof Symbol) + fun = (Function)arg.getSymbolFunction(); + else + fun = (Function)arg; + return new SlimeOutputStream(fun); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SlotClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SlotClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,315 @@ +/* + * SlotClass.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: SlotClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class SlotClass extends LispClass +{ + private LispObject directSlotDefinitions = NIL; + private LispObject slotDefinitions = NIL; + private LispObject directDefaultInitargs = NIL; + private LispObject defaultInitargs = NIL; + + public SlotClass() + { + } + + public SlotClass(Symbol symbol, LispObject directSuperclasses) + { + super(symbol, directSuperclasses); + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject result = super.getParts().nreverse(); + result = result.push(new Cons("DIRECT-SLOTS", directSlotDefinitions)); + result = result.push(new Cons("SLOTS", slotDefinitions)); + result = result.push(new Cons("DIRECT-DEFAULT-INITARGS", directDefaultInitargs)); + result = result.push(new Cons("DEFAULT-INITARGS", defaultInitargs)); + return result.nreverse(); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + return super.typep(type); + } + + public LispObject getDirectSlotDefinitions() + { + return directSlotDefinitions; + } + + public void setDirectSlotDefinitions(LispObject directSlotDefinitions) + { + this.directSlotDefinitions = directSlotDefinitions; + } + + public final LispObject getSlotDefinitions() + { + return slotDefinitions; + } + + public void setSlotDefinitions(LispObject slotDefinitions) + { + this.slotDefinitions = slotDefinitions; + } + + public LispObject getDirectDefaultInitargs() + { + return directDefaultInitargs; + } + + public void setDirectDefaultInitargs(LispObject directDefaultInitargs) + { + this.directDefaultInitargs = directDefaultInitargs; + } + + public void setDefaultInitargs(LispObject defaultInitargs) + { + this.defaultInitargs = defaultInitargs; + } + + private LispObject computeDefaultInitargs() throws ConditionThrowable + { + LispObject result = NIL; + LispObject cpl = getCPL(); + while (cpl != NIL) { + LispClass c = (LispClass) cpl.car(); + if (c instanceof StandardClass) { + LispObject obj = ((StandardClass)c).getDirectDefaultInitargs(); + if (obj != NIL) + result = Symbol.APPEND.execute(result, obj); + } + cpl = cpl.cdr(); + } + return result; + } + + public void finalizeClass() + { + if (isFinalized()) + return; + try { + Debug.assertTrue(slotDefinitions == NIL); + LispObject cpl = getCPL(); + Debug.assertTrue(cpl != null); + Debug.assertTrue(cpl.listp()); + cpl = cpl.reverse(); + while (cpl != NIL) { + LispObject car = cpl.car(); + if (car instanceof StandardClass) { + StandardClass cls = (StandardClass) car; + LispObject defs = cls.getDirectSlotDefinitions(); + Debug.assertTrue(defs != null); + Debug.assertTrue(defs.listp()); + while (defs != NIL) { + slotDefinitions = slotDefinitions.push(defs.car()); + defs = defs.cdr(); + } + } + cpl = cpl.cdr(); + } + slotDefinitions = slotDefinitions.nreverse(); + LispObject[] instanceSlotNames = new LispObject[slotDefinitions.length()]; + int i = 0; + LispObject tail = slotDefinitions; + while (tail != NIL) { + SlotDefinition slotDefinition = (SlotDefinition) tail.car(); + slotDefinition.setLocation(i); + instanceSlotNames[i++] = slotDefinition.getName(); + tail = tail.cdr(); + } + setClassLayout(new Layout(this, instanceSlotNames, NIL)); + setDefaultInitargs(computeDefaultInitargs()); + setFinalized(true); + } + catch (Throwable t) { + Debug.trace(t); + } + } + + // ### class-direct-slots + private static final Primitive CLASS_DIRECT_SLOTS = + new Primitive("class-direct-slots", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof SlotClass) + return ((SlotClass)arg).directSlotDefinitions; + if (arg instanceof BuiltInClass) + return NIL; + return type_error(arg, Symbol.STANDARD_CLASS); + } + }; + + // ### %set-class-direct-slots + private static final Primitive _SET_CLASS_DIRECT_SLOTS = + new Primitive("%set-class-direct-slots", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + ((SlotClass)first).directSlotDefinitions = second; + return second; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STANDARD_CLASS); + } + } + }; + + // ### %class-slots + private static final Primitive _CLASS_SLOTS = + new Primitive(Symbol._CLASS_SLOTS, "class") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof SlotClass) + return ((SlotClass)arg).slotDefinitions; + if (arg instanceof BuiltInClass) + return NIL; + return type_error(arg, Symbol.STANDARD_CLASS); + } + }; + + // ### set-class-slots + private static final Primitive SET_CLASS_SLOTS = + new Primitive(Symbol.SET_CLASS_SLOTS, "class slot-definitions") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + ((SlotClass)first).slotDefinitions = second; + return second; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STANDARD_CLASS); + } + } + }; + + // ### class-direct-default-initargs + private static final Primitive CLASS_DIRECT_DEFAULT_INITARGS = + new Primitive("class-direct-default-initargs", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof SlotClass) + return ((SlotClass)arg).directDefaultInitargs; + if (arg instanceof BuiltInClass) + return NIL; + return type_error(arg, Symbol.STANDARD_CLASS); + } + }; + + // ### %set-class-direct-default-initargs + private static final Primitive _SET_CLASS_DIRECT_DEFAULT_INITARGS = + new Primitive("%set-class-direct-default-initargs", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + ((SlotClass)first).directDefaultInitargs = second; + return second; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STANDARD_CLASS); + } + } + }; + + // ### class-default-initargs + private static final Primitive CLASS_DEFAULT_INITARGS = + new Primitive("class-default-initargs", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof SlotClass) + return ((SlotClass)arg).defaultInitargs; + if (arg instanceof BuiltInClass) + return NIL; + return type_error(arg, Symbol.STANDARD_CLASS); + } + }; + + // ### %set-class-default-initargs + private static final Primitive _SET_CLASS_DEFAULT_INITARGS = + new Primitive("%set-class-default-initargs", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof SlotClass) { + ((SlotClass)first).defaultInitargs = second; + return second; + } + return type_error(first, Symbol.STANDARD_CLASS); + } + }; + + // ### compute-class-default-initargs + private static final Primitive COMPUTE_CLASS_DEFAULT_INITARGS = + new Primitive("compute-class-default-initargs", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + final SlotClass c; + try { + c = (SlotClass) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STANDARD_CLASS); + } + return c.computeDefaultInitargs(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SlotDefinition.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SlotDefinition.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,474 @@ +/* + * SlotDefinition.java + * + * Copyright (C) 2005 Peter Graves + * $Id: SlotDefinition.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SlotDefinition extends StandardObject +{ + public SlotDefinition() + { + super(StandardClass.SLOT_DEFINITION, + StandardClass.SLOT_DEFINITION.getClassLayout().getLength()); + slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = NIL; + } + + public SlotDefinition(LispObject name, LispObject readers) + { + this(); + try + { + Debug.assertTrue(name instanceof Symbol); + slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name; + slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = NIL; + slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = + new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName())); + slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers; + slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; + } + catch (Throwable t) + { + Debug.trace(t); + } + } + + public SlotDefinition(LispObject name, LispObject readers, + LispObject initForm) + { + this(); + try + { + Debug.assertTrue(name instanceof Symbol); + slots[SlotDefinitionClass.SLOT_INDEX_NAME] = name; + slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = NIL; + slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = initForm; + slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = + new Cons(PACKAGE_KEYWORD.intern(((Symbol)name).getName())); + slots[SlotDefinitionClass.SLOT_INDEX_READERS] = readers; + slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = Keyword.INSTANCE; + } + catch (Throwable t) + { + Debug.trace(t); + } + } + + public final LispObject getName() + { + return slots[SlotDefinitionClass.SLOT_INDEX_NAME]; + } + + public final void setLocation(int i) + { + slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = new Fixnum(i); + } + + @Override + public String writeToString() throws ConditionThrowable + { + FastStringBuffer sb = + new FastStringBuffer(Symbol.SLOT_DEFINITION.writeToString()); + LispObject name = slots[SlotDefinitionClass.SLOT_INDEX_NAME]; + if (name != null && name != NIL) + { + sb.append(' '); + sb.append(name.writeToString()); + } + return unreadableString(sb.toString()); + } + + // ### make-slot-definition + private static final Primitive MAKE_SLOT_DEFINITION = + new Primitive("make-slot-definition", PACKAGE_SYS, true, "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new SlotDefinition(); + } + }; + + // ### %slot-definition-name + private static final Primitive _SLOT_DEFINITION_NAME = + new Primitive(Symbol._SLOT_DEFINITION_NAME, "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_NAME]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-name + private static final Primitive SET_SLOT_DEFINITION_NAME = + new Primitive("set-slot-definition-name", PACKAGE_SYS, true, + "slot-definition name") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_NAME] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-initfunction + private static final Primitive _SLOT_DEFINITION_INITFUNCTION = + new Primitive(Symbol._SLOT_DEFINITION_INITFUNCTION, "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-initfunction + private static final Primitive SET_SLOT_DEFINITION_INITFUNCTION = + new Primitive("set-slot-definition-initfunction", PACKAGE_SYS, true, + "slot-definition initfunction") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_INITFUNCTION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-initform + private static final Primitive _SLOT_DEFINITION_INITFORM = + new Primitive("%slot-definition-initform", PACKAGE_SYS, true, + "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-initform + private static final Primitive SET_SLOT_DEFINITION_INITFORM = + new Primitive("set-slot-definition-initform", PACKAGE_SYS, true, + "slot-definition initform") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_INITFORM] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-initargs + private static final Primitive _SLOT_DEFINITION_INITARGS = + new Primitive(Symbol._SLOT_DEFINITION_INITARGS, "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-initargs + private static final Primitive SET_SLOT_DEFINITION_INITARGS = + new Primitive("set-slot-definition-initargs", PACKAGE_SYS, true, + "slot-definition initargs") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_INITARGS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-readers + private static final Primitive _SLOT_DEFINITION_READERS = + new Primitive("%slot-definition-readers", PACKAGE_SYS, true, + "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_READERS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-readers + private static final Primitive SET_SLOT_DEFINITION_READERS = + new Primitive("set-slot-definition-readers", PACKAGE_SYS, true, + "slot-definition readers") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_READERS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-writers + private static final Primitive _SLOT_DEFINITION_WRITERS = + new Primitive("%slot-definition-writers", PACKAGE_SYS, true, + "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-writers + private static final Primitive SET_SLOT_DEFINITION_WRITERS = + new Primitive("set-slot-definition-writers", PACKAGE_SYS, true, + "slot-definition writers") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_WRITERS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-allocation + private static final Primitive _SLOT_DEFINITION_ALLOCATION = + new Primitive("%slot-definition-allocation", PACKAGE_SYS, true, + "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-allocation + private static final Primitive SET_SLOT_DEFINITION_ALLOCATION = + new Primitive("set-slot-definition-allocation", PACKAGE_SYS, true, + "slot-definition allocation") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-allocation-class + private static final Primitive _SLOT_DEFINITION_ALLOCATION_CLASS = + new Primitive("%slot-definition-allocation-class", PACKAGE_SYS, true, + "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-allocation-class + private static final Primitive SET_SLOT_DEFINITION_ALLOCATION_CLASS = + new Primitive("set-slot-definition-allocation-class", PACKAGE_SYS, true, + "slot-definition allocation-class") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_ALLOCATION_CLASS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### %slot-definition-location + private static final Primitive _SLOT_DEFINITION_LOCATION = + new Primitive("%slot-definition-location", PACKAGE_SYS, true, "slot-definition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((SlotDefinition)arg).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.SLOT_DEFINITION); + } + } + }; + + // ### set-slot-definition-location + private static final Primitive SET_SLOT_DEFINITION_LOCATION = + new Primitive("set-slot-definition-location", PACKAGE_SYS, true, "slot-definition location") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((SlotDefinition)first).slots[SlotDefinitionClass.SLOT_INDEX_LOCATION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SLOT_DEFINITION); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/SlotDefinitionClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SlotDefinitionClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,66 @@ +/* + * SlotDefinitionClass.java + * + * Copyright (C) 2005 Peter Graves + * $Id: SlotDefinitionClass.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SlotDefinitionClass extends StandardClass +{ + public static final int SLOT_INDEX_NAME = 0; + public static final int SLOT_INDEX_INITFUNCTION = 1; + public static final int SLOT_INDEX_INITFORM = 2; + public static final int SLOT_INDEX_INITARGS = 3; + public static final int SLOT_INDEX_READERS = 4; + public static final int SLOT_INDEX_WRITERS = 5; + public static final int SLOT_INDEX_ALLOCATION = 6; + public static final int SLOT_INDEX_ALLOCATION_CLASS = 7; + public static final int SLOT_INDEX_LOCATION = 8; + + public SlotDefinitionClass() + { + super(Symbol.SLOT_DEFINITION, list1(StandardClass.STANDARD_OBJECT)); + Package pkg = PACKAGE_SYS; + LispObject[] instanceSlotNames = { + pkg.intern("NAME"), + pkg.intern("INITFUNCTION"), + pkg.intern("INITFORM"), + pkg.intern("INITARGS"), + pkg.intern("READERS"), + pkg.intern("WRITERS"), + pkg.intern("ALLOCATION"), + pkg.intern("ALLOCATION-CLASS"), + pkg.intern("LOCATION") + }; + setClassLayout(new Layout(this, instanceSlotNames, NIL)); + setFinalized(true); + } +} Added: branches/save-image/src/org/armedbear/lisp/SocketStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SocketStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,87 @@ +/* + * SocketStream.java + * + * Copyright (C) 2004 Peter Graves + * $Id: SocketStream.java 11478 2008-12-25 11:46:10Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.Socket; + +public final class SocketStream extends TwoWayStream +{ + private final Socket socket; + + public SocketStream(Socket socket, Stream in, Stream out) + { + super(in, out); + this.socket = socket; + } + + @Override + public LispObject typeOf() + { + return Symbol.SOCKET_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SOCKET_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SOCKET_STREAM) + return T; + if (type == BuiltInClass.SOCKET_STREAM) + return T; + return super.typep(type); + } + + @Override + public LispObject close(LispObject abort) throws ConditionThrowable + { + try { + socket.close(); + setOpen(false); + return T; + } catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + @Override + public String toString() + { + return unreadableString("SOCKET-STREAM"); + } +} Added: branches/save-image/src/org/armedbear/lisp/SpecialBinding.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SpecialBinding.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,49 @@ +/* + * SpecialBinding.java + * + * Copyright (C) 2002-2008 Peter Graves + * $Id: SpecialBinding.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// Package accessibility. +final public class SpecialBinding +{ + final LispObject name; + LispObject value; + final SpecialBinding next; + + SpecialBinding(LispObject name, LispObject value, SpecialBinding next) + { + this.name = name; + this.value = value; + this.next = next; + } +} Added: branches/save-image/src/org/armedbear/lisp/SpecialOperator.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SpecialOperator.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,177 @@ +/* + * SpecialOperator.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: SpecialOperator.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class SpecialOperator extends Operator +{ + private int callCount; + + public SpecialOperator(Symbol symbol) + { + symbol.setSymbolFunction(this); + setLambdaName(symbol); + } + + public SpecialOperator(Symbol symbol, String arglist) + { + symbol.setSymbolFunction(this); + setLambdaName(symbol); + setLambdaList(new SimpleString(arglist)); + } + + public SpecialOperator(String name, Package pkg, boolean exported, + String arglist) + { + try { + Symbol symbol; + if (exported) + symbol = pkg.internAndExport(name.toUpperCase()); + else + symbol = pkg.intern(name.toUpperCase()); + symbol.setSymbolFunction(this); + setLambdaName(symbol); + setLambdaList(new SimpleString(arglist)); + } + catch (ConditionThrowable t) { + Debug.assertTrue(false); + } + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return error(new UndefinedFunction(getLambdaName())); + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = new StringBuffer("#"); + return sb.toString(); + } + + // Profiling. + @Override + public final int getCallCount() + { + return callCount; + } + + @Override + public final void setCallCount(int n) + { + callCount = n; + } + + @Override + public final void incrementCallCount() + { + ++callCount; + } +} Added: branches/save-image/src/org/armedbear/lisp/SpecialOperators.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SpecialOperators.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,636 @@ +/* + * SpecialOperators.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: SpecialOperators.java 11548 2009-01-06 12:12:14Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.ArrayList; +import java.util.LinkedList; +public final class SpecialOperators extends Lisp +{ + // ### quote + private static final SpecialOperator QUOTE = + new SpecialOperator(Symbol.QUOTE, "thing") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.cdr() != NIL) + return error(new WrongNumberOfArgumentsException(this)); + return ((Cons)args).car; + } + }; + + // ### if + private static final SpecialOperator IF = + new SpecialOperator(Symbol.IF, "test then &optional else") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + switch (args.length()) + { + case 2: + { + if (eval(((Cons)args).car, env, thread) != NIL) + return eval(args.cadr(), env, thread); + thread.clearValues(); + return NIL; + } + case 3: + { + if (eval(((Cons)args).car, env, thread) != NIL) + return eval(args.cadr(), env, thread); + return eval((((Cons)args).cdr).cadr(), env, thread); + } + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + }; + + // ### let + private static final SpecialOperator LET = + new SpecialOperator(Symbol.LET, "bindings &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + return _let(args, env, false); + } + }; + + // ### let* + private static final SpecialOperator LET_STAR = + new SpecialOperator(Symbol.LET_STAR, "bindings &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args == NIL) + return error(new WrongNumberOfArgumentsException(this)); + return _let(args, env, true); + } + }; + + private static final LispObject _let(LispObject args, Environment env, + boolean sequential) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + try + { + LispObject varList = checkList(args.car()); + LispObject body = args.cdr(); + // Process declarations. + ArrayList specials = new ArrayList(); + while (body != NIL) + { + LispObject obj = body.car(); + if (obj instanceof Cons && ((Cons)obj).car == Symbol.DECLARE) + { + LispObject decls = ((Cons)obj).cdr; + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && ((Cons)decl).car == Symbol.SPECIAL) + { + LispObject vars = ((Cons)decl).cdr; + while (vars != NIL) + { + specials.add(0, (Symbol) vars.car()); + vars = ((Cons)vars).cdr; + } + } + decls = ((Cons)decls).cdr; + } + body = ((Cons)body).cdr; + } + else + break; + } + Environment ext = new Environment(env); + LinkedList nonSequentialVars = new LinkedList(); + Symbol[] arrayToUseForSpecials = new Symbol[0]; + while (varList != NIL) + { + final Symbol symbol; + LispObject value; + LispObject obj = varList.car(); + if (obj instanceof Cons) + { + if (obj.length() > 2) + return error(new LispError("The " + (sequential ? "LET*" : "LET") + + " binding specification " + + obj.writeToString() + " is invalid.")); + try + { + symbol = (Symbol) ((Cons)obj).car; + } + catch (ClassCastException e) + { + return type_error(((Cons)obj).car, Symbol.SYMBOL); + } + value = eval(obj.cadr(), sequential ? ext : env, thread); + } + else + { + try + { + symbol = (Symbol) obj; + } + catch (ClassCastException e) + { + return type_error(obj, Symbol.SYMBOL); + } + value = NIL; + } + if (sequential) + bindArg(specials.toArray(arrayToUseForSpecials), + symbol, value, ext, thread); + else + nonSequentialVars.add(new Cons(symbol, value)); + varList = ((Cons)varList).cdr; + } + if (!sequential) + { + for (Cons x : nonSequentialVars) + { + bindArg(specials.toArray(arrayToUseForSpecials), + (Symbol)x.car(), x.cdr(), ext, thread); + } + } + // Make sure free special declarations are visible in the body. + // "The scope of free declarations specifically does not include + // initialization forms for bindings established by the form + // containing the declarations." (3.3.4) + for (Symbol symbol : specials) + { + ext.declareSpecial(symbol); + } + return progn(body, ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + // ### symbol-macrolet + private static final SpecialOperator SYMBOL_MACROLET = + new SpecialOperator(Symbol.SYMBOL_MACROLET, "macrobindings &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject varList = checkList(args.car()); + final LispThread thread = LispThread.currentThread(); + if (varList != NIL) + { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + try + { + Environment ext = new Environment(env); + // Declare our free specials, this will correctly raise + LispObject body = ext.processDeclarations(args.cdr()); + + for (int i = varList.length(); i-- > 0;) + { + LispObject obj = varList.car(); + varList = varList.cdr(); + if (obj instanceof Cons && obj.length() == 2) + { + Symbol symbol = checkSymbol(obj.car()); + if (symbol.isSpecialVariable() + || ext.isDeclaredSpecial(symbol)) + { + return error(new ProgramError( + "Attempt to bind the special variable " + + symbol.writeToString() + + " with SYMBOL-MACROLET.")); + } + bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread); + } + else + { + return error(new ProgramError( + "Malformed symbol-expansion pair in SYMBOL-MACROLET: " + + obj.writeToString())); + } + } + return progn(body, ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + else + { + return progn(args.cdr(), env, thread); + } + } + }; + + // ### load-time-value form &optional read-only-p => object + private static final SpecialOperator LOAD_TIME_VALUE = + new SpecialOperator(Symbol.LOAD_TIME_VALUE, + "form &optional read-only-p") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + switch (args.length()) + { + case 1: + case 2: + return eval(args.car(), new Environment(), + LispThread.currentThread()); + default: + return error(new WrongNumberOfArgumentsException(this)); + } + } + }; + + // ### locally + private static final SpecialOperator LOCALLY = + new SpecialOperator(Symbol.LOCALLY, "&body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final Environment ext = new Environment(env); + args = ext.processDeclarations(args); + return progn(args, ext, thread); + } + }; + + // ### progn + private static final SpecialOperator PROGN = + new SpecialOperator(Symbol.PROGN, "&rest forms") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispThread thread = LispThread.currentThread(); + return progn(args, env, thread); + } + }; + + // ### flet + private static final SpecialOperator FLET = + new SpecialOperator(Symbol.FLET, "definitions &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + return _flet(args, env, false); + } + }; + + // ### labels + private static final SpecialOperator LABELS = + new SpecialOperator(Symbol.LABELS, "definitions &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + return _flet(args, env, true); + } + }; + + private static final LispObject _flet(LispObject args, Environment env, + boolean recursive) + throws ConditionThrowable + { + // First argument is a list of local function definitions. + LispObject defs = checkList(args.car()); + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + final Environment ext = new Environment(env); + while (defs != NIL) + { + final LispObject def = checkList(defs.car()); + final LispObject name = def.car(); + final Symbol symbol; + if (name instanceof Symbol) + { + symbol = checkSymbol(name); + if (symbol.getSymbolFunction() instanceof SpecialOperator) + { + String message = + symbol.getName() + " is a special operator and may not be redefined"; + return error(new ProgramError(message)); + } + } + else if (isValidSetfFunctionName(name)) + symbol = checkSymbol(name.cadr()); + else + return type_error(name, FUNCTION_NAME); + LispObject rest = def.cdr(); + LispObject parameters = rest.car(); + LispObject body = rest.cdr(); + LispObject decls = NIL; + while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) + { + decls = new Cons(body.car(), decls); + body = body.cdr(); + } + body = new Cons(symbol, body); + body = new Cons(Symbol.BLOCK, body); + body = new Cons(body, NIL); + while (decls != NIL) + { + body = new Cons(decls.car(), body); + decls = decls.cdr(); + } + LispObject lambda_expression = + new Cons(Symbol.LAMBDA, new Cons(parameters, body)); + LispObject lambda_name = + list2(recursive ? Symbol.LABELS : Symbol.FLET, name); + Closure closure = + new Closure(lambda_name, lambda_expression, + recursive ? ext : env); + ext.addFunctionBinding(name, closure); + defs = defs.cdr(); + } + try + { + final Environment innerEnv = new Environment(ext); + LispObject body = args.cdr(); + body = innerEnv.processDeclarations(body); + return progn(body, ext, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + // ### the value-type form => result* + private static final SpecialOperator THE = + new SpecialOperator(Symbol.THE, "type value") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() != 2) + return error(new WrongNumberOfArgumentsException(this)); + return eval(args.cadr(), env, LispThread.currentThread()); + } + }; + + // ### progv + private static final SpecialOperator PROGV = + new SpecialOperator(Symbol.PROGV, "symbols values &body body") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + if (args.length() < 2) + return error(new WrongNumberOfArgumentsException(this)); + final LispThread thread = LispThread.currentThread(); + final LispObject symbols = checkList(eval(args.car(), env, thread)); + LispObject values = checkList(eval(args.cadr(), env, thread)); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + try + { + // Set up the new bindings. + progvBindVars(symbols, values, thread); + // Implicit PROGN. + return progn(args.cdr().cdr(), env, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + }; + + // ### declare + private static final SpecialOperator DECLARE = + new SpecialOperator(Symbol.DECLARE, "&rest declaration-specifiers") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + while (args != NIL) + { + LispObject decl = args.car(); + args = args.cdr(); + if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) + { + LispObject vars = decl.cdr(); + while (vars != NIL) + { + Symbol var = checkSymbol(vars.car()); + env.declareSpecial(var); + vars = vars.cdr(); + } + } + } + return NIL; + } + }; + + // ### function + private static final SpecialOperator FUNCTION = + new SpecialOperator(Symbol.FUNCTION, "thing") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + final LispObject arg = args.car(); + if (arg instanceof Symbol) + { + LispObject operator = env.lookupFunction(arg); + if (operator instanceof Autoload) + { + Autoload autoload = (Autoload) operator; + autoload.load(); + operator = autoload.getSymbol().getSymbolFunction(); + } + if (operator instanceof Function) + return operator; + if (operator instanceof StandardGenericFunction) + return operator; + return error(new UndefinedFunction(arg)); + } + if (arg instanceof Cons) + { + LispObject car = ((Cons)arg).car; + if (car == Symbol.SETF) + { + LispObject f = env.lookupFunction(arg); + if (f != null) + return f; + Symbol symbol = checkSymbol(arg.cadr()); + f = get(symbol, Symbol.SETF_FUNCTION, null); + if (f != null) + return f; + f = get(symbol, Symbol.SETF_INVERSE, null); + if (f != null) + return f; + } + if (car == Symbol.LAMBDA) + return new Closure(arg, env); + if (car == Symbol.NAMED_LAMBDA) + { + LispObject name = arg.cadr(); + if (name instanceof Symbol || isValidSetfFunctionName(name)) + { + return new Closure(name, + new Cons(Symbol.LAMBDA, arg.cddr()), + env); + } + return type_error(name, FUNCTION_NAME); + } + } + return error(new UndefinedFunction(list2(Keyword.NAME, arg))); + } + }; + + // ### setq + private static final SpecialOperator SETQ = + new SpecialOperator(Symbol.SETQ, "&rest vars-and-values") + { + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject value = Symbol.NIL; + final LispThread thread = LispThread.currentThread(); + while (args != NIL) + { + Symbol symbol = checkSymbol(args.car()); + if (symbol.isConstant()) + { + return error(new ProgramError(symbol.writeToString() + + " is a constant and thus cannot be set.")); + } + args = args.cdr(); + if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) + { + SpecialBinding binding = thread.getSpecialBinding(symbol); + if (binding != null) + { + if (binding.value instanceof SymbolMacro) + { + LispObject expansion = + ((SymbolMacro)binding.value).getExpansion(); + LispObject form = list3(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } + else + { + value = eval(args.car(), env, thread); + binding.value = value; + } + } + else + { + if (symbol.getSymbolValue() instanceof SymbolMacro) + { + LispObject expansion = + ((SymbolMacro)symbol.getSymbolValue()).getExpansion(); + LispObject form = list3(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } + else + { + value = eval(args.car(), env, thread); + symbol.setSymbolValue(value); + } + } + } + else + { + // Not special. + Binding binding = env.getBinding(symbol); + if (binding != null) + { + if (binding.value instanceof SymbolMacro) + { + LispObject expansion = + ((SymbolMacro)binding.value).getExpansion(); + LispObject form = list3(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } + else + { + value = eval(args.car(), env, thread); + binding.value = value; + } + } + else + { + if (symbol.getSymbolValue() instanceof SymbolMacro) + { + LispObject expansion = + ((SymbolMacro)symbol.getSymbolValue()).getExpansion(); + LispObject form = list3(Symbol.SETF, expansion, args.car()); + value = eval(form, env, thread); + } + else + { + value = eval(args.car(), env, thread); + symbol.setSymbolValue(value); + } + } + } + args = args.cdr(); + } + // Return primary value only! + thread._values = null; + return value; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,483 @@ +/* + * StandardClass.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: StandardClass.java 11590 2009-01-25 23:34:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StandardClass extends SlotClass +{ + public StandardClass() + { + setClassLayout(new Layout(this, NIL, NIL)); + } + + public StandardClass(Symbol symbol, LispObject directSuperclasses) + { + super(symbol, directSuperclasses); + setClassLayout(new Layout(this, NIL, NIL)); + } + + @Override + public LispObject typeOf() + { + return Symbol.STANDARD_CLASS; + } + + @Override + public LispObject classOf() + { + return STANDARD_CLASS; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STANDARD_CLASS) + return T; + if (type == STANDARD_CLASS) + return T; + return super.typep(type); + } + + public LispObject allocateInstance() throws ConditionThrowable + { + Layout layout = getClassLayout(); + if (layout == null) + { + Symbol.ERROR.execute(Symbol.SIMPLE_ERROR, + Keyword.FORMAT_CONTROL, + new SimpleString("No layout for class ~S."), + Keyword.FORMAT_ARGUMENTS, + list1(this)); + } + return new StandardObject(this, layout.getLength()); + } + + @Override + public String writeToString() throws ConditionThrowable + { + FastStringBuffer sb = + new FastStringBuffer(Symbol.STANDARD_CLASS.writeToString()); + if (symbol != null) + { + sb.append(' '); + sb.append(symbol.writeToString()); + } + return unreadableString(sb.toString()); + } + + private static final StandardClass addStandardClass(Symbol name, + LispObject directSuperclasses) + { + StandardClass c = new StandardClass(name, directSuperclasses); + addClass(name, c); + return c; + } + + // At this point, BuiltInClass.java has not been completely loaded yet, and + // BuiltInClass.CLASS_T is null. So we need to call setDirectSuperclass() + // for STANDARD_CLASS and STANDARD_OBJECT in initializeStandardClasses() + // below. + public static final StandardClass STANDARD_CLASS = + addStandardClass(Symbol.STANDARD_CLASS, list1(BuiltInClass.CLASS_T)); + public static final StandardClass STANDARD_OBJECT = + addStandardClass(Symbol.STANDARD_OBJECT, list1(BuiltInClass.CLASS_T)); + + // BuiltInClass.FUNCTION is also null here (see previous comment). + public static final StandardClass GENERIC_FUNCTION = + addStandardClass(Symbol.GENERIC_FUNCTION, list2(BuiltInClass.FUNCTION, + STANDARD_OBJECT)); + + public static final StandardClass CLASS = + addStandardClass(Symbol.CLASS, list1(STANDARD_OBJECT)); + + public static final StandardClass BUILT_IN_CLASS = + addStandardClass(Symbol.BUILT_IN_CLASS, list1(CLASS)); + + public static final StandardClass JAVA_CLASS = + addStandardClass(Symbol.JAVA_CLASS, list1(CLASS)); + + public static final StandardClass FORWARD_REFERENCED_CLASS = + addStandardClass(Symbol.FORWARD_REFERENCED_CLASS, list1(CLASS)); + + public static final StandardClass STRUCTURE_CLASS = + addStandardClass(Symbol.STRUCTURE_CLASS, list1(CLASS)); + + public static final StandardClass CONDITION = + addStandardClass(Symbol.CONDITION, list1(STANDARD_OBJECT)); + + public static final StandardClass SIMPLE_CONDITION = + addStandardClass(Symbol.SIMPLE_CONDITION, list1(CONDITION)); + + public static final StandardClass WARNING = + addStandardClass(Symbol.WARNING, list1(CONDITION)); + + public static final StandardClass SIMPLE_WARNING = + addStandardClass(Symbol.SIMPLE_WARNING, list2(SIMPLE_CONDITION, WARNING)); + + public static final StandardClass STYLE_WARNING = + addStandardClass(Symbol.STYLE_WARNING, list1(WARNING)); + + public static final StandardClass SERIOUS_CONDITION = + addStandardClass(Symbol.SERIOUS_CONDITION, list1(CONDITION)); + + public static final StandardClass STORAGE_CONDITION = + addStandardClass(Symbol.STORAGE_CONDITION, list1(SERIOUS_CONDITION)); + + public static final StandardClass ERROR = + addStandardClass(Symbol.ERROR, list1(SERIOUS_CONDITION)); + + public static final StandardClass ARITHMETIC_ERROR = + addStandardClass(Symbol.ARITHMETIC_ERROR, list1(ERROR)); + + public static final StandardClass CELL_ERROR = + addStandardClass(Symbol.CELL_ERROR, list1(ERROR)); + + public static final StandardClass CONTROL_ERROR = + addStandardClass(Symbol.CONTROL_ERROR, list1(ERROR)); + + public static final StandardClass FILE_ERROR = + addStandardClass(Symbol.FILE_ERROR, list1(ERROR)); + + public static final StandardClass DIVISION_BY_ZERO = + addStandardClass(Symbol.DIVISION_BY_ZERO, list1(ARITHMETIC_ERROR)); + + public static final StandardClass FLOATING_POINT_INEXACT = + addStandardClass(Symbol.FLOATING_POINT_INEXACT, list1(ARITHMETIC_ERROR)); + + public static final StandardClass FLOATING_POINT_INVALID_OPERATION = + addStandardClass(Symbol.FLOATING_POINT_INVALID_OPERATION, list1(ARITHMETIC_ERROR)); + + public static final StandardClass FLOATING_POINT_OVERFLOW = + addStandardClass(Symbol.FLOATING_POINT_OVERFLOW, list1(ARITHMETIC_ERROR)); + + public static final StandardClass FLOATING_POINT_UNDERFLOW = + addStandardClass(Symbol.FLOATING_POINT_UNDERFLOW, list1(ARITHMETIC_ERROR)); + + public static final StandardClass PROGRAM_ERROR = + addStandardClass(Symbol.PROGRAM_ERROR, list1(ERROR)); + + public static final StandardClass PACKAGE_ERROR = + addStandardClass(Symbol.PACKAGE_ERROR, list1(ERROR)); + + public static final StandardClass STREAM_ERROR = + addStandardClass(Symbol.STREAM_ERROR, list1(ERROR)); + + public static final StandardClass PARSE_ERROR = + addStandardClass(Symbol.PARSE_ERROR, list1(ERROR)); + + public static final StandardClass PRINT_NOT_READABLE = + addStandardClass(Symbol.PRINT_NOT_READABLE, list1(ERROR)); + + public static final StandardClass READER_ERROR = + addStandardClass(Symbol.READER_ERROR, list2(PARSE_ERROR, STREAM_ERROR)); + + public static final StandardClass END_OF_FILE = + addStandardClass(Symbol.END_OF_FILE, list1(STREAM_ERROR)); + + public static final StandardClass SIMPLE_ERROR = + addStandardClass(Symbol.SIMPLE_ERROR, list2(SIMPLE_CONDITION, ERROR)); + + public static final StandardClass TYPE_ERROR = + addStandardClass(Symbol.TYPE_ERROR, list1(ERROR)); + + public static final StandardClass SIMPLE_TYPE_ERROR = + addStandardClass(Symbol.SIMPLE_TYPE_ERROR, list2(SIMPLE_CONDITION, + TYPE_ERROR)); + + public static final StandardClass UNBOUND_SLOT = + addStandardClass(Symbol.UNBOUND_SLOT, list1(CELL_ERROR)); + + public static final StandardClass UNBOUND_VARIABLE = + addStandardClass(Symbol.UNBOUND_VARIABLE, list1(CELL_ERROR)); + + public static final StandardClass UNDEFINED_FUNCTION = + addStandardClass(Symbol.UNDEFINED_FUNCTION, list1(CELL_ERROR)); + + public static final StandardClass COMPILER_ERROR = + addStandardClass(Symbol.COMPILER_ERROR, list1(CONDITION)); + + public static final StandardClass COMPILER_UNSUPPORTED_FEATURE_ERROR = + addStandardClass(Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR, + list1(CONDITION)); + + public static final StandardClass JAVA_EXCEPTION = + addStandardClass(Symbol.JAVA_EXCEPTION, list1(ERROR)); + + public static final StandardClass METHOD = + addStandardClass(Symbol.METHOD, list1(STANDARD_OBJECT)); + + public static final StandardClass STANDARD_METHOD = + new StandardMethodClass(); + static + { + addClass(Symbol.STANDARD_METHOD, STANDARD_METHOD); + } + + public static final StandardClass STANDARD_READER_METHOD = + new StandardReaderMethodClass(); + static + { + addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD); + } + + public static final StandardClass STANDARD_GENERIC_FUNCTION = + new StandardGenericFunctionClass(); + static + { + addClass(Symbol.STANDARD_GENERIC_FUNCTION, STANDARD_GENERIC_FUNCTION); + } + + public static final StandardClass SLOT_DEFINITION = + new SlotDefinitionClass(); + static + { + addClass(Symbol.SLOT_DEFINITION, SLOT_DEFINITION); + } + + public static void initializeStandardClasses() throws ConditionThrowable + { + // We need to call setDirectSuperclass() here for classes that have a + // BuiltInClass as a superclass. See comment above (at first mention of + // STANDARD_OBJECT). + STANDARD_CLASS.setDirectSuperclass(CLASS); + STANDARD_OBJECT.setDirectSuperclass(BuiltInClass.CLASS_T); + GENERIC_FUNCTION.setDirectSuperclasses(list2(BuiltInClass.FUNCTION, + STANDARD_OBJECT)); + + ARITHMETIC_ERROR.setCPL(ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, + CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + ARITHMETIC_ERROR.setDirectSlotDefinitions( + list2(new SlotDefinition(Symbol.OPERATION, + list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERATION"))), + new SlotDefinition(Symbol.OPERANDS, + list1(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS"))))); + BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + JAVA_CLASS.setCPL(JAVA_CLASS, CLASS, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + CELL_ERROR.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.NAME, + list1(Symbol.CELL_ERROR_NAME)))); + CLASS.setCPL(CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); + COMPILER_ERROR.setCPL(COMPILER_ERROR, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + COMPILER_UNSUPPORTED_FEATURE_ERROR.setCPL(COMPILER_UNSUPPORTED_FEATURE_ERROR, + CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + CONDITION.setCPL(CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + CONDITION.setDirectSlotDefinitions( + list2(new SlotDefinition(Symbol.FORMAT_CONTROL, + list1(Symbol.SIMPLE_CONDITION_FORMAT_CONTROL)), + new SlotDefinition(Symbol.FORMAT_ARGUMENTS, + list1(Symbol.SIMPLE_CONDITION_FORMAT_ARGUMENTS), + NIL))); + CONDITION.setDirectDefaultInitargs(list2(Keyword.FORMAT_ARGUMENTS, + // FIXME + new Closure(list3(Symbol.LAMBDA, NIL, NIL), + new Environment()))); + CONTROL_ERROR.setCPL(CONTROL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + DIVISION_BY_ZERO.setCPL(DIVISION_BY_ZERO, ARITHMETIC_ERROR, ERROR, + SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + END_OF_FILE.setCPL(END_OF_FILE, STREAM_ERROR, ERROR, SERIOUS_CONDITION, + CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + ERROR.setCPL(ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + FILE_ERROR.setCPL(FILE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + FILE_ERROR.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.PATHNAME, + list1(PACKAGE_CL.intern("FILE-ERROR-PATHNAME"))))); + FLOATING_POINT_INEXACT.setCPL(FLOATING_POINT_INEXACT, ARITHMETIC_ERROR, + ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + FLOATING_POINT_INVALID_OPERATION.setCPL(FLOATING_POINT_INVALID_OPERATION, + ARITHMETIC_ERROR, ERROR, + SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + FLOATING_POINT_OVERFLOW.setCPL(FLOATING_POINT_OVERFLOW, ARITHMETIC_ERROR, + ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + FLOATING_POINT_UNDERFLOW.setCPL(FLOATING_POINT_UNDERFLOW, ARITHMETIC_ERROR, + ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + FORWARD_REFERENCED_CLASS.setCPL(FORWARD_REFERENCED_CLASS, CLASS, + BuiltInClass.CLASS_T); + GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, STANDARD_OBJECT, + BuiltInClass.FUNCTION, + BuiltInClass.CLASS_T); + JAVA_EXCEPTION.setCPL(JAVA_EXCEPTION, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + JAVA_EXCEPTION.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.CAUSE, list1(Symbol.JAVA_EXCEPTION_CAUSE)))); + METHOD.setCPL(METHOD, STANDARD_OBJECT, BuiltInClass.CLASS_T); + PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + PACKAGE_ERROR.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.PACKAGE, + list1(PACKAGE_CL.intern("PACKAGE-ERROR-PACKAGE"))))); + PARSE_ERROR.setCPL(PARSE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + PRINT_NOT_READABLE.setCPL(PRINT_NOT_READABLE, ERROR, SERIOUS_CONDITION, + CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + PRINT_NOT_READABLE.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.OBJECT, + list1(PACKAGE_CL.intern("PRINT-NOT-READABLE-OBJECT"))))); + PROGRAM_ERROR.setCPL(PROGRAM_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + READER_ERROR.setCPL(READER_ERROR, PARSE_ERROR, STREAM_ERROR, ERROR, + SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + SERIOUS_CONDITION.setCPL(SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + SIMPLE_CONDITION.setCPL(SIMPLE_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + SIMPLE_ERROR.setCPL(SIMPLE_ERROR, SIMPLE_CONDITION, ERROR, + SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + SIMPLE_TYPE_ERROR.setDirectSuperclasses(list2(SIMPLE_CONDITION, + TYPE_ERROR)); + SIMPLE_TYPE_ERROR.setCPL(SIMPLE_TYPE_ERROR, SIMPLE_CONDITION, + TYPE_ERROR, ERROR, SERIOUS_CONDITION, + CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + SIMPLE_WARNING.setDirectSuperclasses(list2(SIMPLE_CONDITION, WARNING)); + SIMPLE_WARNING.setCPL(SIMPLE_WARNING, SIMPLE_CONDITION, WARNING, + CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + STANDARD_OBJECT.setCPL(STANDARD_OBJECT, BuiltInClass.CLASS_T); + STORAGE_CONDITION.setCPL(STORAGE_CONDITION, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + STREAM_ERROR.setCPL(STREAM_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + STREAM_ERROR.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.STREAM, + list1(PACKAGE_CL.intern("STREAM-ERROR-STREAM"))))); + STRUCTURE_CLASS.setCPL(STRUCTURE_CLASS, CLASS, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + STYLE_WARNING.setCPL(STYLE_WARNING, WARNING, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + TYPE_ERROR.setCPL(TYPE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + TYPE_ERROR.setDirectSlotDefinitions( + list2(new SlotDefinition(Symbol.DATUM, + list1(PACKAGE_CL.intern("TYPE-ERROR-DATUM"))), + new SlotDefinition(Symbol.EXPECTED_TYPE, + list1(PACKAGE_CL.intern("TYPE-ERROR-EXPECTED-TYPE"))))); + UNBOUND_SLOT.setCPL(UNBOUND_SLOT, CELL_ERROR, ERROR, SERIOUS_CONDITION, + CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + UNBOUND_SLOT.setDirectSlotDefinitions( + list1(new SlotDefinition(Symbol.INSTANCE, + list1(PACKAGE_CL.intern("UNBOUND-SLOT-INSTANCE"))))); + UNBOUND_VARIABLE.setCPL(UNBOUND_VARIABLE, CELL_ERROR, ERROR, + SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + UNDEFINED_FUNCTION.setCPL(UNDEFINED_FUNCTION, CELL_ERROR, ERROR, + SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + WARNING.setCPL(WARNING, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); + + // Condition classes. + ARITHMETIC_ERROR.finalizeClass(); + CELL_ERROR.finalizeClass(); + COMPILER_ERROR.finalizeClass(); + COMPILER_UNSUPPORTED_FEATURE_ERROR.finalizeClass(); + CONDITION.finalizeClass(); + CONTROL_ERROR.finalizeClass(); + DIVISION_BY_ZERO.finalizeClass(); + END_OF_FILE.finalizeClass(); + ERROR.finalizeClass(); + FILE_ERROR.finalizeClass(); + FLOATING_POINT_INEXACT.finalizeClass(); + FLOATING_POINT_INVALID_OPERATION.finalizeClass(); + FLOATING_POINT_OVERFLOW.finalizeClass(); + FLOATING_POINT_UNDERFLOW.finalizeClass(); + JAVA_EXCEPTION.finalizeClass(); + PACKAGE_ERROR.finalizeClass(); + PARSE_ERROR.finalizeClass(); + PRINT_NOT_READABLE.finalizeClass(); + PROGRAM_ERROR.finalizeClass(); + READER_ERROR.finalizeClass(); + SERIOUS_CONDITION.finalizeClass(); + SIMPLE_CONDITION.finalizeClass(); + SIMPLE_ERROR.finalizeClass(); + SIMPLE_TYPE_ERROR.finalizeClass(); + SIMPLE_WARNING.finalizeClass(); + STORAGE_CONDITION.finalizeClass(); + STREAM_ERROR.finalizeClass(); + STYLE_WARNING.finalizeClass(); + TYPE_ERROR.finalizeClass(); + UNBOUND_SLOT.finalizeClass(); + UNBOUND_VARIABLE.finalizeClass(); + UNDEFINED_FUNCTION.finalizeClass(); + WARNING.finalizeClass(); + + // SYS:SLOT-DEFINITION is constructed and finalized in + // SlotDefinitionClass.java, but we need to fill in a few things here. + Debug.assertTrue(SLOT_DEFINITION.isFinalized()); + SLOT_DEFINITION.setCPL(SLOT_DEFINITION, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + SLOT_DEFINITION.setDirectSlotDefinitions(SLOT_DEFINITION.getClassLayout().generateSlotDefinitions()); + // There are no inherited slots. + SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions()); + + // STANDARD-METHOD + Debug.assertTrue(STANDARD_METHOD.isFinalized()); + STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + STANDARD_METHOD.setDirectSlotDefinitions(STANDARD_METHOD.getClassLayout().generateSlotDefinitions()); + // There are no inherited slots. + STANDARD_METHOD.setSlotDefinitions(STANDARD_METHOD.getDirectSlotDefinitions()); + + // STANDARD-READER-METHOD + Debug.assertTrue(STANDARD_READER_METHOD.isFinalized()); + STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, STANDARD_METHOD, + METHOD, STANDARD_OBJECT, BuiltInClass.CLASS_T); + STANDARD_READER_METHOD.setSlotDefinitions(STANDARD_READER_METHOD.getClassLayout().generateSlotDefinitions()); + // All but the last slot are inherited. + STANDARD_READER_METHOD.setDirectSlotDefinitions(list1(STANDARD_READER_METHOD.getSlotDefinitions().reverse().car())); + + // STANDARD-GENERIC-FUNCTION + Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized()); + STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION, + GENERIC_FUNCTION, STANDARD_OBJECT, + BuiltInClass.FUNCTION, + BuiltInClass.CLASS_T); + STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions(STANDARD_GENERIC_FUNCTION.getClassLayout().generateSlotDefinitions()); + // There are no inherited slots. + STANDARD_GENERIC_FUNCTION.setSlotDefinitions(STANDARD_GENERIC_FUNCTION.getDirectSlotDefinitions()); + } +} Added: branches/save-image/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardGenericFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,864 @@ +/* + * StandardGenericFunction.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: StandardGenericFunction.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.HashMap; + +public final class StandardGenericFunction extends StandardObject +{ + private LispObject function; + + private int numberOfRequiredArgs; + + private HashMap cache; + private HashMap slotCache; + + public StandardGenericFunction() + { + super(StandardClass.STANDARD_GENERIC_FUNCTION, + StandardClass.STANDARD_GENERIC_FUNCTION.getClassLayout().getLength()); + } + + public StandardGenericFunction(String name, Package pkg, boolean exported, + Function function, LispObject lambdaList, + LispObject specializers) + { + this(); + try + { + Symbol symbol; + if (exported) + symbol = pkg.internAndExport(name.toUpperCase()); + else + symbol = pkg.intern(name.toUpperCase()); + symbol.setSymbolFunction(this); + this.function = function; + slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = symbol; + slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = + lambdaList; + slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = + lambdaList; + numberOfRequiredArgs = lambdaList.length(); + slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = + NIL; + StandardMethod method = + new StandardMethod(this, function, lambdaList, specializers); + slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = + list1(method); + slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = + StandardClass.STANDARD_METHOD; + slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = + Symbol.STANDARD; + slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = + NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = + NIL; + slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL; + } + catch (ConditionThrowable t) + { + Debug.assertTrue(false); + } + } + + private void finalizeInternal() + { + cache = null; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.COMPILED_FUNCTION) + { + if (function != null) + return function.typep(type); + else + return NIL; + } + if (type == Symbol.STANDARD_GENERIC_FUNCTION) + return T; + if (type == StandardClass.STANDARD_GENERIC_FUNCTION) + return T; + return super.typep(type); + } + + public LispObject getGenericFunctionName() + { + return slots[StandardGenericFunctionClass.SLOT_INDEX_NAME]; + } + + public void setGenericFunctionName(LispObject name) + { + slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = name; + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return function.execute(); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return function.execute(arg); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return function.execute(first, second); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return function.execute(first, second, third); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return function.execute(first, second, third, fourth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + return function.execute(first, second, third, fourth, + fifth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + return function.execute(first, second, third, fourth, + fifth, sixth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + return function.execute(first, second, third, fourth, + fifth, sixth, seventh); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + return function.execute(first, second, third, fourth, + fifth, sixth, seventh, eighth); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + return function.execute(args); + } + + @Override + public String writeToString() throws ConditionThrowable + { + LispObject name = getGenericFunctionName(); + if (name != null) + { + FastStringBuffer sb = new FastStringBuffer(); + sb.append(getLispClass().getSymbol().writeToString()); + sb.append(' '); + sb.append(name.writeToString()); + return unreadableString(sb.toString()); + } + return super.writeToString(); + } + + // Profiling. + private int callCount; + + @Override + public final int getCallCount() + { + return callCount; + } + + @Override + public void setCallCount(int n) + { + callCount = n; + } + + @Override + public final void incrementCallCount() + { + ++callCount; + } + + // AMOP (p. 216) specifies the following readers as generic functions: + // generic-function-argument-precedence-order + // generic-function-declarations + // generic-function-lambda-list + // generic-function-method-class + // generic-function-method-combination + // generic-function-methods + // generic-function-name + + // ### %generic-function-name + private static final Primitive _GENERIC_FUNCTION_NAME = + new Primitive("%generic-function-name", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### %set-generic-function-name + private static final Primitive _SET_GENERIC_FUNCTION_NAME = + new Primitive("%set-generic-function-name", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### %generic-function-lambda-list + private static final Primitive _GENERIC_FUNCTION_LAMBDA_LIST = + new Primitive("%generic-function-lambda-list", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### %set-generic-function-lambdaList + private static final Primitive _SET_GENERIC_FUNCTION_LAMBDA_LIST = + new Primitive("%set-generic-function-lambda-list", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### funcallable-instance-function funcallable-instance => function + private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION = + new Primitive("funcallable-instance-function", PACKAGE_MOP, false, + "funcallable-instance") + { + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).function; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-funcallable-instance-function funcallable-instance function => unspecified + // AMOP p. 230 + private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION = + new Primitive("set-funcallable-instance-function", PACKAGE_MOP, true, + "funcallable-instance function") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).function = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### gf-required-args + private static final Primitive GF_REQUIRED_ARGS = + new Primitive("gf-required-args", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### %set-gf-required-args + private static final Primitive _SET_GF_REQUIRED_ARGS = + new Primitive("%set-gf-required-args", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final StandardGenericFunction gf; + try + { + gf = (StandardGenericFunction) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + gf.slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = second; + gf.numberOfRequiredArgs = second.length(); + return second; + } + }; + + // ### generic-function-initial-methods + private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS = + new Primitive("generic-function-initial-methods", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-initial-methods + private static final Primitive SET_GENERIC_FUNCTION_INITIAL_METHODS = + new Primitive("set-generic-function-initial-methods", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### generic-function-methods + private static final Primitive GENERIC_FUNCTION_METHODS = + new Primitive("generic-function-methods", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-methods + private static final Primitive SET_GENERIC_FUNCTION_METHODS = + new Primitive("set-generic-function-methods", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### generic-function-method-class + private static final Primitive GENERIC_FUNCTION_METHOD_CLASS = + new Primitive("generic-function-method-class", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-method-class + private static final Primitive SET_GENERIC_FUNCTION_METHOD_CLASS = + new Primitive("set-generic-function-method-class", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### generic-function-method-combination + private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION = + new Primitive("generic-function-method-combination", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-method-combination + private static final Primitive SET_GENERIC_FUNCTION_METHOD_COMBINATION = + new Primitive("set-generic-function-method-combination", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_COMBINATION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### generic-function-argument-precedence-order + private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER = + new Primitive("generic-function-argument-precedence-order", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-argument-precedence-order + private static final Primitive SET_GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER = + new Primitive("set-generic-function-argument-precedence-order", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### generic-function-classes-to-emf-table + private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE = + new Primitive("generic-function-classes-to-emf-table", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-classes-to-emf-table + private static final Primitive SET_GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE = + new Primitive("set-generic-function-classes-to-emf-table", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### generic-function-documentation + private static final Primitive GENERIC_FUNCTION_DOCUMENTATION = + new Primitive("generic-function-documentation", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### set-generic-function-documentation + private static final Primitive SET_GENERIC_FUNCTION_DOCUMENTATION = + new Primitive("set-generic-function-documentation", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + } + }; + + // ### %finalize-generic-function + private static final Primitive _FINALIZE_GENERIC_FUNCTION = + new Primitive("%finalize-generic-function", PACKAGE_SYS, true, + "generic-function") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final StandardGenericFunction gf; + try + { + gf = (StandardGenericFunction) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_GENERIC_FUNCTION); + } + gf.finalizeInternal(); + return T; + } + }; + + // ### cache-emf + private static final Primitive CACHE_EMF = + new Primitive("cache-emf", PACKAGE_SYS, true, "generic-function args emf") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final StandardGenericFunction gf; + try + { + gf = (StandardGenericFunction) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + LispObject args = second; + LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; + for (int i = gf.numberOfRequiredArgs; i-- > 0;) + { + array[i] = args.car().classOf(); + args = args.cdr(); + } + CacheEntry classes = new CacheEntry(array); + HashMap ht = gf.cache; + if (ht == null) + ht = gf.cache = new HashMap(); + ht.put(classes, third); + return third; + } + }; + + // ### get-cached-emf + private static final Primitive GET_CACHED_EMF = + new Primitive("get-cached-emf", PACKAGE_SYS, true, "generic-function args") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final StandardGenericFunction gf; + try + { + gf = (StandardGenericFunction) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + LispObject args = second; + LispObject[] array = new LispObject[gf.numberOfRequiredArgs]; + for (int i = gf.numberOfRequiredArgs; i-- > 0;) + { + array[i] = args.car().classOf(); + args = args.cdr(); + } + CacheEntry classes = new CacheEntry(array); + HashMap ht = gf.cache; + if (ht == null) + return NIL; + LispObject emf = (LispObject) ht.get(classes); + return emf != null ? emf : NIL; + } + }; + + // ### cache-slot-location + private static final Primitive CACHE_SLOT_LOCATION = + new Primitive("cache-slot-location", PACKAGE_SYS, true, "generic-function layout location") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final StandardGenericFunction gf; + try + { + gf = (StandardGenericFunction) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + LispObject layout = second; + LispObject location = third; + HashMap ht = gf.slotCache; + if (ht == null) + ht = gf.slotCache = new HashMap(); + ht.put(layout, location); + return third; + } + }; + + // ### get-cached-slot-location + private static final Primitive GET_CACHED_SLOT_LOCATION = + new Primitive("get-cached-slot-location", PACKAGE_SYS, true, "generic-function layout") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final StandardGenericFunction gf; + try + { + gf = (StandardGenericFunction) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_GENERIC_FUNCTION); + } + LispObject layout = second; + HashMap ht = gf.slotCache; + if (ht == null) + return NIL; + LispObject location = (LispObject) ht.get(layout); + return location != null ? location : NIL; + } + }; + + private static final StandardGenericFunction GENERIC_FUNCTION_NAME = + new StandardGenericFunction("generic-function-name", + PACKAGE_MOP, + true, + _GENERIC_FUNCTION_NAME, + list1(Symbol.GENERIC_FUNCTION), + list1(StandardClass.STANDARD_GENERIC_FUNCTION)); + + private static class CacheEntry implements java.io.Serializable + { + final LispObject[] array; + + CacheEntry(LispObject[] array) + { + this.array = array; + } + + @Override + public int hashCode() + { + int result = 0; + for (int i = array.length; i-- > 0;) + result ^= array[i].hashCode(); + return result; + } + + @Override + public boolean equals(Object object) + { + if (!(object instanceof CacheEntry)) + return false; + final CacheEntry otherEntry = (CacheEntry) object; + if (otherEntry.array.length != array.length) + return false; + final LispObject[] otherArray = otherEntry.array; + for (int i = array.length; i-- > 0;) + if (array[i] != otherArray[i]) + return false; + return true; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/StandardGenericFunctionClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardGenericFunctionClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,76 @@ +/* + * StandardGenericFunctionClass.java + * + * Copyright (C) 2005 Peter Graves + * $Id: StandardGenericFunctionClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StandardGenericFunctionClass extends StandardClass +{ + public static final int SLOT_INDEX_NAME = 0; + public static final int SLOT_INDEX_LAMBDA_LIST = 1; + public static final int SLOT_INDEX_REQUIRED_ARGS = 2; + public static final int SLOT_INDEX_INITIAL_METHODS = 3; + public static final int SLOT_INDEX_METHODS = 4; + public static final int SLOT_INDEX_METHOD_CLASS = 5; + public static final int SLOT_INDEX_METHOD_COMBINATION = 6; + public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 7; + public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 8; + public static final int SLOT_INDEX_DOCUMENTATION = 9; + + public StandardGenericFunctionClass() + { + super(Symbol.STANDARD_GENERIC_FUNCTION, + list1(StandardClass.GENERIC_FUNCTION)); + Package pkg = PACKAGE_SYS; + LispObject[] instanceSlotNames = + { + pkg.intern("NAME"), + pkg.intern("LAMBDA-LIST"), + pkg.intern("REQUIRED-ARGS"), + pkg.intern("INITIAL-METHODS"), + pkg.intern("METHODS"), + pkg.intern("METHOD-CLASS"), + pkg.intern("METHOD-COMBINATION"), + pkg.intern("ARGUMENT-PRECEDENCE-ORDER"), + pkg.intern("CLASSES-TO-EMF-TABLE"), + Symbol.DOCUMENTATION + }; + setClassLayout(new Layout(this, instanceSlotNames, NIL)); + setFinalized(true); + } + + @Override + public LispObject allocateInstance() + { + return new StandardGenericFunction(); + } +} Added: branches/save-image/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardMethod.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,397 @@ +/* + * StandardMethod.java + * + * Copyright (C) 2005 Peter Graves + * $Id: StandardMethod.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StandardMethod extends StandardObject +{ + public StandardMethod() + { + super(StandardClass.STANDARD_METHOD, + StandardClass.STANDARD_METHOD.getClassLayout().getLength()); + } + + protected StandardMethod(LispClass cls, int length) + { + super(cls, length); + } + + public StandardMethod(StandardGenericFunction gf, + Function fastFunction, + LispObject lambdaList, + LispObject specializers) + { + this(); + slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = gf; + slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = lambdaList; + slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = specializers; + slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = NIL; + slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = NIL; + slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION] = fastFunction; + slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = NIL; + } + + // ### method-lambda-list + // generic function + private static final Primitive METHOD_LAMBDA_LIST = + new Primitive("method-lambda-list", PACKAGE_SYS, true, "method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_METHOD); + } + } + }; + + // ### set-method-lambda-list + private static final Primitive SET_METHOD_LAMBDA_LIST = + new Primitive("set-method-lambda-list", PACKAGE_SYS, true, + "method lambda-list") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_METHOD); + } + } + }; + + // ### method-qualifiers + private static final Primitive _METHOD_QUALIFIERS = + new Primitive("%method-qualifiers", PACKAGE_SYS, true, "method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_METHOD); + } + } + }; + + // ### set-method-qualifiers + private static final Primitive SET_METHOD_QUALIFIERS = + new Primitive("set-method-qualifiers", PACKAGE_SYS, true, + "method qualifiers") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_METHOD); + } + } + }; + + // ### method-documentation + private static final Primitive METHOD_DOCUMENTATION = + new Primitive("method-documentation", PACKAGE_SYS, true, "method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_METHOD); + } + } + }; + + // ### set-method-documentation + private static final Primitive SET_METHOD_DOCUMENTATION = + new Primitive("set-method-documentation", PACKAGE_SYS, true, + "method documentation") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_METHOD); + } + } + }; + + public LispObject getFunction() + { + return slots[StandardMethodClass.SLOT_INDEX_FUNCTION]; + } + + @Override + public String writeToString() throws ConditionThrowable + { + LispObject genericFunction = + slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION]; + if (genericFunction instanceof StandardGenericFunction) + { + LispObject name = + ((StandardGenericFunction)genericFunction).getGenericFunctionName(); + if (name != null) + { + FastStringBuffer sb = new FastStringBuffer(); + sb.append(getLispClass().getSymbol().writeToString()); + sb.append(' '); + sb.append(name.writeToString()); + LispObject specializers = + slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS]; + if (specializers != null) + { + LispObject specs = specializers; + LispObject names = NIL; + while (specs != NIL) + { + LispObject spec = specs.car(); + if (spec instanceof LispClass) + names = names.push(((LispClass)spec).getSymbol()); + else + names = names.push(spec); + specs = specs.cdr(); + } + sb.append(' '); + sb.append(names.nreverse().writeToString()); + } + return unreadableString(sb.toString()); + } + } + return super.writeToString(); + } + + // ### %method-generic-function + private static final Primitive _METHOD_GENERIC_FUNCTION = + new Primitive("%method-generic-function", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.METHOD); + } + } + }; + + // ### %set-method-generic-function + private static final Primitive _SET_METHOD_GENERICFUNCTION = + new Primitive("%set-method-generic-function", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.METHOD); + } + } + }; + + // ### %method-function + private static final Primitive _METHOD_FUNCTION = + new Primitive("%method-function", PACKAGE_SYS, true, "method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_FUNCTION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.METHOD); + } + } + }; + + // ### %set-method-function + private static final Primitive _SET_METHOD_FUNCTION = + new Primitive("%set-method-function", PACKAGE_SYS, true, + "method function") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.METHOD); + } + } + }; + + // ### %method-fast-function + private static final Primitive _METHOD_FAST_FUNCTION = + new Primitive("%method-fast-function", PACKAGE_SYS, true, "method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.METHOD); + } + } + }; + + // ### %set-method-fast-function + private static final Primitive _SET_METHOD_FAST_FUNCTION = + new Primitive("%set-method-fast-function", PACKAGE_SYS, true, + "method fast-function") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_FAST_FUNCTION] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.METHOD); + } + } + }; + + // ### %method-specializers + private static final Primitive _METHOD_SPECIALIZERS = + new Primitive("%method-specializers", PACKAGE_SYS, true, "method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardMethod)arg).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.METHOD); + } + } + }; + + // ### %set-method-specializers + private static final Primitive _SET_METHOD_SPECIALIZERS = + new Primitive("%set-method-specializers", PACKAGE_SYS, true, + "method specializers") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardMethod)first).slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.METHOD); + } + } + }; + + private static final StandardGenericFunction METHOD_SPECIALIZERS = + new StandardGenericFunction("method-specializers", + PACKAGE_MOP, + true, + _METHOD_SPECIALIZERS, + list1(Symbol.METHOD), + list1(StandardClass.STANDARD_METHOD)); + + private static final StandardGenericFunction METHOD_QUALIFIERS = + new StandardGenericFunction("method-qualifiers", + PACKAGE_MOP, + true, + _METHOD_QUALIFIERS, + list1(Symbol.METHOD), + list1(StandardClass.STANDARD_METHOD)); + +} Added: branches/save-image/src/org/armedbear/lisp/StandardMethodClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardMethodClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,69 @@ +/* + * StandardMethodClass.java + * + * Copyright (C) 2005 Peter Graves + * $Id: StandardMethodClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StandardMethodClass extends StandardClass +{ + public static final int SLOT_INDEX_GENERIC_FUNCTION = 0; + public static final int SLOT_INDEX_LAMBDA_LIST = 1; + public static final int SLOT_INDEX_SPECIALIZERS = 2; + public static final int SLOT_INDEX_QUALIFIERS = 3; + public static final int SLOT_INDEX_FUNCTION = 4; + public static final int SLOT_INDEX_FAST_FUNCTION = 5; + public static final int SLOT_INDEX_DOCUMENTATION = 6; + + public StandardMethodClass() + { + super(Symbol.STANDARD_METHOD, list1(StandardClass.METHOD)); + Package pkg = PACKAGE_SYS; + LispObject[] instanceSlotNames = + { + Symbol.GENERIC_FUNCTION, + pkg.intern("LAMBDA-LIST"), + pkg.intern("SPECIALIZERS"), + pkg.intern("QUALIFIERS"), + Symbol.FUNCTION, + pkg.intern("FAST-FUNCTION"), + Symbol.DOCUMENTATION + }; + setClassLayout(new Layout(this, instanceSlotNames, NIL)); + setFinalized(true); + } + + @Override + public LispObject allocateInstance() + { + return new StandardMethod(); + } +} Added: branches/save-image/src/org/armedbear/lisp/StandardObject.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardObject.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,582 @@ +/* + * StandardObject.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: StandardObject.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StandardObject extends LispObject +{ + protected Layout layout; + protected LispObject[] slots; + + protected StandardObject() + { + layout = new Layout(StandardClass.STANDARD_OBJECT, NIL, NIL); + } + + protected StandardObject(LispClass cls, int length) + { + layout = cls.getClassLayout(); + slots = new LispObject[length]; + for (int i = slots.length; i-- > 0;) + slots[i] = UNBOUND_VALUE; + } + + protected StandardObject(LispClass cls) + { + layout = cls.getClassLayout(); + slots = new LispObject[layout.getLength()]; + for (int i = slots.length; i-- > 0;) + slots[i] = UNBOUND_VALUE; + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject parts = NIL; + if (layout != null) + { + if (layout.isInvalid()) + { + // Update instance. + layout = updateLayout(); + } + } + parts = parts.push(new Cons("LAYOUT", layout)); + if (layout != null) + { + LispObject[] slotNames = layout.getSlotNames(); + if (slotNames != null) + { + for (int i = 0; i < slotNames.length; i++) + { + parts = parts.push(new Cons(slotNames[i], slots[i])); + } + } + } + return parts.nreverse(); + } + + public final LispClass getLispClass() + { + return layout.lispClass; + } + + @Override + public LispObject typeOf() + { + // "For objects of metaclass STRUCTURE-CLASS or STANDARD-CLASS, and for + // conditions, TYPE-OF returns the proper name of the class returned by + // CLASS-OF if it has a proper name, and otherwise returns the class + // itself." + final LispClass c1 = layout.lispClass; + // The proper name of a class is "a symbol that names the class whose + // name is that symbol". + final Symbol symbol = c1.getSymbol(); + if (symbol != NIL) + { + // TYPE-OF.9 + final LispObject c2 = LispClass.findClass(symbol); + if (c2 == c1) + return symbol; + } + return c1; + } + + @Override + public LispObject classOf() + { + return layout.lispClass; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STANDARD_OBJECT) + return T; + if (type == StandardClass.STANDARD_OBJECT) + return T; + LispClass cls = layout != null ? layout.lispClass : null; + if (cls != null) + { + if (type == cls) + return T; + if (type == cls.getSymbol()) + return T; + LispObject cpl = cls.getCPL(); + while (cpl != NIL) + { + if (type == cpl.car()) + return T; + if (type == ((LispClass)cpl.car()).getSymbol()) + return T; + cpl = cpl.cdr(); + } + } + return super.typep(type); + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + int maxLevel = Integer.MAX_VALUE; + LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = Fixnum.getValue(currentPrintLevel); + if (currentLevel >= maxLevel) + return "#"; + if (typep(Symbol.CONDITION) != NIL) + { + StringOutputStream stream = new StringOutputStream(); + Symbol.PRINT_OBJECT.execute(this, stream); + return stream.getString().getStringValue(); + } + return unreadableString(typeOf().writeToString()); + } + + private Layout updateLayout() throws ConditionThrowable + { + Debug.assertTrue(layout.isInvalid()); + Layout oldLayout = layout; + LispClass cls = oldLayout.lispClass; + Layout newLayout = cls.getClassLayout(); + Debug.assertTrue(!newLayout.isInvalid()); + StandardObject newInstance = new StandardObject(cls); + Debug.assertTrue(newInstance.layout == newLayout); + LispObject added = NIL; + LispObject discarded = NIL; + LispObject plist = NIL; + // Old local slots. + LispObject[] oldSlotNames = oldLayout.getSlotNames(); + for (int i = 0; i < oldSlotNames.length; i++) + { + LispObject slotName = oldSlotNames[i]; + int j = newLayout.getSlotIndex(slotName); + if (j >= 0) + newInstance.slots[j] = slots[i]; + else + { + discarded = discarded.push(slotName); + if (slots[i] != UNBOUND_VALUE) + { + plist = plist.push(slotName); + plist = plist.push(slots[i]); + } + } + } + // Old shared slots. + LispObject rest = oldLayout.getSharedSlots(); // A list. + if (rest != null) + { + while (rest != NIL) + { + LispObject location = rest.car(); + LispObject slotName = location.car(); + int i = newLayout.getSlotIndex(slotName); + if (i >= 0) + newInstance.slots[i] = location.cdr(); + rest = rest.cdr(); + } + } + // Go through all the new local slots to compute the added slots. + LispObject[] newSlotNames = newLayout.getSlotNames(); + for (int i = 0; i < newSlotNames.length; i++) + { + LispObject slotName = newSlotNames[i]; + int j = oldLayout.getSlotIndex(slotName); + if (j >= 0) + continue; + LispObject location = oldLayout.getSharedSlotLocation(slotName); + if (location != null) + continue; + // Not found. + added = added.push(slotName); + } + // Swap slots. + LispObject[] tempSlots = slots; + slots = newInstance.slots; + newInstance.slots = tempSlots; + // Swap layouts. + Layout tempLayout = layout; + layout = newInstance.layout; + newInstance.layout = tempLayout; + Debug.assertTrue(!layout.isInvalid()); + // Call UPDATE-INSTANCE-FOR-REDEFINED-CLASS. + Symbol.UPDATE_INSTANCE_FOR_REDEFINED_CLASS.execute(this, added, + discarded, plist); + return newLayout; + } + + // Only handles instance slots (not shared slots). + public LispObject getInstanceSlotValue(LispObject slotName) + throws ConditionThrowable + { + Debug.assertTrue(layout != null); + if (layout.isInvalid()) + { + // Update instance. + layout = updateLayout(); + } + Debug.assertTrue(layout != null); + int index = layout.getSlotIndex(slotName); + Debug.assertTrue(index >= 0); + return slots[index]; + } + + // Only handles instance slots (not shared slots). + public void setInstanceSlotValue(LispObject slotName, LispObject newValue) + throws ConditionThrowable + { + Debug.assertTrue(layout != null); + if (layout.isInvalid()) + { + // Update instance. + layout = updateLayout(); + } + Debug.assertTrue(layout != null); + int index = layout.getSlotIndex(slotName); + Debug.assertTrue(index >= 0); + slots[index] = newValue; + } + + // ### swap-slots instance-1 instance-2 => nil + private static final Primitive SWAP_SLOTS = + new Primitive("swap-slots", PACKAGE_SYS, true, "instance-1 instance-2") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + StandardObject obj1, obj2; + try + { + obj1 = (StandardObject) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_OBJECT); + } + try + { + obj2 = (StandardObject) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STANDARD_OBJECT); + } + LispObject[] temp = obj1.slots; + obj1.slots = obj2.slots; + obj2.slots = temp; + return NIL; + } + }; + + // ### std-instance-layout + private static final Primitive STD_INSTANCE_LAYOUT = + new Primitive("std-instance-layout", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final StandardObject instance; + try + { + instance = (StandardObject) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_OBJECT); + } + Layout layout = instance.layout; + if (layout.isInvalid()) + { + // Update instance. + layout = instance.updateLayout(); + } + return layout; + } + }; + + // ### %set-std-instance-layout + private static final Primitive _SET_STD_INSTANCE_LAYOUT = + new Primitive("%set-std-instance-layout", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardObject)first).layout = (Layout) second; + return second; + } + catch (ClassCastException e) + { + if (!(first instanceof StandardObject)) + return type_error(first, Symbol.STANDARD_OBJECT); + if (!(second instanceof Layout)) + return type_error(second, Symbol.LAYOUT); + // Not reached. + return NIL; + } + } + }; + + // ### std-instance-class + private static final Primitive STD_INSTANCE_CLASS = + new Primitive("std-instance-class", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardObject)arg).layout.lispClass; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_OBJECT); + } + } + }; + + // ### standard-instance-access instance location => value + private static final Primitive STANDARD_INSTANCE_ACCESS = + new Primitive("standard-instance-access", PACKAGE_SYS, true, + "instance location") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final StandardObject instance; + try + { + instance = (StandardObject) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_OBJECT); + } + final int index; + try + { + index = ((Fixnum)second).value; + } + catch (ClassCastException e) + { + return type_error(second, + list3(Symbol.INTEGER, Fixnum.ZERO, + new Fixnum(instance.slots.length))); + } + LispObject value; + try + { + value = instance.slots[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return type_error(second, + list3(Symbol.INTEGER, Fixnum.ZERO, + new Fixnum(instance.slots.length))); + } + if (value == UNBOUND_VALUE) + { + LispObject slotName = instance.layout.getSlotNames()[index]; + value = Symbol.SLOT_UNBOUND.execute(instance.getLispClass(), + instance, slotName); + LispThread.currentThread()._values = null; + } + return value; + } + }; + + // ### %set-standard-instance-access instance location new-value => new-value + private static final Primitive _SET_STANDARD_INSTANCE_ACCESS = + new Primitive("%set-standard-instance-access", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try + { + ((StandardObject)first).slots[Fixnum.getValue(second)] = third; // FIXME + return third; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_OBJECT); + } + } + }; + + // ### std-slot-boundp + private static final Primitive STD_SLOT_BOUNDP = + new Primitive(Symbol.STD_SLOT_BOUNDP, "instance slot-name") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final StandardObject instance; + try + { + instance = (StandardObject) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_OBJECT); + } + Layout layout = instance.layout; + if (layout.isInvalid()) + { + // Update instance. + layout = instance.updateLayout(); + } + final LispObject index = layout.slotTable.get(second); + if (index != null) + { + // Found instance slot. + return instance.slots[((Fixnum)index).value] != UNBOUND_VALUE ? T : NIL; + } + // Check for shared slot. + final LispObject location = layout.getSharedSlotLocation(second); + if (location != null) + return location.cdr() != UNBOUND_VALUE ? T : NIL; + // Not found. + final LispThread thread = LispThread.currentThread(); + LispObject value = + thread.execute(Symbol.SLOT_MISSING, instance.getLispClass(), + instance, second, Symbol.SLOT_BOUNDP); + // "If SLOT-MISSING is invoked and returns a value, a boolean + // equivalent to its primary value is returned by SLOT-BOUNDP." + thread._values = null; + return value != NIL ? T : NIL; + } + }; + + @Override + public LispObject SLOT_VALUE(LispObject slotName) throws ConditionThrowable + { + if (layout.isInvalid()) + { + // Update instance. + layout = updateLayout(); + } + LispObject value; + final LispObject index = layout.slotTable.get(slotName); + if (index != null) + { + // Found instance slot. + value = slots[((Fixnum)index).value]; + } + else + { + // Check for shared slot. + LispObject location = layout.getSharedSlotLocation(slotName); + if (location == null) + return Symbol.SLOT_MISSING.execute(getLispClass(), this, slotName, + Symbol.SLOT_VALUE); + value = location.cdr(); + } + if (value == UNBOUND_VALUE) + { + value = Symbol.SLOT_UNBOUND.execute(getLispClass(), this, slotName); + LispThread.currentThread()._values = null; + } + return value; + } + + // ### std-slot-value + private static final Primitive STD_SLOT_VALUE = + new Primitive(Symbol.STD_SLOT_VALUE, "instance slot-name") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.SLOT_VALUE(second); + } + }; + + @Override + public void setSlotValue(LispObject slotName, LispObject newValue) + throws ConditionThrowable + { + if (layout.isInvalid()) + { + // Update instance. + layout = updateLayout(); + } + final LispObject index = layout.slotTable.get(slotName); + if (index != null) + { + // Found instance slot. + slots[((Fixnum)index).value] = newValue; + return; + } + // Check for shared slot. + LispObject location = layout.getSharedSlotLocation(slotName); + if (location != null) + { + location.setCdr(newValue); + return; + } + LispObject[] args = new LispObject[5]; + args[0] = getLispClass(); + args[1] = this; + args[2] = slotName; + args[3] = Symbol.SETF; + args[4] = newValue; + Symbol.SLOT_MISSING.execute(args); + } + + // ### set-std-slot-value + private static final Primitive SET_STD_SLOT_VALUE = + new Primitive(Symbol.SET_STD_SLOT_VALUE, "instance slot-name new-value") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + first.setSlotValue(second, third); + return third; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StandardObjectFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardObjectFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,59 @@ +/* + * StandardObjectFunctions.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: StandardObjectFunctions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StandardObjectFunctions extends Lisp +{ + // ### std-allocate-instance class => instance + private static final Primitive STD_ALLOCATE_INSTANCE = + new Primitive("std-allocate-instance", PACKAGE_SYS, true, "class") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == StandardClass.STANDARD_CLASS) + return new StandardClass(); + final StandardClass c; + try + { + c = (StandardClass) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_CLASS); + } + return c.allocateInstance(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StandardReaderMethod.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardReaderMethod.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,82 @@ +/* + * StandardReaderMethod.java + * + * Copyright (C) 2005 Peter Graves + * $Id: StandardReaderMethod.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StandardReaderMethod extends StandardMethod +{ + public StandardReaderMethod() + { + super(StandardClass.STANDARD_READER_METHOD, + StandardClass.STANDARD_READER_METHOD.getClassLayout().getLength()); + } + + // ### reader-method-slot-name + private static final Primitive READER_METHOD_SLOT_NAME = + new Primitive("reader-method-slot-name", PACKAGE_MOP, false, "reader-method") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((StandardReaderMethod)arg).slots[StandardReaderMethodClass.SLOT_INDEX_SLOT_NAME]; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STANDARD_READER_METHOD); + } + } + }; + + // ### set-reader-method-slot-name + private static final Primitive SET_READER_METHOD_SLOT_NAME = + new Primitive("set-reader-method-slot-name", PACKAGE_MOP, false, + "reader-method slot-name") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((StandardReaderMethod)first).slots[StandardReaderMethodClass.SLOT_INDEX_SLOT_NAME] = second; + return second; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STANDARD_READER_METHOD); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StandardReaderMethodClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StandardReaderMethodClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,75 @@ +/* + * StandardReaderMethodClass.java + * + * Copyright (C) 2005 Peter Graves + * $Id: StandardReaderMethodClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StandardReaderMethodClass extends StandardClass +{ + // From StandardMethodClass.java: + public static final int SLOT_INDEX_GENERIC_FUNCTION = 0; + public static final int SLOT_INDEX_LAMBDA_LIST = 1; + public static final int SLOT_INDEX_SPECIALIZERS = 2; + public static final int SLOT_INDEX_QUALIFIERS = 3; + public static final int SLOT_INDEX_FUNCTION = 4; + public static final int SLOT_INDEX_FAST_FUNCTION = 5; + public static final int SLOT_INDEX_DOCUMENTATION = 6; + + // Added: + public static final int SLOT_INDEX_SLOT_NAME = 7; + + public StandardReaderMethodClass() + { + super(Symbol.STANDARD_READER_METHOD, + list1(StandardClass.STANDARD_READER_METHOD)); + Package pkg = PACKAGE_SYS; + LispObject[] instanceSlotNames = + { + Symbol.GENERIC_FUNCTION, + pkg.intern("LAMBDA-LIST"), + pkg.intern("SPECIALIZERS"), + pkg.intern("QUALIFIERS"), + Symbol.FUNCTION, + pkg.intern("FAST-FUNCTION"), + Symbol.DOCUMENTATION, + pkg.intern("SLOT-NAME") + }; + setClassLayout(new Layout(this, instanceSlotNames, NIL)); + setFinalized(true); + } + + @Override + public LispObject allocateInstance() + { + return new StandardReaderMethod(); + } +} Added: branches/save-image/src/org/armedbear/lisp/StorageCondition.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StorageCondition.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,73 @@ +/* + * StorageCondition.java + * + * Copyright (C) 2004-2007 Peter Graves + * $Id: StorageCondition.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StorageCondition extends SeriousCondition +{ + public StorageCondition() throws ConditionThrowable + { + } + + public StorageCondition(LispObject initArgs) throws ConditionThrowable + { + super(initArgs); + } + + public StorageCondition(String message) + { + super(message); + } + + @Override + public LispObject typeOf() + { + return Symbol.STORAGE_CONDITION; + } + + @Override + public LispObject classOf() + { + return StandardClass.STORAGE_CONDITION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STORAGE_CONDITION) + return T; + if (type == StandardClass.STORAGE_CONDITION) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Stream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Stream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,3044 @@ +/* + * Stream.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Stream.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.BufferedInputStream; +import java.io.BufferedOutputStream; +import java.io.BufferedReader; +import java.io.IOException; +import java.io.InputStream; +import java.io.InputStreamReader; +import java.io.OutputStream; +import java.io.OutputStreamWriter; +import java.io.PrintWriter; +import java.io.PushbackReader; +import java.io.Reader; +import java.io.StringWriter; +import java.io.Writer; +import java.math.BigInteger; +import java.nio.charset.Charset; +import java.util.BitSet; + + +/** The stream class + * + * A base class for all Lisp built-in streams. + * + */ +public class Stream extends LispObject +{ + protected LispObject elementType; + protected boolean isInputStream; + protected boolean isOutputStream; + protected boolean isCharacterStream; + protected boolean isBinaryStream; + + private boolean pastEnd = false; + private boolean interactive; + private boolean open = true; + + // Character input. + protected transient PushbackReader reader; //provvisorio finch? non capisco chi serializza lo stream + protected int offset; + protected int lineNumber; + + // Character output. + private transient Writer writer; + + /** The number of characters on the current line of output + * + * Used to determine whether additional line feeds are + * required when calling FRESH-LINE + */ + protected int charPos; + + public enum EolStyle { + RAW, + CR, + CRLF, + LF + } + + static final protected Symbol keywordDefault = Packages.internKeyword("DEFAULT"); + + static final private Symbol keywordCodePage = Packages.internKeyword("CODE-PAGE"); + static final private Symbol keywordID = Packages.internKeyword("ID"); + + static final private Symbol keywordEolStyle = Packages.internKeyword("EOL-STYLE"); + static final private Symbol keywordCR = Packages.internKeyword("CR"); + static final private Symbol keywordLF = Packages.internKeyword("LF"); + static final private Symbol keywordCRLF = Packages.internKeyword("CRLF"); + static final private Symbol keywordRAW = Packages.internKeyword("RAW"); + + public final static EolStyle platformEolStyle = Utilities.isPlatformWindows ? EolStyle.CRLF : EolStyle.LF; + + protected EolStyle eolStyle = platformEolStyle; + protected char eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + protected LispObject externalFormat = LispObject.NIL; + protected String encoding = null; + protected char lastChar = 0; + + // Binary input. + private transient InputStream in; + + // Binary output. + private transient OutputStream out; + + protected Stream() + { + } + + public Stream(InputStream inputStream, LispObject elementType) + { + this(inputStream, elementType, keywordDefault); + } + + + // Input stream constructors. + public Stream(InputStream inputStream, LispObject elementType, LispObject format) + { + this.elementType = elementType; + setExternalFormat(format); + + if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) + { + InputStreamReader inputStreamReader = + (encoding == null) ? + new InputStreamReader(inputStream) + : new InputStreamReader(inputStream, + Charset.forName(encoding).newDecoder()); + initAsCharacterInputStream(new BufferedReader(inputStreamReader)); + } + else + { + isBinaryStream = true; + InputStream stream = new BufferedInputStream(inputStream); + initAsBinaryInputStream(stream); + } + } + + public Stream(InputStream inputStream, LispObject elementType, boolean interactive) + { + this(inputStream, elementType); + setInteractive(interactive); + } + + public Stream(OutputStream outputStream, LispObject elementType) + { + this(outputStream, elementType, keywordDefault); + } + + // Output stream constructors. + public Stream(OutputStream outputStream, LispObject elementType, LispObject format) + { + this.elementType = elementType; + setExternalFormat(format); + if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) + { + Writer w = + (encoding == null) ? + new OutputStreamWriter(outputStream) + : new OutputStreamWriter(outputStream, + Charset.forName(encoding).newEncoder()); + initAsCharacterOutputStream(w); + } + else + { + OutputStream stream = new BufferedOutputStream(outputStream); + initAsBinaryOutputStream(stream); + } + } + + public Stream(OutputStream outputStream, LispObject elementType, + boolean interactive) + { + this(outputStream, elementType); + setInteractive(interactive); + } + + protected void initAsCharacterInputStream(Reader reader) + { + if (! (reader instanceof PushbackReader)) + this.reader = new PushbackReader(reader, 5); + else + this.reader = (PushbackReader)reader; + + isInputStream = true; + isCharacterStream = true; + } + + protected void initAsBinaryInputStream(InputStream in) { + this.in = in; + isInputStream = true; + isBinaryStream = true; + } + + protected void initAsCharacterOutputStream(Writer writer) { + this.writer = writer; + isOutputStream = true; + isCharacterStream = true; + } + + protected void initAsBinaryOutputStream(OutputStream out) { + this.out = out; + isOutputStream = true; + isBinaryStream = true; + } + + public boolean isInputStream() throws ConditionThrowable + { + return isInputStream; + } + + public boolean isOutputStream() throws ConditionThrowable + { + return isOutputStream; + } + + public boolean isCharacterInputStream() throws ConditionThrowable + { + return isCharacterStream && isInputStream; + } + + public boolean isBinaryInputStream() throws ConditionThrowable + { + return isBinaryStream && isInputStream; + } + + public boolean isCharacterOutputStream() throws ConditionThrowable + { + return isCharacterStream && isOutputStream; + } + + public boolean isBinaryOutputStream() throws ConditionThrowable + { + return isBinaryStream && isOutputStream; + } + + public boolean isInteractive() + { + return interactive; + } + + public void setInteractive(boolean b) + { + interactive = b; + } + + public LispObject getExternalFormat() { + return externalFormat; + } + + public String getEncoding() { + return encoding; + } + + public void setExternalFormat(LispObject format) { + if (format == keywordDefault) { + encoding = null; + eolStyle = platformEolStyle; + eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + externalFormat = format; + return; + } + + try { + LispObject enc; + boolean encIsCp = false; + + if (format instanceof Cons) { + // meaning a non-empty list + enc = format.car(); + + if (enc == keywordCodePage) { + encIsCp = true; + + enc = LispObject.getf(format.cdr(), keywordID, null); + } + + LispObject eol = LispObject.getf(format.cdr(), keywordEolStyle, keywordRAW); + if (eol == keywordCR) + eolStyle = EolStyle.CR; + else if (eol == keywordLF) + eolStyle = EolStyle.LF; + else if (eol == keywordCRLF) + eolStyle = EolStyle.CRLF; + else if (eol != keywordRAW) + ; //###FIXME: raise an error + + } else + enc = format; + + if (enc.numberp()) + encoding = enc.toString(); + else if (enc instanceof AbstractString) + encoding = enc.getStringValue(); + else if (enc == keywordDefault) + // This allows the user to use the encoding determined by + // Java to be the default for the current environment + // while still being able to set other stream options + // (e.g. :EOL-STYLE) + encoding = null; + else if (enc instanceof Symbol) + encoding = ((Symbol)enc).getName(); + else + ; //###FIXME: raise an error! + + if (encIsCp) + encoding = "Cp" + encoding; + } + catch (ConditionThrowable ct) { } + + eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + externalFormat = format; + } + + public boolean isOpen() + { + return open; + } + + public void setOpen(boolean b) + { + open = b; + } + + @Override + public LispObject typeOf() + { + return Symbol.STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.STREAM; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.STREAM) + return T; + if (typeSpecifier == BuiltInClass.STREAM) + return T; + return super.typep(typeSpecifier); + } + + public LispObject getElementType() throws ConditionThrowable + { + return elementType; + } + + // Character input. + public int getOffset() + { + return offset; + } + + // Character input. + public final int getLineNumber() + { + return lineNumber; + } + + protected void setWriter(Writer writer) + { + this.writer = writer; + } + + // Character output. + public int getCharPos() + { + return charPos; + } + + // Character output. + public void setCharPos(int n) + { + charPos = n; + } + + public LispObject read(boolean eofError, LispObject eofValue, + boolean recursive, LispThread thread) + throws ConditionThrowable + { + LispObject result = readPreservingWhitespace(eofError, eofValue, + recursive, thread); + if (result != eofValue && !recursive) + { + if (_charReady()) + { + int n = _readChar(); + if (n >= 0) + { + char c = (char) n; + Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + if (!rt.isWhitespace(c)) + _unreadChar(c); + } + } + } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + else + return result; + } + + // ### *sharp-equal-alist* + // internal symbol + private static final Symbol _SHARP_EQUAL_ALIST_ = + internSpecial("*SHARP-EQUAL-ALIST*", PACKAGE_SYS, NIL); + + public LispObject readPreservingWhitespace(boolean eofError, + LispObject eofValue, + boolean recursive, + LispThread thread) + throws ConditionThrowable + { + if (recursive) + { + final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + while (true) + { + int n = _readChar(); + if (n < 0) + { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + char c = (char) n; + if (rt.isWhitespace(c)) + continue; + LispObject result = processChar(c, rt); + if (result != null) + return result; + } + } + else + { + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); + try + { + return readPreservingWhitespace(eofError, eofValue, true, thread); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + } + + public LispObject faslRead(boolean eofError, LispObject eofValue, + boolean recursive, LispThread thread) + throws ConditionThrowable + { + LispObject result = faslReadPreservingWhitespace(eofError, eofValue, + recursive, thread); + if (result != eofValue && !recursive) + { + if (_charReady()) + { + int n = _readChar(); + if (n >= 0) + { + char c = (char) n; + Readtable rt = FaslReadtable.getInstance(); + if (!rt.isWhitespace(c)) + _unreadChar(c); + } + } + } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + else + return result; + } + + private final LispObject faslReadPreservingWhitespace(boolean eofError, + LispObject eofValue, + boolean recursive, + LispThread thread) + throws ConditionThrowable + { + if (recursive) + { + final Readtable rt = FaslReadtable.getInstance(); + while (true) + { + int n = _readChar(); + if (n < 0) + { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + char c = (char) n; + if (rt.isWhitespace(c)) + continue; + LispObject result = processChar(c, rt); + if (result != null) + return result; + } + } + else + { + thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); + return faslReadPreservingWhitespace(eofError, eofValue, true, thread); + } + } + + private final LispObject processChar(char c, Readtable rt) + throws ConditionThrowable + { + 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); + } + + public LispObject readPathname() throws ConditionThrowable + { + LispObject obj = read(true, NIL, false, LispThread.currentThread()); + if (obj instanceof AbstractString) + return Pathname.parseNamestring((AbstractString)obj); + if (obj.listp()) + return Pathname.makePathname(obj); + return error(new TypeError("#p requires a string or list argument.")); + } + + public LispObject faslReadPathname() throws ConditionThrowable + { + LispObject obj = faslRead(true, NIL, false, LispThread.currentThread()); + if (obj instanceof AbstractString) + return Pathname.parseNamestring((AbstractString)obj); + if (obj.listp()) + return Pathname.makePathname(obj); + return error(new TypeError("#p requires a string or list argument.")); + } + + public LispObject readSymbol() throws ConditionThrowable + { + final Readtable rt = + (Readtable) Symbol.CURRENT_READTABLE.symbolValue(LispThread.currentThread()); + FastStringBuffer sb = new FastStringBuffer(); + _readToken(sb, rt); + return new Symbol(sb.toString()); + } + + public LispObject readSymbol(Readtable rt) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(); + _readToken(sb, rt); + return new Symbol(sb.toString()); + } + + public LispObject readStructure() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject obj = read(true, NIL, true, thread); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (obj.listp()) + { + Symbol structure = checkSymbol(obj.car()); + LispClass c = LispClass.findClass(structure); + if (!(c instanceof StructureClass)) + return error(new ReaderError(structure.getName() + + " is not a defined structure type.", + this)); + LispObject args = obj.cdr(); + Symbol DEFSTRUCT_DEFAULT_CONSTRUCTOR = + PACKAGE_SYS.intern("DEFSTRUCT-DEFAULT-CONSTRUCTOR"); + LispObject constructor = + DEFSTRUCT_DEFAULT_CONSTRUCTOR.getSymbolFunctionOrDie().execute(structure); + final int length = args.length(); + if ((length % 2) != 0) + return error(new ReaderError("Odd number of keyword arguments following #S: " + + obj.writeToString(), + this)); + LispObject[] array = new LispObject[length]; + LispObject rest = args; + for (int i = 0; i < length; i += 2) + { + LispObject key = rest.car(); + if (key instanceof Symbol && ((Symbol)key).getPackage() == PACKAGE_KEYWORD) + { + array[i] = key; + } + else + { + array[i] = PACKAGE_KEYWORD.intern(javaString(key)); + } + array[i + 1] = rest.cadr(); + rest = rest.cddr(); + } + return funcall(constructor.getSymbolFunctionOrDie(), array, + thread); + } + return error(new ReaderError("Non-list following #S: " + + obj.writeToString(), + this)); + } + + public LispObject faslReadStructure() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject obj = faslRead(true, NIL, true, thread); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (obj.listp()) + { + Symbol structure = checkSymbol(obj.car()); + LispClass c = LispClass.findClass(structure); + if (!(c instanceof StructureClass)) + return error(new ReaderError(structure.getName() + + " is not a defined structure type.", + this)); + LispObject args = obj.cdr(); + Symbol DEFSTRUCT_DEFAULT_CONSTRUCTOR = + PACKAGE_SYS.intern("DEFSTRUCT-DEFAULT-CONSTRUCTOR"); + LispObject constructor = + DEFSTRUCT_DEFAULT_CONSTRUCTOR.getSymbolFunctionOrDie().execute(structure); + final int length = args.length(); + if ((length % 2) != 0) + return error(new ReaderError("Odd number of keyword arguments following #S: " + + obj.writeToString(), + this)); + LispObject[] array = new LispObject[length]; + LispObject rest = args; + for (int i = 0; i < length; i += 2) + { + LispObject key = rest.car(); + if (key instanceof Symbol && ((Symbol)key).getPackage() == PACKAGE_KEYWORD) + { + array[i] = key; + } + else + { + array[i] = PACKAGE_KEYWORD.intern(javaString(key)); + } + array[i + 1] = rest.cadr(); + rest = rest.cddr(); + } + return funcall(constructor.getSymbolFunctionOrDie(), array, + thread); + } + return error(new ReaderError("Non-list following #S: " + + obj.writeToString(), + this)); + } + + public LispObject readList(boolean requireProperList, boolean useFaslReadtable) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + Cons first = null; + Cons last = null; + Readtable rt = null; + if (useFaslReadtable) + rt = FaslReadtable.getInstance(); + while (true) + { + if (!useFaslReadtable) + rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + char c = flushWhitespace(rt); + if (c == ')') + { + return first == null ? NIL : first; + } + if (c == '.') + { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + char nextChar = (char) n; + if (isTokenDelimiter(nextChar, rt)) + { + if (last == null) + { + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + else + return error(new ReaderError("Nothing appears before . in list.", + this)); + } + _unreadChar(nextChar); + LispObject obj = read(true, NIL, true, thread); + if (requireProperList) + { + if (!obj.listp()) + error(new ReaderError("The value " + + obj.writeToString() + + " is not of type " + + Symbol.LIST.writeToString() + ".", + this)); + } + last.cdr = obj; + continue; + } + // normal token beginning with '.' + _unreadChar(nextChar); + } + LispObject obj = processChar(c, rt); + if (obj == null) + { + // A comment. + continue; + } + if (first == null) + { + first = new Cons(obj); + last = first; + } + else + { + Cons newCons = new Cons(obj); + last.cdr = newCons; + last = newCons; + } + } + } + + private static final boolean isTokenDelimiter(char c, Readtable rt) + throws ConditionThrowable + { + switch (c) + { + case '"': + case '\'': + case '(': + case ')': + case ',': + case ';': + case '`': + return true; + default: + return rt.isWhitespace(c); + } + } + + public LispObject readDispatchChar(char dispChar, boolean useFaslReadtable) + throws ConditionThrowable + { + int numArg = -1; + char c; + while (true) + { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + c = (char) n; + if (c < '0' || c > '9') + break; + if (numArg < 0) + numArg = 0; + numArg = numArg * 10 + c - '0'; + } + final LispThread thread = LispThread.currentThread(); + final Readtable rt; + if (useFaslReadtable) + rt = FaslReadtable.getInstance(); + else + rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + LispObject fun = rt.getDispatchMacroCharacter(dispChar, c); + if (fun instanceof DispatchMacroFunction) + return ((DispatchMacroFunction)fun).execute(this, c, numArg); + if (fun != NIL) + { + LispObject result = + thread.execute(fun, this, LispCharacter.getInstance(c), + (numArg < 0) ? NIL : new Fixnum(numArg)); + LispObject[] values = thread._values; + if (values != null && values.length == 0) + result = null; + thread._values = null; + return result; + } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return null; + return error(new ReaderError("No dispatch function defined for #\\" + c, + this)); + } + + public LispObject readCharacterLiteral(Readtable rt, LispThread thread) + throws ConditionThrowable + { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + char c = (char) n; + FastStringBuffer sb = new FastStringBuffer(c); + while (true) + { + n = _readChar(); + if (n < 0) + break; + c = (char) n; + if (rt.isWhitespace(c)) + break; + if (c == '(' || c == ')') + { + _unreadChar(c); + break; + } + sb.append(c); + } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (sb.length() == 1) + return LispCharacter.getInstance(sb.charAt(0)); + String token = sb.toString(); + n = LispCharacter.nameToChar(token); + if (n >= 0) + return LispCharacter.getInstance((char)n); + return error(new LispError("Unrecognized character name: \"" + token + '"')); + } + + public void skipBalancedComment() throws ConditionThrowable + { + while (true) + { + int n = _readChar(); + if (n < 0) + return; + if (n == '|') + { + n = _readChar(); + if (n == '#') + return; + else + _unreadChar(n); + } + else if (n == '#') + { + n = _readChar(); + if (n == '|') + skipBalancedComment(); // Nested comment. Recurse! + else + _unreadChar(n); + } + } + } + + public LispObject readArray(int rank) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject obj = read(true, NIL, true, thread); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + switch (rank) + { + case -1: + return error(new ReaderError("No dimensions argument to #A.", this)); + case 0: + return new ZeroRankArray(T, obj, false); + case 1: + { + if (obj.listp() || obj instanceof AbstractVector) + return new SimpleVector(obj); + return error(new ReaderError(obj.writeToString() + " is not a sequence.", + this)); + } + default: + return new SimpleArray_T(rank, obj); + } + } + + public LispObject faslReadArray(int rank) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject obj = faslRead(true, NIL, true, thread); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + switch (rank) + { + case -1: + return error(new ReaderError("No dimensions argument to #A.", this)); + case 0: + return new ZeroRankArray(T, obj, false); + case 1: + { + if (obj.listp() || obj instanceof AbstractVector) + return new SimpleVector(obj); + return error(new ReaderError(obj.writeToString() + " is not a sequence.", + this)); + } + default: + return new SimpleArray_T(rank, obj); + } + } + + public LispObject readComplex() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject obj = read(true, NIL, true, thread); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (obj instanceof Cons && obj.length() == 2) + return Complex.getInstance(obj.car(), obj.cadr()); + // Error. + FastStringBuffer sb = new FastStringBuffer("Invalid complex number format"); + if (this instanceof FileStream) + { + Pathname p = ((FileStream)this).getPathname(); + if (p != null) + { + String namestring = p.getNamestring(); + if (namestring != null) + { + sb.append(" in #P\""); + sb.append(namestring); + sb.append('"'); + } + } + sb.append(" at offset "); + sb.append(_getFilePosition()); + } + sb.append(": #C"); + sb.append(obj.writeToString()); + return error(new ReaderError(sb.toString(), this)); + } + + public LispObject faslReadComplex() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject obj = faslRead(true, NIL, true, thread); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (obj instanceof Cons && obj.length() == 2) + return Complex.getInstance(obj.car(), obj.cadr()); + // Error. + FastStringBuffer sb = new FastStringBuffer("Invalid complex number format"); + if (this instanceof FileStream) + { + Pathname p = ((FileStream)this).getPathname(); + if (p != null) + { + String namestring = p.getNamestring(); + if (namestring != null) + { + sb.append(" in #P\""); + sb.append(namestring); + sb.append('"'); + } + } + sb.append(" at offset "); + sb.append(_getFilePosition()); + } + sb.append(": #C"); + sb.append(obj.writeToString()); + return error(new ReaderError(sb.toString(), this)); + } + + private String readMultipleEscape(Readtable rt) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(); + while (true) + { + int n = _readChar(); + if (n < 0) + { + error(new EndOfFile(this)); + // Not reached. + return null; + } + char c = (char) n; + 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; + } + sb.append((char)n); + continue; + } + if (syntaxType == Readtable.SYNTAX_TYPE_MULTIPLE_ESCAPE) + break; + sb.append(c); + } + return sb.toString(); + } + + private static final int findUnescapedSingleColon(String s, BitSet flags) + { + if (flags == null) + return s.indexOf(':'); + final int limit = s.length(); + for (int i = 0; i < limit; i++) + { + if (s.charAt(i) == ':' && !flags.get(i)) + { + return i; + } + } + return -1; + } + + private static final int findUnescapedDoubleColon(String s, BitSet flags) + { + if (flags == null) + return s.indexOf("::"); + final int limit = s.length() - 1; + for (int i = 0; i < limit; i++) + { + if (s.charAt(i) == ':' && !flags.get(i)) + { + if (s.charAt(i + 1) == ':' && !flags.get(i + 1)) + { + return i; + } + } + } + return -1; + } + + private final LispObject readToken(char c, Readtable rt) + throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(c); + final LispThread thread = LispThread.currentThread(); + BitSet flags = _readToken(sb, rt); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + final LispObject readtableCase = rt.getReadtableCase(); + final String token; + if (readtableCase == Keyword.INVERT) + token = invert(sb.toString(), flags); + else + token = sb.toString(); + final int length = token.length(); + if (length > 0) + { + final char firstChar = token.charAt(0); + if (flags == null) + { + if (firstChar == '.') + { + // Section 2.3.3: "If a token consists solely of dots (with + // no escape characters), then an error of type READER- + // ERROR is signaled, except in one circumstance: if the + // token is a single dot and appears in a situation where + // dotted pair notation permits a dot, then it is accepted + // as part of such syntax and no error is signaled." + boolean ok = false; + for (int i = length; i-- > 1;) + { + if (token.charAt(i) != '.') + { + ok = true; + break; + } + } + if (!ok) + { + final String message; + if (length > 1) + message = "Too many dots."; + else + message = "Dot context error."; + return error(new ReaderError(message, this)); + } + } + final int radix = getReadBase(thread); + if ("+-.0123456789".indexOf(firstChar) >= 0) + { + LispObject number = makeNumber(token, length, radix); + if (number != null) + return number; + } + else if (Character.digit(firstChar, radix) >= 0) + { + LispObject number = makeNumber(token, length, radix); + if (number != null) + return number; + } + } + if (firstChar == ':') + if (flags == null || !flags.get(0)) + return PACKAGE_KEYWORD.intern(token.substring(1)); + int index = findUnescapedDoubleColon(token, flags); + if (index > 0) + { + String packageName = token.substring(0, index); + String symbolName = token.substring(index + 2); + Package pkg = Packages.findPackage(packageName); + if (pkg == null) + return error(new LispError("Package \"" + packageName + + "\" not found.")); + return pkg.intern(symbolName); + } + index = findUnescapedSingleColon(token, flags); + if (index > 0) + { + final String packageName = token.substring(0, index); + Package pkg = Packages.findPackage(packageName); + if (pkg == null) + return error(new PackageError("Package \"" + packageName + + "\" not found.")); + final String symbolName = token.substring(index + 1); + final SimpleString s = new SimpleString(symbolName); + Symbol symbol = pkg.findExternalSymbol(s); + if (symbol != null) + return symbol; + // Error! + if (pkg.findInternalSymbol(s) != null) + return error(new ReaderError("The symbol \"" + symbolName + + "\" is not external in package " + + packageName + '.', + this)); + else + return error(new ReaderError("The symbol \"" + symbolName + + "\" was not found in package " + + packageName + '.', + this)); + } + } + // Intern token in current package. + return ((Package)Symbol._PACKAGE_.symbolValue(thread)).intern(new SimpleString(token)); + } + + private final BitSet _readToken(FastStringBuffer sb, Readtable rt) + throws ConditionThrowable + { + BitSet flags = null; + final LispObject readtableCase = rt.getReadtableCase(); + if (sb.length() > 0) + { + Debug.assertTrue(sb.length() == 1); + char c = sb.charAt(0); + byte syntaxType = rt.getSyntaxType(c); + if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) + { + int n = _readChar(); + if (n < 0) + { + error(new EndOfFile(this)); + // Not reached. + return flags; + } + sb.setCharAt(0, (char) n); + flags = new BitSet(1); + flags.set(0); + } + else if (syntaxType == Readtable.SYNTAX_TYPE_MULTIPLE_ESCAPE) + { + sb.setLength(0); + sb.append(readMultipleEscape(rt)); + flags = new BitSet(sb.length()); + for (int i = sb.length(); i-- > 0;) + flags.set(i); + } + else if (rt.isInvalid(c)) + { + rt.checkInvalid(c, this); // Signals a reader-error. + } + else if (readtableCase == Keyword.UPCASE) + { + sb.setCharAt(0, LispCharacter.toUpperCase(c)); + } + else if (readtableCase == Keyword.DOWNCASE) + { + sb.setCharAt(0, LispCharacter.toLowerCase(c)); + } + } + while (true) + { + int n = _readChar(); + if (n < 0) + break; + char c = (char) n; + if (rt.isWhitespace(c)) + { + _unreadChar(n); + break; + } + byte syntaxType = rt.getSyntaxType(c); + if (syntaxType == Readtable.SYNTAX_TYPE_TERMINATING_MACRO) + { + _unreadChar(c); + break; + } + rt.checkInvalid(c, this); + if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) + { + n = _readChar(); + if (n < 0) + break; + sb.append((char)n); + if (flags == null) + flags = new BitSet(sb.length()); + flags.set(sb.length() - 1); + continue; + } + if (syntaxType == Readtable.SYNTAX_TYPE_MULTIPLE_ESCAPE) + { + int begin = sb.length(); + sb.append(readMultipleEscape(rt)); + int end = sb.length(); + if (flags == null) + flags = new BitSet(sb.length()); + for (int i = begin; i < end; i++) + flags.set(i); + continue; + } + if (readtableCase == Keyword.UPCASE) + c = LispCharacter.toUpperCase(c); + else if (readtableCase == Keyword.DOWNCASE) + c = LispCharacter.toLowerCase(c); + sb.append(c); + } + return flags; + } + + public static final String invert(String s, BitSet flags) + { + // Section 23.1.2: "When the readtable case is :INVERT, then if all of + // the unescaped letters in the extended token are of the same case, + // those (unescaped) letters are converted to the opposite case." + final int limit = s.length(); + final int LOWER = 1; + final int UPPER = 2; + int state = 0; + for (int i = 0; i < limit; i++) + { + // We only care about unescaped characters. + if (flags != null && flags.get(i)) + continue; + char c = s.charAt(i); + if (Character.isUpperCase(c)) + { + if (state == LOWER) + return s; // Mixed case. + state = UPPER; + } + if (Character.isLowerCase(c)) + { + if (state == UPPER) + return s; // Mixed case. + state = LOWER; + } + } + FastStringBuffer sb = new FastStringBuffer(limit); + for (int i = 0; i < limit; i++) + { + char c = s.charAt(i); + if (flags != null && flags.get(i)) // Escaped. + sb.append(c); + else if (Character.isUpperCase(c)) + sb.append(Character.toLowerCase(c)); + else if (Character.isLowerCase(c)) + sb.append(Character.toUpperCase(c)); + else + sb.append(c); + } + return sb.toString(); + } + + private static final int getReadBase(LispThread thread) + throws ConditionThrowable + { + final int readBase; + try + { + readBase = ((Fixnum)Symbol.READ_BASE.symbolValue(thread)).value; + } + catch (ClassCastException e) + { + // 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 readBase; + } + + private final LispObject makeNumber(String token, int length, int radix) + throws ConditionThrowable + { + if (length == 0) + return null; + if (token.indexOf('/') >= 0) + return makeRatio(token, radix); + if (token.charAt(length - 1) == '.') + { + radix = 10; + token = token.substring(0, --length); + } + boolean numeric = true; + if (radix == 10) + { + for (int i = length; i-- > 0;) + { + char c = token.charAt(i); + if (c < '0' || c > '9') + { + if (i > 0 || (c != '-' && c != '+')) + { + numeric = false; + break; + } + } + } + } + else + { + for (int i = length; i-- > 0;) + { + char c = token.charAt(i); + if (Character.digit(c, radix) < 0) + { + if (i > 0 || (c != '-' && c != '+')) + { + numeric = false; + break; + } + } + } + } + if (!numeric) // Can't be an integer. + return makeFloat(token, length); + if (token.charAt(0) == '+') + token = token.substring(1); + try + { + int n = Integer.parseInt(token, radix); + return (n >= 0 && n <= 255) ? Fixnum.constants[n] : new Fixnum(n); + } + catch (NumberFormatException e) {} + // parseInt() failed. + try + { + return new Bignum(token, radix); + } + catch (NumberFormatException e) {} + // Not a number. + return null; + } + + private final LispObject makeRatio(String token, int radix) + throws ConditionThrowable + { + final int index = token.indexOf('/'); + if (index < 0) + return null; + try + { + BigInteger numerator = + new BigInteger(token.substring(0, index), radix); + BigInteger denominator = + new BigInteger(token.substring(index + 1), radix); + // Check the denominator here, before calling number(), so we can + // signal a READER-ERROR, as required by ANSI, instead of DIVISION- + // BY-ZERO. + if (denominator.signum() == 0) + error(new ReaderError("Division by zero.", this)); + return number(numerator, denominator); + } + catch (NumberFormatException e) + { + return null; + } + } + + private static final LispObject makeFloat(final String token, + final int length) + throws ConditionThrowable + { + if (length == 0) + return null; + FastStringBuffer sb = new FastStringBuffer(); + int i = 0; + boolean maybe = false; + char marker = 0; + char c = token.charAt(i); + if (c == '-' || c == '+') + { + sb.append(c); + ++i; + } + while (i < length) + { + c = token.charAt(i); + if (c == '.' || (c >= '0' && c <= '9')) + { + if (c == '.') + maybe = true; + sb.append(c); + ++i; + } + else + break; + } + if (i < length) + { + c = token.charAt(i); + if ("esfdlESFDL".indexOf(c) >= 0) + { + // Exponent marker. + maybe = true; + marker = LispCharacter.toUpperCase(c); + if (marker == 'S') + marker = 'F'; + else if (marker == 'L') + marker = 'D'; + else if (marker == 'E') + { + LispObject format = Symbol.READ_DEFAULT_FLOAT_FORMAT.symbolValue(); + if (format == Symbol.SINGLE_FLOAT || format == Symbol.SHORT_FLOAT) + marker = 'F'; + else + marker = 'D'; + } + sb.append('E'); + ++i; + } + } + if (!maybe) + return null; + // Append rest of token. + sb.append(token.substring(i)); + try + { + if (marker == 0) + { + LispObject format = Symbol.READ_DEFAULT_FLOAT_FORMAT.symbolValue(); + if (format == Symbol.SINGLE_FLOAT || format == Symbol.SHORT_FLOAT) + marker = 'F'; + else + marker = 'D'; + } + if (marker == 'D') + return new DoubleFloat(Double.parseDouble(sb.toString())); + else + return new SingleFloat(Float.parseFloat(sb.toString())); + } + catch (NumberFormatException e) + { + return null; + } + } + + public LispObject readRadix(int radix) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(); + final LispThread thread = LispThread.currentThread(); + final Readtable rt = + (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + boolean escaped = (_readToken(sb, rt) != null); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (escaped) + return error(new ReaderError("Illegal syntax for number.", this)); + String s = sb.toString(); + if (s.indexOf('/') >= 0) + return makeRatio(s, radix); + // Integer.parseInt() below handles a prefixed '-' character correctly, but + // does not accept a prefixed '+' character, so we skip over it here + if (s.charAt(0) == '+') + s = s.substring(1); + try + { + int n = Integer.parseInt(s, radix); + return (n >= 0 && n <= 255) ? Fixnum.constants[n] : new Fixnum(n); + } + catch (NumberFormatException e) {} + // parseInt() failed. + try + { + return new Bignum(s, radix); + } + catch (NumberFormatException e) {} + // Not a number. + return error(new LispError()); + } + + public LispObject faslReadRadix(int radix) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer(); + final LispThread thread = LispThread.currentThread(); + final Readtable rt = FaslReadtable.getInstance(); + boolean escaped = (_readToken(sb, rt) != null); + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + if (escaped) + return error(new ReaderError("Illegal syntax for number.", this)); + String s = sb.toString(); + if (s.indexOf('/') >= 0) + return makeRatio(s, radix); + try + { + int n = Integer.parseInt(s, radix); + return (n >= 0 && n <= 255) ? Fixnum.constants[n] : new Fixnum(n); + } + catch (NumberFormatException e) {} + // parseInt() failed. + try + { + return new Bignum(s, radix); + } + catch (NumberFormatException e) {} + // Not a number. + return error(new LispError()); + } + + private char flushWhitespace(Readtable rt) throws ConditionThrowable + { + while (true) + { + int n = _readChar(); + if (n < 0) + { + error(new EndOfFile(this)); + // Not reached. + return 0; + } + char c = (char) n; + if (!rt.isWhitespace(c)) + return c; + } + } + + public LispObject readDelimitedList(char delimiter) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject result = NIL; + while (true) + { + Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + char c = flushWhitespace(rt); + if (c == delimiter) + break; + LispObject obj = processChar(c, rt); + if (obj != null) + result = new Cons(obj, result); + } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + else + return result.nreverse(); + } + + // read-line &optional stream eof-error-p eof-value recursive-p + // => line, missing-newline-p + // recursive-p is ignored + public LispObject readLine(boolean eofError, LispObject eofValue) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + FastStringBuffer sb = new FastStringBuffer(); + while (true) + { + int n = _readChar(); + if (n < 0) + { + if (sb.length() == 0) + { + if (eofError) + return error(new EndOfFile(this)); + return thread.setValues(eofValue, T); + } + return thread.setValues(new SimpleString(sb), T); + } + if (n == '\n') + return thread.setValues(new SimpleString(sb), NIL); + else + sb.append((char)n); + } + } + + // read-char &optional stream eof-error-p eof-value recursive-p => char + // recursive-p is ignored + public LispObject readChar() throws ConditionThrowable + { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + return LispCharacter.getInstance((char)n); + } + + public LispObject readChar(boolean eofError, LispObject eofValue) + throws ConditionThrowable + { + int n = _readChar(); + if (n < 0) + { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + return LispCharacter.getInstance((char)n); + } + + // read-char-no-hang &optional stream eof-error-p eof-value recursive-p => char + // recursive-p is ignored + public LispObject readCharNoHang(boolean eofError, LispObject eofValue) + throws ConditionThrowable + { + return _charReady() ? readChar(eofError, eofValue) : NIL; + } + + + // unread-char character &optional input-stream => nil + public LispObject unreadChar(LispCharacter c) throws ConditionThrowable + { + _unreadChar(c.value); + return NIL; + } + + public LispObject finishOutput() throws ConditionThrowable + { + _finishOutput(); + return NIL; + } + + // clear-input &optional input-stream => nil + public LispObject clearInput() throws ConditionThrowable + { + _clearInput(); + return NIL; + } + + public LispObject getFilePosition() throws ConditionThrowable + { + long pos = _getFilePosition(); + return pos >= 0 ? number(pos) : NIL; + } + + public LispObject setFilePosition(LispObject arg) throws ConditionThrowable + { + return _setFilePosition(arg) ? T : NIL; + } + + // close stream &key abort => result + // Must return true if stream was open, otherwise implementation-dependent. + public LispObject close(LispObject abort) throws ConditionThrowable + { + _close(); + return T; + } + + @Override + public String toString() + { + return unreadableString("STREAM"); + } + + // read-byte stream &optional eof-error-p eof-value => byte + // Reads an 8-bit byte. + public LispObject readByte(boolean eofError, LispObject eofValue) + throws ConditionThrowable + { + int n = _readByte(); + if (n < 0) + { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + return Fixnum.constants[n]; + } + + public LispObject terpri() throws ConditionThrowable + { + _writeChar('\n'); + return NIL; + } + + public LispObject freshLine() throws ConditionThrowable + { + if (charPos == 0) + return NIL; + _writeChar('\n'); + return T; + } + + public void print(char c) throws ConditionThrowable + { + _writeChar(c); + } + + // PRIN1 produces output suitable for input to READ. + // Binds *PRINT-ESCAPE* to true. + public void prin1(LispObject obj) throws ConditionThrowable + { + LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try + { + _writeString(obj.writeToString()); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + public LispObject listen() throws ConditionThrowable + { + if (pastEnd) + return NIL; + + if (! _charReady()) + return NIL; + + int n = _readChar(); + if (n < 0) + return NIL; + + _unreadChar(n); + + return T; + } + + public LispObject fileLength() throws ConditionThrowable + { + return type_error(this, Symbol.FILE_STREAM); + } + + public LispObject fileStringLength(LispObject arg) throws ConditionThrowable + { + if (arg instanceof LispCharacter) + { + if (Utilities.isPlatformWindows) + { + if (((LispCharacter)arg).value == '\n') + return Fixnum.TWO; + } + return Fixnum.ONE; + } + if (arg instanceof AbstractString) + { + if (Utilities.isPlatformWindows) + { + int fileStringLength = 0; + char[] chars = ((AbstractString)arg).getStringChars(); + for (int i = chars.length; i-- > 0;) + { + if (chars[i] == '\n') + fileStringLength += 2; + else + ++fileStringLength; + } + return number(fileStringLength); + + } + return number(arg.length()); + } + return error(new TypeError(arg.writeToString() + + " is neither a string nor a character.")); + } + + /** Reads a character off an underlying stream + * + * @return a character, or -1 at end-of-file + * @throws org.armedbear.lisp.ConditionThrowable + */ + protected int _readChar() throws ConditionThrowable + { + if (pastEnd) + return -1; + + try + { + int n = reader.read(); + + if (n < 0) { + pastEnd = true; + return -1; + } + + ++offset; + if (eolStyle == EolStyle.CRLF && n == '\r') { + n = _readChar(); + if (n != '\n') { + _unreadChar(n); + return '\r'; + } + else + return '\n'; + } + + if (n == eolChar) { + ++lineNumber; + return '\n'; + } + + return n; + } + catch (NullPointerException e) + { + // reader is null + streamNotCharacterInputStream(); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + // Not reached. + return -1; + } + + /** Puts a character back into the (underlying) stream + * + * @param n + * @throws org.armedbear.lisp.ConditionThrowable + */ + protected void _unreadChar(int n) throws ConditionThrowable + { + try + { + reader.unread(n); + --offset; + pastEnd = false; + if (n == eolChar) + --lineNumber; + } + catch (NullPointerException e) + { + // reader is null + streamNotCharacterInputStream(); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + /** Returns a boolean indicating input readily available + * + * @return true if a character is available + * @throws org.armedbear.lisp.ConditionThrowable + */ + protected boolean _charReady() throws ConditionThrowable + { + try + { + return reader.ready(); + } + catch (NullPointerException e) + { + // reader is null + streamNotCharacterInputStream(); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + // Not reached. + return false; + } + + /** Writes a character into the underlying stream, + * updating charPos while doing so + * + * @param c + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _writeChar(char c) throws ConditionThrowable + { + try + { + if (c == '\n') { + if (eolStyle == EolStyle.CRLF && lastChar != '\r') + writer.write('\r'); + + writer.write(eolChar); + lastChar = eolChar; + writer.flush(); + charPos = 0; + } else { + writer.write(c); + lastChar = c; + ++charPos; + } + } + catch (NullPointerException e) + { + // writer is null + streamNotCharacterOutputStream(); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + /** Writes a series of characters in the underlying stream, + * updating charPos while doing so + * + * @param chars + * @param start + * @param end + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + try + { + if (eolStyle != EolStyle.RAW) { + for (int i = start; i < end; i++) + //###FIXME: the number of writes can be greatly reduced by + // writing the space between newlines as chunks. + _writeChar(chars[i]); + return; + } + + writer.write(chars, start, end - start); + if (start < end) + lastChar = chars[end-1]; + + int index = -1; + for (int i = end; i-- > start;) + { + if (chars[i] == '\n') + { + index = i; + break; + } + } + if (index < 0) + { + // No newline. + charPos += (end - start); + } + else + { + charPos = end - (index + 1); + writer.flush(); + } + } + catch (NullPointerException e) + { + if (writer == null) + streamNotCharacterOutputStream(); + else + throw e; + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + /** Writes a string to the underlying stream, + * updating charPos while doing so + * + * @param s + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _writeString(String s) throws ConditionThrowable + { + try + { + _writeChars(s.toCharArray(), 0, s.length()); + } + catch (NullPointerException e) + { + if (writer == null) + streamNotCharacterOutputStream(); + else + throw e; + } + } + + /** Writes a string to the underlying stream, appending + * a new line and updating charPos while doing so + * + * @param s + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _writeLine(String s) throws ConditionThrowable + { + try + { + _writeString(s); + _writeChar('\n'); + } + catch (NullPointerException e) + { + // writer is null + streamNotCharacterOutputStream(); + } + } + + // Reads an 8-bit byte. + /** Reads an 8-bit byte off the underlying stream + * + * @return + * @throws org.armedbear.lisp.ConditionThrowable + */ + public int _readByte() throws ConditionThrowable + { + try + { + int n = in.read(); + if (n < 0) + pastEnd = true; + + return n; // Reads an 8-bit byte. + } + catch (IOException e) + { + error(new StreamError(this, e)); + // Not reached. + return -1; + } + } + + // Writes an 8-bit byte. + /** Writes an 8-bit byte off the underlying stream + * + * @param n + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _writeByte(int n) throws ConditionThrowable + { + try + { + out.write(n); // Writes an 8-bit byte. + } + catch (NullPointerException e) + { + // out is null + streamNotBinaryOutputStream(); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + /** Flushes any buffered output in the (underlying) stream + * + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _finishOutput() throws ConditionThrowable + { + try + { + if (writer != null) + writer.flush(); + if (out != null) + out.flush(); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + /** Reads all input from the underlying stream, + * until _charReady() indicates no more input to be available + * + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _clearInput() throws ConditionThrowable + { + if (reader != null) + { + int c = 0; + while (_charReady() && (c >= 0)) + c = _readChar(); + } + else if (in != null) + { + try + { + int n = 0; + while (in.available() > 0) + n = in.read(); + + if (n < 0) + pastEnd = true; + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + } + + /** Returns a (non-negative) file position integer or a negative value + * if the position cannot be determined. + * + * @return non-negative value as a position spec + * @return negative value for 'unspecified' + * @throws org.armedbear.lisp.ConditionThrowable + */ + protected long _getFilePosition() throws ConditionThrowable + { + return -1; + } + + /** Sets the file position based on a position designator passed in arg + * + * @param arg File position specifier as described in the CLHS + * @return true on success, false on failure + * @throws org.armedbear.lisp.ConditionThrowable + */ + protected boolean _setFilePosition(LispObject arg) throws ConditionThrowable + { + return false; + } + + /** Closes the stream and underlying streams + * + * @throws org.armedbear.lisp.ConditionThrowable + */ + public void _close() throws ConditionThrowable + { + try + { + if (reader != null) + reader.close(); + if (in != null) + in.close(); + if (writer != null) + writer.close(); + if (out != null) + out.close(); + setOpen(false); + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + public void printStackTrace(Throwable t) throws ConditionThrowable + { + StringWriter sw = new StringWriter(); + PrintWriter pw = new PrintWriter(sw); + t.printStackTrace(pw); + try + { + writer.write(sw.toString()); + writer.write('\n'); + lastChar = '\n'; + writer.flush(); + charPos = 0; + } + catch (IOException e) + { + error(new StreamError(this, e)); + } + } + + protected LispObject streamNotInputStream() throws ConditionThrowable + { + return error(new StreamError(this, writeToString() + " is not an input stream.")); + } + + protected LispObject streamNotCharacterInputStream() throws ConditionThrowable + { + return error(new StreamError(this, writeToString() + " is not a character input stream.")); + } + + protected LispObject streamNotOutputStream() throws ConditionThrowable + { + return error(new StreamError(this, writeToString() + " is not an output stream.")); + } + + protected LispObject streamNotBinaryOutputStream() throws ConditionThrowable + { + return error(new StreamError(this, writeToString() + " is not a binary output stream.")); + } + + protected LispObject streamNotCharacterOutputStream() throws ConditionThrowable + { + return error(new StreamError(this, writeToString() + " is not a character output stream.")); + } + + // ### %stream-write-char character output-stream => character + // OUTPUT-STREAM must be a real stream, not an output stream designator! + private static final Primitive _WRITE_CHAR = + new Primitive("%stream-write-char", PACKAGE_SYS, true, + "character output-stream") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + ((Stream)second)._writeChar(((LispCharacter)first).value); + } + catch (ClassCastException e) + { + if (second instanceof Stream) + return type_error(first, Symbol.CHARACTER); + else + return type_error(second, Symbol.STREAM); + } + return first; + } + }; + + // ### %write-char character output-stream => character + private static final Primitive _STREAM_WRITE_CHAR = + new Primitive("%write-char", PACKAGE_SYS, false, + "character output-stream") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final char c; + try + { + c = ((LispCharacter)first).value; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.CHARACTER); + } + if (second == T) + second = Symbol.TERMINAL_IO.symbolValue(); + else if (second == NIL) + second = Symbol.STANDARD_OUTPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STREAM); + } + stream._writeChar(c); + return first; + } + }; + + // ### %write-string string output-stream start end => string + private static final Primitive _WRITE_STRING = + new Primitive("%write-string", PACKAGE_SYS, false, + "string output-stream start end") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + final AbstractString s; + try + { + s = (AbstractString) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STRING); + } + char[] chars = s.chars(); + final Stream out; + try + { + if (second == T) + out = (Stream) Symbol.TERMINAL_IO.symbolValue(); + else if (second == NIL) + out = (Stream) Symbol.STANDARD_OUTPUT.symbolValue(); + else + out = (Stream) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STREAM); + } + final int start; + try + { + start = ((Fixnum)third).value; + } + catch (ClassCastException e) + { + return type_error(third, Symbol.FIXNUM); + } + final int end; + if (fourth == NIL) + end = chars.length; + else + { + try + { + end = ((Fixnum)fourth).value; + } + catch (ClassCastException e) + { + return type_error(fourth, Symbol.FIXNUM); + } + } + checkBounds(start, end, chars.length); + out._writeChars(chars, start, end); + return first; + } + }; + + // ### %finish-output output-stream => nil + private static final Primitive _FINISH_OUTPUT = + new Primitive("%finish-output", PACKAGE_SYS, false, "output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return finishOutput(arg); + } + }; + + // ### %force-output output-stream => nil + private static final Primitive _FORCE_OUTPUT = + new Primitive("%force-output", PACKAGE_SYS, false, "output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return finishOutput(arg); + } + }; + + private static final LispObject finishOutput(LispObject arg) + throws ConditionThrowable + { + final Stream out; + try + { + if (arg == T) + out = (Stream) Symbol.TERMINAL_IO.symbolValue(); + else if (arg == NIL) + out = (Stream) Symbol.STANDARD_OUTPUT.symbolValue(); + else + out = (Stream) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + return out.finishOutput(); + } + + // ### clear-input &optional input-stream => nil + private static final Primitive CLEAR_INPUT = + new Primitive(Symbol.CLEAR_INPUT, "&optional input-stream") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length > 1) + return error(new WrongNumberOfArgumentsException(this)); + final Stream in; + if (args.length == 0) + in = checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()); + else + in = inSynonymOf(args[0]); + in.clearInput(); + return NIL; + } + }; + + // ### %clear-output output-stream => nil + // "If any of these operations does not make sense for output-stream, then + // it does nothing." + private static final Primitive _CLEAR_OUTPUT = + new Primitive("%clear-output", PACKAGE_SYS, false, "output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == T) // *TERMINAL-IO* + return NIL; + if (arg == NIL) // *STANDARD-OUTPUT* + return NIL; + if (arg instanceof Stream) + return NIL; + return type_error(arg, Symbol.STREAM); + } + }; + + // ### close stream &key abort => result + private static final Primitive CLOSE = + new Primitive(Symbol.CLOSE, "stream &key abort") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return ((Stream)arg).close(NIL); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + if (second == Keyword.ABORT) + return stream.close(third); + return error(new ProgramError("Unrecognized keyword argument " + + second.writeToString() + ".")); + } + }; + + // ### out-synonym-of stream-designator => stream + private static final Primitive OUT_SYNONYM_OF = + new Primitive("out-synonym-of", PACKAGE_SYS, true, "stream-designator") + { + @Override + public LispObject execute (LispObject arg) throws ConditionThrowable + { + if (arg instanceof Stream) + return arg; + if (arg == T) + return Symbol.TERMINAL_IO.symbolValue(); + if (arg == NIL) + return Symbol.STANDARD_OUTPUT.symbolValue(); + return arg; + } + }; + + // ### write-8-bits + // write-8-bits byte stream => nil + private static final Primitive WRITE_8_BITS = + new Primitive("write-8-bits", PACKAGE_SYS, true, "byte stream") + { + @Override + public LispObject execute (LispObject first, LispObject second) + throws ConditionThrowable + { + int n; + try + { + n = ((Fixnum)first).value; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.FIXNUM); + } + if (n < 0 || n > 255) + return type_error(first, UNSIGNED_BYTE_8); + try + { + ((Stream)second)._writeByte(n); + return NIL; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STREAM); + } + } + }; + + // ### read-8-bits + // read-8-bits stream &optional eof-error-p eof-value => byte + private static final Primitive READ_8_BITS = + new Primitive("read-8-bits", PACKAGE_SYS, true, + "stream &optional eof-error-p eof-value") + { + @Override + public LispObject execute (LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return checkBinaryInputStream(first).readByte((second != NIL), + third); + } + + @Override + public LispObject execute (LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length < 1 || length > 3) + return error(new WrongNumberOfArgumentsException(this)); + final Stream in = checkBinaryInputStream(args[0]); + boolean eofError = length > 1 ? (args[1] != NIL) : true; + LispObject eofValue = length > 2 ? args[2] : NIL; + return in.readByte(eofError, eofValue); + } + }; + + // ### read-line &optional input-stream eof-error-p eof-value recursive-p + // => line, missing-newline-p + private static final Primitive READ_LINE = + new Primitive(Symbol.READ_LINE, + "&optional input-stream eof-error-p eof-value recursive-p") + { + @Override + public LispObject execute() throws ConditionThrowable + { + final LispObject obj = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) obj; + } + catch (ClassCastException e) + { + return type_error(obj, Symbol.STREAM); + } + return stream.readLine(true, NIL); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == T) + arg = Symbol.TERMINAL_IO.symbolValue(); + else if (arg == NIL) + arg = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + return stream.readLine(true, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.readLine(second != NIL, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.readLine(second != NIL, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + // recursive-p is ignored + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.readLine(second != NIL, third); + } + }; + + // ### %read-from-string string eof-error-p eof-value start end preserve-whitespace + // => object, position + private static final Primitive _READ_FROM_STRING = + new Primitive("%read-from-string", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + String s = first.getStringValue(); + boolean eofError = (second != NIL); + boolean preserveWhitespace = (sixth != NIL); + final int startIndex; + if (fourth != NIL) + startIndex = Fixnum.getValue(fourth); + else + startIndex = 0; + final int endIndex; + if (fifth != NIL) + endIndex = Fixnum.getValue(fifth); + else + endIndex = s.length(); + StringInputStream in = + new StringInputStream(s, startIndex, endIndex); + final LispThread thread = LispThread.currentThread(); + LispObject result; + if (preserveWhitespace) + result = in.readPreservingWhitespace(eofError, third, false, + thread); + else + result = in.read(eofError, third, false, thread); + return thread.setValues(result, new Fixnum(in.getOffset())); + } + }; + + // ### read &optional input-stream eof-error-p eof-value recursive-p => object + private static final Primitive READ = + new Primitive(Symbol.READ, + "&optional input-stream eof-error-p eof-value recursive-p") + { + @Override + public LispObject execute() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + final LispObject obj = Symbol.STANDARD_INPUT.symbolValue(thread); + final Stream stream; + try + { + stream = (Stream) obj; + } + catch (ClassCastException e) + { + return type_error(obj, Symbol.STREAM); + } + return stream.read(true, NIL, false, thread); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (arg == T) + arg = Symbol.TERMINAL_IO.symbolValue(thread); + else if (arg == NIL) + arg = Symbol.STANDARD_INPUT.symbolValue(thread); + final Stream stream; + try + { + stream = (Stream) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + return stream.read(true, NIL, false, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(thread); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(thread); + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.read(second != NIL, NIL, false, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(thread); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(thread); + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.read(second != NIL, third, false, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(thread); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(thread); + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.read(second != NIL, third, fourth != NIL, thread); + } + }; + + // ### read-preserving-whitespace + // &optional input-stream eof-error-p eof-value recursive-p => object + private static final Primitive READ_PRESERVING_WHITESPACE = + new Primitive(Symbol.READ_PRESERVING_WHITESPACE, + "&optional input-stream eof-error-p eof-value recursive-p") + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length > 4) + return error(new WrongNumberOfArgumentsException(this)); + Stream stream = + length > 0 ? inSynonymOf(args[0]) : getStandardInput(); + boolean eofError = length > 1 ? (args[1] != NIL) : true; + LispObject eofValue = length > 2 ? args[2] : NIL; + boolean recursive = length > 3 ? (args[3] != NIL) : false; + return stream.readPreservingWhitespace(eofError, eofValue, + recursive, + LispThread.currentThread()); + } + }; + + // ### read-char &optional input-stream eof-error-p eof-value recursive-p + // => char + private static final Primitive READ_CHAR = + new Primitive(Symbol.READ_CHAR, + "&optional input-stream eof-error-p eof-value recursive-p") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()).readChar(); + } + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return inSynonymOf(arg).readChar(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return inSynonymOf(first).readChar(second != NIL, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + return inSynonymOf(first).readChar(second != NIL, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + return inSynonymOf(first).readChar(second != NIL, third); + } + }; + + // ### read-char-no-hang &optional input-stream eof-error-p eof-value + // recursive-p => char + private static final Primitive READ_CHAR_NO_HANG = + new Primitive("read-char-no-hang", "&optional input-stream eof-error-p eof-value recursive-p") { + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length > 4) + error(new WrongNumberOfArgumentsException(this)); + Stream stream = + length > 0 ? inSynonymOf(args[0]) : getStandardInput(); + boolean eofError = length > 1 ? (args[1] != NIL) : true; + LispObject eofValue = length > 2 ? args[2] : NIL; + // recursive-p is ignored + // boolean recursive = length > 3 ? (args[3] != NIL) : false; + return stream.readCharNoHang(eofError, eofValue); + } + }; + + // ### read-delimited-list char &optional input-stream recursive-p => list + private static final Primitive READ_DELIMITED_LIST = + new Primitive("read-delimited-list", "char &optional input-stream recursive-p") { + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length < 1 || length > 3) + error(new WrongNumberOfArgumentsException(this)); + char c = LispCharacter.getValue(args[0]); + Stream stream = + length > 1 ? inSynonymOf(args[1]) : getStandardInput(); + return stream.readDelimitedList(c); + } + }; + + + // ### unread-char character &optional input-stream => nil + private static final Primitive UNREAD_CHAR = + new Primitive(Symbol.UNREAD_CHAR, "character &optional input-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return getStandardInput().unreadChar(checkCharacter(arg)); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Stream stream = inSynonymOf(second); + return stream.unreadChar(checkCharacter(first)); + } + }; + + // ### write-vector-unsigned-byte-8 + private static final Primitive WRITE_VECTOR_UNSIGNED_BYTE_8 = + new Primitive("write-vector-unsigned-byte-8", PACKAGE_SYS, true, + "vector stream start end") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + final AbstractVector v = checkVector(first); + final Stream stream; + try + { + stream = (Stream) second; + } + catch (ClassCastException e) + { + return type_error(second, Symbol.STREAM); + } + int start = Fixnum.getValue(third); + int end = Fixnum.getValue(fourth); + for (int i = start; i < end; i++) + stream._writeByte(v.aref(i)); + return v; + } + }; + + // ### read-vector-unsigned-byte-8 vector stream start end => position + private static final Primitive READ_VECTOR_UNSIGNED_BYTE_8 = + new Primitive("read-vector-unsigned-byte-8", PACKAGE_SYS, true, + "vector stream start end") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + AbstractVector v = checkVector(first); + Stream stream = checkBinaryInputStream(second); + int start = Fixnum.getValue(third); + int end = Fixnum.getValue(fourth); + if (!v.getElementType().equal(UNSIGNED_BYTE_8)) + return type_error(first, list2(Symbol.VECTOR, + UNSIGNED_BYTE_8)); + for (int i = start; i < end; i++) + { + int n = stream._readByte(); + if (n < 0) + { + // End of file. + return new Fixnum(i); + } + v.aset(i, n); + } + return fourth; + } + }; + + // ### file-position + private static final Primitive FILE_POSITION = + new Primitive("file-position", "stream &optional position-spec") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final Stream stream; + try + { + stream = (Stream) arg; + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STREAM); + } + return stream.getFilePosition(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Stream stream; + try + { + stream = (Stream) first; + } + catch (ClassCastException e) + { + return type_error(first, Symbol.STREAM); + } + return stream.setFilePosition(second); + } + }; + + // ### stream-line-number + private static final Primitive STREAM_LINE_NUMBER = + new Primitive("stream-line-number", PACKAGE_SYS, false, "stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Stream stream = checkStream(arg); + return new Fixnum(stream.getLineNumber() + 1); + } + }; + + // ### stream-offset + private static final Primitive STREAM_OFFSET = + new Primitive("stream-offset", PACKAGE_SYS, false, "stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Stream stream = checkStream(arg); + return number(stream.getOffset()); + } + }; + + // ### stream-charpos stream => position + private static final Primitive STREAM_CHARPOS = + new Primitive("stream-charpos", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Stream stream = checkCharacterOutputStream(arg); + return new Fixnum(stream.getCharPos()); + } + }; + + // ### stream-%set-charpos stream newval => newval + private static final Primitive STREAM_SET_CHARPOS = + new Primitive("stream-%set-charpos", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Stream stream = checkCharacterOutputStream(first); + stream.setCharPos(Fixnum.getValue(second)); + return second; + } + }; + + public OutputStream getJavaOutputStream() { + return out; + } + + public InputStream getJavaInputStream() { + return in; + } + + public Writer getJavaWriter() { + return writer; + } + + public Reader getJavaReader() { + return reader; + } + +} Added: branches/save-image/src/org/armedbear/lisp/StreamError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StreamError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,167 @@ +/* + * StreamError.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: StreamError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StreamError extends LispError +{ + private final Throwable cause; + + protected StreamError(LispClass cls) throws ConditionThrowable + { + super(cls); + cause = null; + } + + public StreamError(String message) throws ConditionThrowable + { + super(StandardClass.STREAM_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + setStream(NIL); + cause = null; + } + + public StreamError(Stream stream) throws ConditionThrowable + { + super(StandardClass.STREAM_ERROR); + setStream(stream != null ? stream : NIL); + cause = null; + } + + public StreamError(String message, Stream stream) throws ConditionThrowable + { + super(StandardClass.STREAM_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + setStream(stream != null ? stream : NIL); + cause = null; + } + + public StreamError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.STREAM_ERROR); + initialize(initArgs); + cause = null; + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + while (initArgs != NIL) { + LispObject first = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.STREAM) { + setStream(initArgs.car()); + break; + } + initArgs = initArgs.cdr(); + } + } + + public StreamError(Stream stream, String message) throws ConditionThrowable + { + super(StandardClass.STREAM_ERROR); + setFormatControl(message); + setFormatArguments(NIL); + setStream(stream != null ? stream : NIL); + cause = null; + } + + public StreamError(Stream stream, Throwable cause) throws ConditionThrowable + { + super(StandardClass.STREAM_ERROR); + setStream(stream != null ? stream : NIL); + this.cause = cause; + } + + public final LispObject getStream() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.STREAM); + } + + protected final void setStream(LispObject stream) throws ConditionThrowable + { + setInstanceSlotValue(Symbol.STREAM, stream); + } + + @Override + public LispObject typeOf() + { + return Symbol.STREAM_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.STREAM_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STREAM_ERROR) + return T; + if (type == StandardClass.STREAM_ERROR) + return T; + return super.typep(type); + } + + @Override + public String getMessage() + { + if (cause != null) { + String s = cause.getMessage(); + if (s != null && s.length() > 0) + return s; + } + return null; + } + + // ### stream-error-stream + private static final Primitive STREAM_ERROR_STREAM = + new Primitive("stream-error-stream", "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((StreamError)arg).getStream(); + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.STREAM_ERROR)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StringFunctions.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StringFunctions.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1049 @@ +/* + * StringFunctions.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: StringFunctions.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StringFunctions extends Lisp +{ + // ### %string= + // Case sensitive. + private static final Primitive _STRING_EQUAL = + new Primitive("%string=", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + char[] array1 = first.STRING().getStringChars(); + char[] array2 = second.STRING().getStringChars(); + int start1, end1, start2, end2; + try { + start1 = ((Fixnum)third).value; + } + catch (ClassCastException e) { + return type_error(third, Symbol.FIXNUM); + } + if (fourth == NIL) { + end1 = array1.length; + } else { + try { + end1 = ((Fixnum)fourth).value; + } + catch (ClassCastException e) { + return type_error(fourth, Symbol.FIXNUM); + } + } + try { + start2 = ((Fixnum)fifth).value; + } + catch (ClassCastException e) { + return type_error(fifth, Symbol.FIXNUM); + } + if (sixth == NIL) { + end2 = array2.length; + } else { + try { + end2 = ((Fixnum)sixth).value; + } + catch (ClassCastException e) { + return type_error(sixth, Symbol.FIXNUM); + } + } + if ((end1 - start1) != (end2 - start2)) + return NIL; + try { + for (int i = start1, j = start2; i < end1; i++, j++) { + if (array1[i] != array2[j]) + return NIL; + } + } + catch (ArrayIndexOutOfBoundsException e) { + // Shouldn't happen. + Debug.trace(e); + return NIL; + } + return T; + } + }; + + // ### %%string= + // Case sensitive. + private static final Primitive __STRING_EQUAL = + new Primitive("%%string=", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + char[] array1 = first.STRING().getStringChars(); + char[] array2 = second.STRING().getStringChars(); + if (array1.length != array2.length) + return NIL; + for (int i = array1.length; i-- > 0;) { + if (array1[i] != array2[i]) + return NIL; + } + return T; + } + }; + + // ### %string/= + // Case sensitive. + private static final Primitive _STRING_NOT_EQUAL = + new Primitive("%string/=", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + if (j == end2) + return NIL; // Strings are identical. + return new Fixnum(i); + } + if (j == end2) { + // Reached end of string2 before end of string1. + return new Fixnum(i); + } + if (array1[i] != array2[j]) + return new Fixnum(i); + ++i; + ++j; + } + } + }; + + // ### %string-equal + // Case insensitive. + private static final Primitive _STRING_EQUAL_IGNORE_CASE = + new Primitive("%string-equal", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + char[] array1 = first.STRING().getStringChars(); + char[] array2 = second.STRING().getStringChars(); + int start1 = Fixnum.getValue(third); + int end1 = Fixnum.getValue(fourth); + int start2 = Fixnum.getValue(fifth); + int end2 = Fixnum.getValue(sixth); + if ((end1 - start1) != (end2 - start2)) + return NIL; + int i, j; + for (i = start1, j = start2; i < end1; i++, j++) { + char c1 = array1[i]; + char c2 = array2[j]; + if (c1 == c2) + continue; + if (LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2)) + continue; + if (LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) + continue; + return NIL; + } + return T; + } + }; + + // ### %string-not-equal + // Case sensitive. + private static final Primitive _STRING_NOT_EQUAL_IGNORE_CASE = + new Primitive("%string-not-equal", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + if (j == end2) + return NIL; // Strings are identical. + return new Fixnum(i); + } + if (j == end2) { + // Reached end of string2. + return new Fixnum(i); + } + char c1 = array1[i]; + char c2 = array2[j]; + if (c1 == c2 || + LispCharacter.toUpperCase(c1) == LispCharacter.toUpperCase(c2) || + LispCharacter.toLowerCase(c1) == LispCharacter.toLowerCase(c2)) + { + ++i; + ++j; + continue; + } + return new Fixnum(i); + } + } + }; + + // ### %string< + // Case sensitive. + private static final Primitive _STRING_LESS_THAN = + new Primitive("%string<", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + if (j == end2) + return NIL; // Strings are identical. + return new Fixnum(i); + } + if (j == end2) { + // Reached end of string2. + return NIL; + } + char c1 = array1[i]; + char c2 = array2[j]; + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 < c2) + return new Fixnum(i); + // c1 > c2 + return NIL; + } + } + }; + + // ### %string<= + // Case sensitive. + private static final Primitive _STRING_GREATER_THAN = + new Primitive("%string>", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + return NIL; + } + if (j == end2) { + // Reached end of string2. + return new Fixnum(i); + } + char c1 = array1[i]; + char c2 = array2[j]; + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 < c2) + return NIL; + // c1 > c2 + return new Fixnum(i); + } + } + }; + + // ### %string<= + // Case sensitive. + private static final Primitive _STRING_LE = + new Primitive("%string<=", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + return new Fixnum(i); + } + if (j == end2) { + // Reached end of string2. + return NIL; + } + char c1 = array1[i]; + char c2 = array2[j]; + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 > c2) + return NIL; + // c1 < c2 + return new Fixnum(i); + } + } + }; + + // ### %string<= + // Case sensitive. + private static final Primitive _STRING_GE = + new Primitive("%string>=", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + if (j == end2) + return new Fixnum(i); // Strings are identical. + return NIL; + } + if (j == end2) { + // Reached end of string2. + return new Fixnum(i); + } + char c1 = array1[i]; + char c2 = array2[j]; + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 < c2) + return NIL; + // c1 > c2 + return new Fixnum(i); + } + } + }; + + // ### %string-lessp + // Case insensitive. + private static final Primitive _STRING_LESSP = + new Primitive("%string-lessp", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + if (j == end2) + return NIL; // Strings are identical. + return new Fixnum(i); + } + if (j == end2) { + // Reached end of string2. + return NIL; + } + char c1 = LispCharacter.toUpperCase(array1[i]); + char c2 = LispCharacter.toUpperCase(array2[j]); + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 > c2) + return NIL; + // c1 < c2 + return new Fixnum(i); + } + } + }; + + // ### %string-greaterp + // Case insensitive. + private static final Primitive _STRING_GREATERP = + new Primitive("%string-greaterp", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + return NIL; + } + if (j == end2) { + // Reached end of string2. + return new Fixnum(i); + } + char c1 = LispCharacter.toUpperCase(array1[i]); + char c2 = LispCharacter.toUpperCase(array2[j]); + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 < c2) + return NIL; + // c1 > c2 + return new Fixnum(i); + } + } + }; + + // ### %string-not-lessp + // Case insensitive. + private static final Primitive _STRING_NOT_LESSP = + new Primitive("%string-not-lessp", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + if (j == end2) + return new Fixnum(i); // Strings are identical. + return NIL; + } + if (j == end2) { + // Reached end of string2. + return new Fixnum(i); + } + char c1 = LispCharacter.toUpperCase(array1[i]); + char c2 = LispCharacter.toUpperCase(array2[j]); + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 > c2) + return new Fixnum(i); + // c1 < c2 + return NIL; + } + } + }; + + // ### %string-not-greaterp + // Case insensitive. + private static final Primitive _STRING_NOT_GREATERP = + new Primitive("%string-not-greaterp", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 6) + return error(new WrongNumberOfArgumentsException(this)); + char[] array1 = args[0].STRING().getStringChars(); + char[] array2 = args[1].STRING().getStringChars(); + int start1 = Fixnum.getValue(args[2]); + int end1 = Fixnum.getValue(args[3]); + int start2 = Fixnum.getValue(args[4]); + int end2 = Fixnum.getValue(args[5]); + int i = start1; + int j = start2; + while (true) { + if (i == end1) { + // Reached end of string1. + return new Fixnum(i); + } + if (j == end2) { + // Reached end of string2. + return NIL; + } + char c1 = LispCharacter.toUpperCase(array1[i]); + char c2 = LispCharacter.toUpperCase(array2[j]); + if (c1 == c2) { + ++i; + ++j; + continue; + } + if (c1 > c2) + return NIL; + // c1 < c2 + return new Fixnum(i); + } + } + }; + + // ### %string-upcase + private static final Primitive _STRING_UPCASE = + new Primitive("%string-upcase", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + LispObject s = first.STRING(); + final int length = s.length(); + int start = (int) Fixnum.getValue(second); + if (start < 0 || start > length) + return error(new TypeError("Invalid start position " + start + ".")); + int end; + if (third == NIL) + end = length; + else + end = (int) Fixnum.getValue(third); + if (end < 0 || end > length) + return error(new TypeError("Invalid end position " + start + ".")); + if (start > end) + return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + FastStringBuffer sb = new FastStringBuffer(length); + char[] array = s.getStringChars(); + int i; + for (i = 0; i < start; i++) + sb.append(array[i]); + for (i = start; i < end; i++) + sb.append(LispCharacter.toUpperCase(array[i])); + for (i = end; i < length; i++) + sb.append(array[i]); + return new SimpleString(sb); + } + }; + + // ### %string-downcase + private static final Primitive _STRING_DOWNCASE = + new Primitive("%string-downcase", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) throws + ConditionThrowable + { + LispObject s = first.STRING(); + final int length = s.length(); + int start = (int) Fixnum.getValue(second); + if (start < 0 || start > length) + return error(new TypeError("Invalid start position " + start + ".")); + int end; + if (third == NIL) + end = length; + else + end = (int) Fixnum.getValue(third); + if (end < 0 || end > length) + return error(new TypeError("Invalid end position " + start + ".")); + if (start > end) + return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + FastStringBuffer sb = new FastStringBuffer(length); + char[] array = s.getStringChars(); + int i; + for (i = 0; i < start; i++) + sb.append(array[i]); + for (i = start; i < end; i++) + sb.append(LispCharacter.toLowerCase(array[i])); + for (i = end; i < length; i++) + sb.append(array[i]); + return new SimpleString(sb); + } + }; + + // ### %string-capitalize + private static final Primitive _STRING_CAPITALIZE= + new Primitive("%string-capitalize", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + LispObject s = first.STRING(); + final int length = s.length(); + int start = (int) Fixnum.getValue(second); + if (start < 0 || start > length) + return error(new TypeError("Invalid start position " + start + ".")); + int end; + if (third == NIL) + end = length; + else + end = (int) Fixnum.getValue(third); + if (end < 0 || end > length) + return error(new TypeError("Invalid end position " + start + ".")); + if (start > end) + return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + FastStringBuffer sb = new FastStringBuffer(length); + char[] array = s.getStringChars(); + boolean lastCharWasAlphanumeric = false; + int i; + for (i = 0; i < start; i++) + sb.append(array[i]); + for (i = start; i < end; i++) { + char c = array[i]; + if (Character.isLowerCase(c)) { + sb.append(lastCharWasAlphanumeric ? c : LispCharacter.toUpperCase(c)); + lastCharWasAlphanumeric = true; + } else if (Character.isUpperCase(c)) { + sb.append(lastCharWasAlphanumeric ? LispCharacter.toLowerCase(c) : c); + lastCharWasAlphanumeric = true; + } else { + sb.append(c); + lastCharWasAlphanumeric = Character.isDigit(c); + } + } + for (i = end; i < length; i++) + sb.append(array[i]); + return new SimpleString(sb); + } + }; + + // ### %nstring-upcase + private static final Primitive _NSTRING_UPCASE = + new Primitive("%nstring-upcase", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + AbstractString string; + try { + string = (AbstractString) first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STRING); + } + final int length = string.length(); + int start = (int) Fixnum.getValue(second); + if (start < 0 || start > length) + return error(new TypeError("Invalid start position " + start + ".")); + int end; + if (third == NIL) + end = length; + else + end = (int) Fixnum.getValue(third); + if (end < 0 || end > length) + return error(new TypeError("Invalid end position " + start + ".")); + if (start > end) + return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + for (int i = start; i < end; i++) + string.setCharAt(i, LispCharacter.toUpperCase(string.charAt(i))); + return string; + } + }; + + // ### %nstring-downcase + private static final Primitive _NSTRING_DOWNCASE = + new Primitive("%nstring-downcase", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + AbstractString string; + try { + string = (AbstractString) first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STRING); + } + final int length = string.length(); + int start = (int) Fixnum.getValue(second); + if (start < 0 || start > length) + return error(new TypeError("Invalid start position " + start + ".")); + int end; + if (third == NIL) + end = length; + else + end = (int) Fixnum.getValue(third); + if (end < 0 || end > length) + return error(new TypeError("Invalid end position " + start + ".")); + if (start > end) + return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + for (int i = start; i < end; i++) + string.setCharAt(i, LispCharacter.toLowerCase(string.charAt(i))); + return string; + } + }; + + // ### %nstring-capitalize + private static final Primitive _NSTRING_CAPITALIZE = + new Primitive("%nstring-capitalize", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + AbstractString string; + try { + string = (AbstractString) first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STRING); + } + final int length = string.length(); + int start = (int) Fixnum.getValue(second); + if (start < 0 || start > length) + return error(new TypeError("Invalid start position " + start + ".")); + int end; + if (third == NIL) + end = length; + else + end = (int) Fixnum.getValue(third); + if (end < 0 || end > length) + return error(new TypeError("Invalid end position " + start + ".")); + if (start > end) + return error(new TypeError("Start (" + start + ") is greater than end (" + end + ").")); + boolean lastCharWasAlphanumeric = false; + for (int i = start; i < end; i++) { + char c = string.charAt(i); + if (Character.isLowerCase(c)) { + if (!lastCharWasAlphanumeric) + string.setCharAt(i, LispCharacter.toUpperCase(c)); + lastCharWasAlphanumeric = true; + } else if (Character.isUpperCase(c)) { + if (lastCharWasAlphanumeric) + string.setCharAt(i, LispCharacter.toLowerCase(c)); + lastCharWasAlphanumeric = true; + } else + lastCharWasAlphanumeric = Character.isDigit(c); + } + return string; + } + }; + + // ### stringp + public static final Primitive STRINGP = new Primitive("stringp", "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.STRINGP(); + } + }; + + // ### simple-string-p + public static final Primitive SIMPLE_STRING_P = + new Primitive("simple-string-p", "object") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.SIMPLE_STRING_P(); + } + }; + + // ### %make-string + // %make-string size initial-element element-type => string + // Returns a simple string. + private static final Primitive _MAKE_STRING = + new Primitive("%make-string", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject size, LispObject initialElement, + LispObject elementType) + throws ConditionThrowable + { + final int n; + try { + n = ((Fixnum)size).value; + } + catch (ClassCastException e) { + return type_error(size, Symbol.FIXNUM); + } + if (n < 0 || n >= ARRAY_DIMENSION_MAX) { + FastStringBuffer sb = new FastStringBuffer(); + sb.append("The size specified for this string ("); + sb.append(n); + sb.append(')'); + if (n >= ARRAY_DIMENSION_MAX) { + sb.append(" is >= ARRAY-DIMENSION-LIMIT ("); + sb.append(ARRAY_DIMENSION_MAX); + sb.append(")."); + } else + sb.append(" is negative."); + return error(new LispError(sb.toString())); + } + // Ignore elementType. + SimpleString string = new SimpleString(n); + if (initialElement != NIL) { + // Initial element was specified. + char c = checkCharacter(initialElement).getValue(); + string.fill(c); + } + return string; + } + }; + + // ### char + private static final Primitive CHAR = + new Primitive(Symbol.CHAR, "string index") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + return first.CHAR(((Fixnum)second).value); + } + catch (ClassCastException e) { + return type_error(second, Symbol.FIXNUM); + } + } + }; + + // ### schar + private static final Primitive SCHAR = + new Primitive(Symbol.SCHAR, "string index") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + return first.SCHAR(((Fixnum)second).value); + } + catch (ClassCastException e) { + return type_error(second, Symbol.FIXNUM); + } + } + }; + + // ### set-char + private static final Primitive SET_CHAR = + new Primitive(Symbol.SET_CHAR, "string index character") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try { + ((AbstractString)first).setCharAt(((Fixnum)second).value, + ((LispCharacter)third).value); + return third; + } + catch (ClassCastException e) { + if (!(first instanceof AbstractString)) + return type_error(first, Symbol.STRING); + else if (!(second instanceof Fixnum)) + return type_error(second, Symbol.FIXNUM); + else + return type_error(third, Symbol.CHARACTER); + } + } + }; + + // ### set-schar + private static final Primitive SET_SCHAR = + new Primitive(Symbol.SET_SCHAR, "string index character") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try { + ((SimpleString)first).setCharAt(((Fixnum)second).value, + ((LispCharacter)third).value); + return third; + } + catch (ClassCastException e) { + if (!(first instanceof SimpleString)) + return type_error(first, Symbol.SIMPLE_STRING); + if (!(second instanceof Fixnum)) + return type_error(second, Symbol.FIXNUM); + return type_error(third, Symbol.CHARACTER); + } + } + }; + + // ### string-position + private static final Primitive STRING_POSITION = + new Primitive("string-position", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + char c = LispCharacter.getValue(first); + AbstractString string; + if (second instanceof AbstractString) + string = (AbstractString) second; + else + return type_error(second, Symbol.STRING); + int start = Fixnum.getValue(third); + for (int i = start, limit = string.length(); i < limit; i++) { + if (string.charAt(i) == c) + return number(i); + } + return NIL; + } + }; + + // ### string-find + private static final Primitive STRING_FIND = + new Primitive("string-find", PACKAGE_EXT, true, "char string") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof LispCharacter) { + final char c = ((LispCharacter)first).value; + final AbstractString string; + try { + string = (AbstractString) second; + } + catch (ClassCastException e) { + return type_error(second, Symbol.STRING); + } + final int limit = string.length(); + for (int i = 0; i < limit; i++) { + if (string.charAt(i) == c) + return first; + } + } + return NIL; + } + }; + + // ### simple-string-search pattern string => position + // Searches string for a substring that matches pattern. + private static final Primitive SIMPLE_STRING_SEARCH = + new Primitive("simple-string-search", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + // FIXME Don't call getStringValue() here! (Just look at the chars.) + int index = second.getStringValue().indexOf(first.getStringValue()); + return index >= 0 ? new Fixnum(index) : NIL; + } + }; + + // ### simple-string-fill string character => string + private static final Primitive STRING_FILL = + new Primitive("simple-string-fill", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + AbstractString s = (AbstractString) first; + s.fill(LispCharacter.getValue(second)); + return first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.SIMPLE_STRING); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StringInputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,149 @@ +/* + * StringInputStream.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: StringInputStream.java 11434 2008-12-07 23:24:31Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.StringReader; + +public final class StringInputStream extends Stream +{ + private final StringReader stringReader; + private final int start; + + public StringInputStream(String s) + { + this(s, 0, s.length()); + } + + public StringInputStream(String s, int start) + { + this(s, start, s.length()); + } + + public StringInputStream(String s, int start, int end) + { + elementType = Symbol.CHARACTER; + setExternalFormat(keywordDefault); + eolStyle = EolStyle.RAW; + + this.start = start; + + stringReader = new StringReader(s.substring(start, end)); + initAsCharacterInputStream(stringReader); + } + + @Override + public LispObject typeOf() + { + return Symbol.STRING_INPUT_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.STRING_INPUT_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STRING_INPUT_STREAM) + return T; + if (type == Symbol.STRING_STREAM) + return T; + if (type == BuiltInClass.STRING_INPUT_STREAM) + return T; + if (type == BuiltInClass.STRING_STREAM) + return T; + return super.typep(type); + } + + @Override + public String toString() + { + return unreadableString("STRING-INPUT-STREAM"); + } + + @Override + public int getOffset() { + return start + super.getOffset(); + } + + // ### make-string-input-stream + // make-string-input-stream string &optional start end => string-stream + private static final Primitive MAKE_STRING_INPUT_STREAM = + new Primitive("make-string-input-stream", "string &optional start end") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new StringInputStream(arg.getStringValue()); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + String s = first.getStringValue(); + int start = Fixnum.getValue(second); + return new StringInputStream(s, start); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + String s = first.getStringValue(); + int start = Fixnum.getValue(second); + if (third == NIL) + return new StringInputStream(s, start); + int end = Fixnum.getValue(third); + return new StringInputStream(s, start, end); + } + }; + + // ### string-input-stream-current + private static final Primitive STRING_INPUT_STREAM_CURRENT = + new Primitive("string-input-stream-current", PACKAGE_EXT, true, "stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof StringInputStream) + return new Fixnum(((StringInputStream)arg).getOffset()); + return error(new TypeError(String.valueOf(arg) + + " is not a string input stream.")); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StringOutputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,133 @@ +/* + * StringOutputStream.java + * + * Copyright (C) 2002-2004 Peter Graves + * $Id: StringOutputStream.java 11434 2008-12-07 23:24:31Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.StringWriter; + +public final class StringOutputStream extends Stream +{ + private final StringWriter stringWriter; + + public StringOutputStream() + { + this(Symbol.CHARACTER); + } + + private StringOutputStream(LispObject elementType) + { + this.elementType = elementType; + this.eolStyle = EolStyle.RAW; + initAsCharacterOutputStream(stringWriter = new StringWriter()); + } + + @Override + public LispObject typeOf() + { + return Symbol.STRING_OUTPUT_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.STRING_OUTPUT_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STRING_OUTPUT_STREAM) + return T; + if (type == Symbol.STRING_STREAM) + return T; + if (type == BuiltInClass.STRING_OUTPUT_STREAM) + return T; + if (type == BuiltInClass.STRING_STREAM) + return T; + return super.typep(type); + } + + @Override + protected long _getFilePosition() throws ConditionThrowable + { + if (elementType == NIL) + return 0; + return stringWriter.getBuffer().length(); + } + + public LispObject getString() throws ConditionThrowable + { + if (elementType == NIL) + return new NilVector(0); + StringBuffer sb = stringWriter.getBuffer(); + SimpleString s = new SimpleString(sb); + sb.setLength(0); + return s; + } + + @Override + public String toString() + { + return unreadableString("STRING-OUTPUT-STREAM"); + } + + // ### %make-string-output-stream + // %make-string-output-stream element-type => string-stream + private static final Primitive MAKE_STRING_OUTPUT_STREAM = + new Primitive("%make-string-output-stream", PACKAGE_SYS, false, + "element-type") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new StringOutputStream(arg); + } + }; + + // ### get-output-stream-string + // get-output-stream-string string-output-stream => string + private static final Primitive GET_OUTPUT_STREAM_STRING = + new Primitive("get-output-stream-string", "string-output-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((StringOutputStream)arg).getString(); + } + catch (ClassCastException e) { + return error(new TypeError(this, Symbol.STRING_OUTPUT_STREAM)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StructureClass.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StructureClass.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,113 @@ +/* + * StructureClass.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: StructureClass.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class StructureClass extends SlotClass +{ + private StructureClass(Symbol symbol) + { + super(symbol, new Cons(BuiltInClass.STRUCTURE_OBJECT)); + } + + public StructureClass(Symbol symbol, LispObject directSuperclasses) + { + super(symbol, directSuperclasses); + } + + @Override + public LispObject typeOf() + { + return Symbol.STRUCTURE_CLASS; + } + + @Override + public LispObject classOf() + { + return StandardClass.STRUCTURE_CLASS; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STRUCTURE_CLASS) + return T; + if (type == StandardClass.STRUCTURE_CLASS) + return T; + return super.typep(type); + } + + @Override + public LispObject getDescription() throws ConditionThrowable + { + return new SimpleString(writeToString()); + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = new StringBuffer("#'); + return sb.toString(); + } + + // ### make-structure-class name direct-slots slots include => class + private static final Primitive MAKE_STRUCTURE_CLASS = + new Primitive("make-structure-class", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + Symbol symbol = checkSymbol(first); + LispObject directSlots = checkList(second); + LispObject slots = checkList(third); + Symbol include = checkSymbol(fourth); + StructureClass c = new StructureClass(symbol); + if (include != NIL) { + LispClass includedClass = LispClass.findClass(include); + if (includedClass == null) + return error(new SimpleError("Class " + include + + " is undefined.")); + c.setCPL(new Cons(c, includedClass.getCPL())); + } else + c.setCPL(c, BuiltInClass.STRUCTURE_OBJECT, BuiltInClass.CLASS_T); + c.setDirectSlotDefinitions(directSlots); + c.setSlotDefinitions(slots); + addClass(symbol, c); + return c; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StructureObject.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,691 @@ +/* + * StructureObject.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: StructureObject.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StructureObject extends LispObject +{ + private final StructureClass structureClass; + private final LispObject[] slots; + + public StructureObject(Symbol symbol, LispObject[] slots) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + this.slots = slots; + } + + public StructureObject(Symbol symbol, LispObject obj0) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + LispObject[] slots = new LispObject[1]; + slots[0] = obj0; + this.slots = slots; + } + + public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + LispObject[] slots = new LispObject[2]; + slots[0] = obj0; + slots[1] = obj1; + this.slots = slots; + } + + public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1, + LispObject obj2) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + LispObject[] slots = new LispObject[3]; + slots[0] = obj0; + slots[1] = obj1; + slots[2] = obj2; + this.slots = slots; + } + + public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1, + LispObject obj2, LispObject obj3) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + LispObject[] slots = new LispObject[4]; + slots[0] = obj0; + slots[1] = obj1; + slots[2] = obj2; + slots[3] = obj3; + this.slots = slots; + } + + public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1, + LispObject obj2, LispObject obj3, LispObject obj4) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + LispObject[] slots = new LispObject[5]; + slots[0] = obj0; + slots[1] = obj1; + slots[2] = obj2; + slots[3] = obj3; + slots[4] = obj4; + this.slots = slots; + } + + public StructureObject(Symbol symbol, LispObject obj0, LispObject obj1, + LispObject obj2, LispObject obj3, LispObject obj4, + LispObject obj5) + throws ConditionThrowable + { + structureClass = (StructureClass) LispClass.findClass(symbol); // Might return null. + LispObject[] slots = new LispObject[6]; + slots[0] = obj0; + slots[1] = obj1; + slots[2] = obj2; + slots[3] = obj3; + slots[4] = obj4; + slots[5] = obj5; + this.slots = slots; + } + + public StructureObject(StructureObject obj) + { + this.structureClass = obj.structureClass; + slots = new LispObject[obj.slots.length]; + for (int i = slots.length; i-- > 0;) + slots[i] = obj.slots[i]; + } + + @Override + public LispObject typeOf() + { + return structureClass.getSymbol(); + } + + @Override + public LispObject classOf() + { + return structureClass; + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject result = NIL; + result = result.push(new Cons("class", structureClass)); + LispObject effectiveSlots = structureClass.getSlotDefinitions(); + LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray(); + Debug.assertTrue(effectiveSlotsArray.length == slots.length); + for (int i = 0; i < slots.length; i++) + { + SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i]; + LispObject slotName = slotDefinition.AREF(1); + result = result.push(new Cons(slotName, slots[i])); + } + return result.nreverse(); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type instanceof StructureClass) + return memq(type, structureClass.getCPL()) ? T : NIL; + if (type == structureClass.getSymbol()) + return T; + if (type == Symbol.STRUCTURE_OBJECT) + return T; + if (type == BuiltInClass.STRUCTURE_OBJECT) + return T; + if (type instanceof Symbol) + { + LispClass c = LispClass.findClass((Symbol)type); + if (c != null) + return memq(c, structureClass.getCPL()) ? T : NIL; + } + return super.typep(type); + } + + @Override + public boolean equalp(LispObject obj) throws ConditionThrowable + { + if (this == obj) + return true; + if (obj instanceof StructureObject) + { + StructureObject o = (StructureObject) obj; + if (structureClass != o.structureClass) + return false; + for (int i = 0; i < slots.length; i++) + { + if (!slots[i].equalp(o.slots[i])) + return false; + } + return true; + } + return false; + } + + @Override + public LispObject getSlotValue_0() throws ConditionThrowable + { + try + { + return slots[0]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return badIndex(0); + } + } + + @Override + public LispObject getSlotValue_1() throws ConditionThrowable + { + try + { + return slots[1]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return badIndex(1); + } + } + + @Override + public LispObject getSlotValue_2() throws ConditionThrowable + { + try + { + return slots[2]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return badIndex(2); + } + } + + @Override + public LispObject getSlotValue_3() throws ConditionThrowable + { + try + { + return slots[3]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return badIndex(3); + } + } + + @Override + public LispObject getSlotValue(int index) throws ConditionThrowable + { + try + { + return slots[index]; + } + catch (ArrayIndexOutOfBoundsException e) + { + return badIndex(index); + } + } + + @Override + public int getFixnumSlotValue(int index) throws ConditionThrowable + { + try + { + return ((Fixnum)slots[index]).value; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index); + // Not reached. + return 0; + } + catch (ClassCastException e) + { + type_error(slots[index], Symbol.FIXNUM); + // Not reached. + return 0; + } + } + + @Override + public boolean getSlotValueAsBoolean(int index) throws ConditionThrowable + { + try + { + return slots[index] != NIL ? true : false; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index); + // Not reached. + return false; + } + } + + @Override + public void setSlotValue_0(LispObject value) + throws ConditionThrowable + { + try + { + slots[0] = value; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(0); + } + } + + @Override + public void setSlotValue_1(LispObject value) + throws ConditionThrowable + { + try + { + slots[1] = value; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(1); + } + } + + @Override + public void setSlotValue_2(LispObject value) + throws ConditionThrowable + { + try + { + slots[2] = value; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(2); + } + } + + @Override + public void setSlotValue_3(LispObject value) + throws ConditionThrowable + { + try + { + slots[3] = value; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(3); + } + } + + @Override + public void setSlotValue(int index, LispObject value) + throws ConditionThrowable + { + try + { + slots[index] = value; + } + catch (ArrayIndexOutOfBoundsException e) + { + badIndex(index); + } + } + + private LispObject badIndex(int n) throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("Invalid slot index "); + sb.append(Fixnum.getInstance(n).writeToString()); + sb.append(" for "); + sb.append(writeToString()); + return error(new LispError(sb.toString())); + } + + @Override + public final int psxhash() + { + return psxhash(4); + } + + @Override + public final int psxhash(int depth) + { + int result = mix(structureClass.sxhash(), 7814971); + if (depth > 0) + { + int limit = slots.length; + if (limit > 4) + limit = 4; + for (int i = 0; i < limit; i++) + result = mix(slots[i].psxhash(depth - 1), result); + } + return result & 0x7fffffff; + } + + @Override + public String writeToString() throws ConditionThrowable + { + try + { + final LispThread thread = LispThread.currentThread(); + // FIXME + if (typep(Symbol.RESTART) != NIL) + { + Symbol PRINT_RESTART = PACKAGE_SYS.intern("PRINT-RESTART"); + LispObject fun = PRINT_RESTART.getSymbolFunction(); + StringOutputStream stream = new StringOutputStream(); + thread.execute(fun, this, stream); + return stream.getString().getStringValue(); + } + if (_PRINT_STRUCTURE_.symbolValue(thread) == NIL) + return unreadableString(structureClass.getSymbol().writeToString()); + int maxLevel = Integer.MAX_VALUE; + LispObject printLevel = Symbol.PRINT_LEVEL.symbolValue(thread); + if (printLevel instanceof Fixnum) + maxLevel = ((Fixnum)printLevel).value; + LispObject currentPrintLevel = + _CURRENT_PRINT_LEVEL_.symbolValue(thread); + int currentLevel = Fixnum.getValue(currentPrintLevel); + if (currentLevel >= maxLevel && slots.length > 0) + return "#"; + FastStringBuffer sb = new FastStringBuffer("#S("); + sb.append(structureClass.getSymbol().writeToString()); + if (currentLevel < maxLevel) + { + LispObject effectiveSlots = structureClass.getSlotDefinitions(); + LispObject[] effectiveSlotsArray = effectiveSlots.copyToArray(); + Debug.assertTrue(effectiveSlotsArray.length == slots.length); + final LispObject printLength = Symbol.PRINT_LENGTH.symbolValue(thread); + final int limit; + if (printLength instanceof Fixnum) + limit = Math.min(slots.length, ((Fixnum)printLength).value); + else + limit = slots.length; + final boolean printCircle = + (Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL); + for (int i = 0; i < limit; i++) + { + sb.append(' '); + SimpleVector slotDefinition = (SimpleVector) effectiveSlotsArray[i]; + // FIXME AREF(1) + LispObject slotName = slotDefinition.AREF(1); + Debug.assertTrue(slotName instanceof Symbol); + sb.append(':'); + sb.append(((Symbol)slotName).name.getStringValue()); + sb.append(' '); + if (printCircle) + { + StringOutputStream stream = new StringOutputStream(); + thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(), + slots[i], stream); + sb.append(stream.getString().getStringValue()); + } + else + sb.append(slots[i].writeToString()); + } + if (limit < slots.length) + sb.append(" ..."); + } + sb.append(')'); + return sb.toString(); + } + catch (StackOverflowError e) + { + error(new StorageCondition("Stack overflow.")); + return null; // Not reached. + } + } + + // ### structure-object-p object => generalized-boolean + private static final Primitive STRUCTURE_OBJECT_P = + new Primitive("structure-object-p", PACKAGE_SYS, true, "object") + { + @Override + public LispObject execute(LispObject arg) + { + return arg instanceof StructureObject ? T : NIL; + } + }; + + // ### structure-length instance => length + private static final Primitive STRUCTURE_LENGTH = + new Primitive("structure-length", PACKAGE_SYS, true, "instance") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new Fixnum(((StructureObject)arg).slots.length); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STRUCTURE_OBJECT); + } + } + }; + + // ### structure-ref instance index => value + private static final Primitive STRUCTURE_REF = + new Primitive("structure-ref", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return ((StructureObject)first).slots[((Fixnum)second).value]; + } + catch (ClassCastException e) + { + if (first instanceof StructureObject) + return type_error(second, Symbol.FIXNUM); + else + return type_error(first, Symbol.STRUCTURE_OBJECT); + } + catch (ArrayIndexOutOfBoundsException e) + { + // Shouldn't happen. + return error(new LispError("Internal error.")); + } + } + }; + + // ### structure-set instance index new-value => new-value + private static final Primitive STRUCTURE_SET = + new Primitive("structure-set", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try + { + ((StructureObject)first).slots[((Fixnum)second).value] = third; + return third; + } + catch (ClassCastException e) + { + if (first instanceof StructureObject) + return type_error(second, Symbol.FIXNUM); + else + return type_error(first, Symbol.STRUCTURE_OBJECT); + } + catch (ArrayIndexOutOfBoundsException e) + { + // Shouldn't happen. + return error(new LispError("Internal error.")); + } + } + }; + + // ### make-structure + private static final Primitive MAKE_STRUCTURE = + new Primitive("make-structure", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second, third); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second, third, fourth); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second, third, fourth, + fifth); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second, third, fourth, + fifth, sixth); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second, third, fourth, + fifth, sixth, seventh); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + }; + + // ### %make-structure name slot-values => object + private static final Primitive _MAKE_STRUCTURE = + new Primitive("%make-structure", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return new StructureObject(((Symbol)first), second.copyToArray()); + } + catch (ClassCastException e) + { + return type_error(first, Symbol.SYMBOL); + } + } + }; + + // ### copy-structure structure => copy + private static final Primitive COPY_STRUCTURE = + new Primitive(Symbol.COPY_STRUCTURE, "structure") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return new StructureObject((StructureObject)arg); + } + catch (ClassCastException e) + { + return type_error(arg, Symbol.STRUCTURE_OBJECT); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/StyleWarning.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/StyleWarning.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,65 @@ +/* + * StyleWarning.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: StyleWarning.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class StyleWarning extends Warning +{ + public StyleWarning(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.STYLE_WARNING); + initialize(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.STYLE_WARNING; + } + + @Override + public LispObject classOf() + { + return StandardClass.STYLE_WARNING; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.STYLE_WARNING) + return T; + if (type == StandardClass.STYLE_WARNING) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/Symbol.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Symbol.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,3048 @@ +/* + * Symbol.java + * + * Copyright (C) 2002-2007 Peter Graves + * $Id: Symbol.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Symbol extends LispObject +{ + // Bit flags. + private static final int FLAG_SPECIAL = 0x0001; + private static final int FLAG_CONSTANT = 0x0002; + private static final int FLAG_BUILT_IN_FUNCTION = 0x0004; + + public static final Symbol addFunction(String name, LispObject obj) + { + try + { + Symbol symbol = PACKAGE_CL.internAndExport(name); + symbol.function = obj; + return symbol; + } + catch (ConditionThrowable t) + { + Debug.trace(t); // Shouldn't happen. + return null; + } + } + + public final SimpleString name; + private int hash = -1; + private transient LispObject pkg; // Either a package object or NIL. + private LispObject value; + private LispObject function; + private LispObject propertyList; + private int flags; + + // Construct an uninterned symbol. + public Symbol(String s) + { + name = new SimpleString(s); + pkg = NIL; + } + + public Symbol(SimpleString string) + { + name = string; + pkg = NIL; + } + + public Symbol(String s, Package pkg) + { + name = new SimpleString(s); + this.pkg = pkg; + } + + public Symbol(SimpleString string, Package pkg) + { + name = string; + this.pkg = pkg; + } + + public Symbol(SimpleString string, int hash, Package pkg) + { + name = string; + this.hash = hash; + this.pkg = pkg; + } + + @Override + public LispObject typeOf() + { + if (pkg == PACKAGE_KEYWORD) + return Symbol.KEYWORD; + if (this == T) + return Symbol.BOOLEAN; + return Symbol.SYMBOL; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SYMBOL; + } + + @Override + public LispObject getDescription() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); + try + { + FastStringBuffer sb = new FastStringBuffer("The symbol "); + sb.append(name.writeToString()); + sb.append(" at #x"); + sb.append(Integer.toHexString(System.identityHashCode(this)).toUpperCase()); + if (pkg instanceof Package) + { + sb.append(", an "); + Symbol sym = ((Package)pkg).findExternalSymbol(name); + sb.append(sym == this ? "external" : "internal"); + sb.append(" symbol in the "); + sb.append(((Package)pkg).getName()); + sb.append(" package"); + } + return new SimpleString(sb); + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + @Override + public LispObject getParts() throws ConditionThrowable + { + LispObject parts = NIL; + parts = parts.push(new Cons("name", name)); + parts = parts.push(new Cons("package", pkg)); + parts = parts.push(new Cons("value", value)); + parts = parts.push(new Cons("function", function)); + parts = parts.push(new Cons("plist", propertyList)); + parts = parts.push(new Cons("flags", new Fixnum(flags))); + parts = parts.push(new Cons("hash", new Fixnum(hash))); + return parts.nreverse(); + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SYMBOL) + return T; + if (type == BuiltInClass.SYMBOL) + return T; + if (type == Symbol.KEYWORD) + return pkg == PACKAGE_KEYWORD ? T : NIL; + if (type == Symbol.BOOLEAN) + return this == T ? T : NIL; + return super.typep(type); + } + + @Override + public final LispObject SYMBOLP() + { + return T; + } + + @Override + public boolean constantp() + { + return (flags & FLAG_CONSTANT) != 0; + } + + @Override + public final LispObject STRING() + { + return name; + } + + public final LispObject getPackage() + { + return pkg; + } + + public final void setPackage(LispObject obj) + { + pkg = obj; + } + + @Override + public final boolean isSpecialOperator() + { + return (function instanceof SpecialOperator); + } + + @Override + public final boolean isSpecialVariable() + { + return (flags & FLAG_SPECIAL) != 0; + } + + public final void setSpecial(boolean b) + { + if (b) + flags |= FLAG_SPECIAL; + else + flags &= ~FLAG_SPECIAL; + } + + public final void initializeSpecial(LispObject value) + { + flags |= FLAG_SPECIAL; + this.value = value; + } + + public final boolean isConstant() + { + return (flags & FLAG_CONSTANT) != 0; + } + + public final void initializeConstant(LispObject value) + { + flags |= (FLAG_SPECIAL | FLAG_CONSTANT); + this.value = value; + } + + public final boolean isBuiltInFunction() + { + return (flags & FLAG_BUILT_IN_FUNCTION) != 0; + } + + public final void setBuiltInFunction(boolean b) + { + if (b) + flags |= FLAG_BUILT_IN_FUNCTION; + else + flags &= ~FLAG_BUILT_IN_FUNCTION; + } + + public final String getName() + { + try + { + return name.getStringValue(); + } + catch (Throwable t) + { + Debug.trace(t); + return null; + } + } + + public final String getQualifiedName() + { + try + { + final String n = name.getStringValue(); + if (pkg == NIL) + return("#:".concat(n)); + if (pkg == PACKAGE_KEYWORD) + return ":".concat(n); + FastStringBuffer sb = new FastStringBuffer(((Package)pkg).getName()); + if (((Package)pkg).findExternalSymbol(name) != null) + sb.append(':'); + else + sb.append("::"); + sb.append(n); + return sb.toString(); + } + catch (Throwable t) + { + Debug.trace(t); + return null; + } + } + + // Raw accessor. + @Override + public LispObject getSymbolValue() + { + return value; + } + + public final void setSymbolValue(LispObject value) + { + this.value = value; + } + + public final LispObject symbolValue() throws ConditionThrowable + { + LispObject val = LispThread.currentThread().lookupSpecial(this); + if (val != null) + return val; + if (value != null) + return value; + return error(new UnboundVariable(this)); + } + + public final LispObject symbolValue(LispThread thread) throws ConditionThrowable + { + LispObject val = thread.lookupSpecial(this); + if (val != null) + return val; + if (value != null) + return value; + return error(new UnboundVariable(this)); + } + + public final LispObject symbolValueNoThrow() + { + if ((flags & FLAG_SPECIAL) != 0) + { + LispObject val = LispThread.currentThread().lookupSpecial(this); + if (val != null) + return val; + } + return value; + } + + public final LispObject symbolValueNoThrow(LispThread thread) + { + if ((flags & FLAG_SPECIAL) != 0) + { + LispObject val = thread.lookupSpecial(this); + if (val != null) + return val; + } + return value; + } + + @Override + public LispObject getSymbolFunction() + { + return function; + } + + @Override + public final LispObject getSymbolFunctionOrDie() throws ConditionThrowable + { + if (function == null) + return error(new UndefinedFunction(this)); + if (function instanceof Autoload) + { + Autoload autoload = (Autoload) function; + autoload.load(); + } + return function; + } + + public final LispObject getSymbolSetfFunctionOrDie() + throws ConditionThrowable + { + LispObject obj = get(this, Symbol.SETF_FUNCTION, null); + if (obj == null) + error(new UndefinedFunction(list2(Keyword.NAME, + list2(Symbol.SETF, + this)))); + return obj; + } + + public final void setSymbolFunction(LispObject obj) + { + this.function = obj; + } + + @Override + public final LispObject getPropertyList() + { + if (propertyList == null) + propertyList = NIL; + return propertyList; + } + + @Override + public final void setPropertyList(LispObject obj) + { + if (obj == null) + throw new NullPointerException(); + propertyList = obj; + } + + @Override + public String writeToString() throws ConditionThrowable + { + final String n = name.getStringValue(); + final LispThread thread = LispThread.currentThread(); + boolean printEscape = (PRINT_ESCAPE.symbolValue(thread) != NIL); + LispObject printCase = PRINT_CASE.symbolValue(thread); + final LispObject readtableCase = + ((Readtable)CURRENT_READTABLE.symbolValue(thread)).getReadtableCase(); + boolean printReadably = (PRINT_READABLY.symbolValue(thread) != NIL); + if (printReadably) + { + if (readtableCase != Keyword.UPCASE || + printCase != Keyword.UPCASE) + { + FastStringBuffer sb = new FastStringBuffer(); + if (pkg == PACKAGE_KEYWORD) + { + sb.append(':'); + } + else if (pkg instanceof Package) + { + sb.append(multipleEscape(((Package)pkg).getName())); + sb.append("::"); + } + else + { + sb.append("#:"); + } + sb.append(multipleEscape(n)); + return sb.toString(); + } + else + printEscape = true; + } + if (!printEscape) + { + if (pkg == PACKAGE_KEYWORD) + { + if (printCase == Keyword.DOWNCASE) + return n.toLowerCase(); + if (printCase == Keyword.CAPITALIZE) + return capitalize(n, readtableCase); + return n; + } + // Printer escaping is disabled. + if (readtableCase == Keyword.UPCASE) + { + if (printCase == Keyword.DOWNCASE) + return n.toLowerCase(); + if (printCase == Keyword.CAPITALIZE) + return capitalize(n, readtableCase); + return n; + } + else if (readtableCase == Keyword.DOWNCASE) + { + // "When the readtable case is :DOWNCASE, uppercase characters + // are printed in their own case, and lowercase characters are + // printed in the case specified by *PRINT-CASE*." (22.1.3.3.2) + if (printCase == Keyword.DOWNCASE) + return n; + if (printCase == Keyword.UPCASE) + return n.toUpperCase(); + if (printCase == Keyword.CAPITALIZE) + return capitalize(n, readtableCase); + return n; + } + else if (readtableCase == Keyword.PRESERVE) + { + return n; + } + else // INVERT + return invert(n); + } + // Printer escaping is enabled. + final boolean escapeSymbolName = needsEscape(n, readtableCase, thread); + String symbolName = escapeSymbolName ? multipleEscape(n) : n; + if (!escapeSymbolName) + { + if (readtableCase == Keyword.PRESERVE) { } + else if (readtableCase == Keyword.INVERT) + symbolName = invert(symbolName); + else if (printCase == Keyword.DOWNCASE) + symbolName = symbolName.toLowerCase(); + else if (printCase == Keyword.UPCASE) + symbolName = symbolName.toUpperCase(); + else if (printCase == Keyword.CAPITALIZE) + symbolName = capitalize(symbolName, readtableCase); + } + if (pkg == NIL) + { + if (printReadably || PRINT_GENSYM.symbolValue(thread) != NIL) + return "#:".concat(symbolName); + else + return symbolName; + } + if (pkg == PACKAGE_KEYWORD) + return ":".concat(symbolName); + // "Package prefixes are printed if necessary." (22.1.3.3.1) + final Package currentPackage = (Package) _PACKAGE_.symbolValue(thread); + if (pkg == currentPackage) + return symbolName; + if (currentPackage != null && currentPackage.uses(pkg)) + { + // Check for name conflict in current package. + if (currentPackage.findExternalSymbol(name) == null) + if (currentPackage.findInternalSymbol(name) == null) + if (((Package)pkg).findExternalSymbol(name) != null) + return symbolName; + } + // Has this symbol been imported into the current package? + if (currentPackage.findExternalSymbol(name) == this) + return symbolName; + if (currentPackage.findInternalSymbol(name) == this) + return symbolName; + // Package prefix is necessary. + String packageName = ((Package)pkg).getName(); + final boolean escapePackageName = needsEscape(packageName, readtableCase, thread); + if (escapePackageName) + { + packageName = multipleEscape(packageName); + } + else + { + if (readtableCase == Keyword.UPCASE) + { + if (printCase == Keyword.DOWNCASE) + packageName = packageName.toLowerCase(); + else if (printCase == Keyword.CAPITALIZE) + packageName = capitalize(packageName, readtableCase); + } + else if (readtableCase == Keyword.DOWNCASE) + { + if (printCase == Keyword.UPCASE) + packageName = packageName.toUpperCase(); + else if (printCase == Keyword.CAPITALIZE) + packageName = capitalize(packageName, readtableCase); + } + else if (readtableCase == Keyword.INVERT) + { + packageName = invert(packageName); + } + } + FastStringBuffer sb = new FastStringBuffer(packageName); + if (((Package)pkg).findExternalSymbol(name) != null) + sb.append(':'); + else + sb.append("::"); + sb.append(symbolName); + return sb.toString(); + } + + private static final String invert(String s) + { + // "When the readtable case is :INVERT, the case of all alphabetic + // characters in single case symbol names is inverted. Mixed-case + // symbol names are printed as is." (22.1.3.3.2) + final int limit = s.length(); + final int LOWER = 1; + final int UPPER = 2; + int state = 0; + for (int i = 0; i < limit; i++) + { + char c = s.charAt(i); + if (Character.isUpperCase(c)) + { + if (state == LOWER) + return s; // Mixed case. + state = UPPER; + } + if (Character.isLowerCase(c)) + { + if (state == UPPER) + return s; // Mixed case. + state = LOWER; + } + } + FastStringBuffer sb = new FastStringBuffer(limit); + for (int i = 0; i < limit; i++) + { + char c = s.charAt(i); + if (Character.isUpperCase(c)) + sb.append(Character.toLowerCase(c)); + else if (Character.isLowerCase(c)) + sb.append(Character.toUpperCase(c)); + else + sb.append(c); + } + return sb.toString(); + } + + private static final boolean needsEscape(String s, + LispObject readtableCase, + LispThread thread) + throws ConditionThrowable + { + boolean escape = false; + final int length = s.length(); + if (length == 0) + return true; + if (s.charAt(0) == '#') + return true; + int radix; + try + { + radix = ((Fixnum)PRINT_BASE.symbolValue(thread)).value; + } + catch (ClassCastException e) + { + error(new TypeError("The value of *PRINT-BASE* is not of type (INTEGER 2 36).")); + // Not reached. + return false; + } + if (radix < 2 || radix > 36) + { + error(new TypeError("The value of *PRINT-BASE* is not of type (INTEGER 2 36).")); + // Not reached. + return false; + } + boolean seenNonDigit = false; + for (int i = length; i-- > 0;) + { + char c = s.charAt(i); + if ("(),|\\`'\";:".indexOf(c) >= 0) + return true; + if (Character.isWhitespace(c)) + return true; + if (readtableCase == Keyword.UPCASE) + { + if (Character.isLowerCase(c)) + return true; + } + else if (readtableCase == Keyword.DOWNCASE) + { + if (Character.isUpperCase(c)) + return true; + } + if (!escape && !seenNonDigit) + { + if (Character.digit(c, radix) < 0) + seenNonDigit = true; + } + } + if (!seenNonDigit) + return true; + if (s.charAt(0) == '.') + { + boolean allDots = true; + for (int i = length; i-- > 1;) + { + if (s.charAt(i) != '.') + { + allDots = false; + break; + } + } + if (allDots) + return true; + } + return false; + } + + private static final String multipleEscape(String s) + { + FastStringBuffer sb = new FastStringBuffer("|"); + final int limit = s.length(); + for (int i = 0; i < limit; i++) + { + char c = s.charAt(i); + if (c == '|' || c == '\\') + sb.append('\\'); + sb.append(c); + } + sb.append('|'); + return sb.toString(); + } + + private static final String capitalize(String s, LispObject readtableCase) + { + if (readtableCase == Keyword.INVERT || readtableCase == Keyword.PRESERVE) + return s; + final int limit = s.length(); + FastStringBuffer sb = new FastStringBuffer(limit); + boolean lastCharWasAlphanumeric = false; + for (int i = 0; i < limit; i++) + { + char c = s.charAt(i); + if (Character.isLowerCase(c)) + { + if (readtableCase == Keyword.UPCASE) + sb.append(c); + else // DOWNCASE + sb.append(lastCharWasAlphanumeric ? c : LispCharacter.toUpperCase(c)); + lastCharWasAlphanumeric = true; + } + else if (Character.isUpperCase(c)) + { + if (readtableCase == Keyword.UPCASE) + sb.append(lastCharWasAlphanumeric ? LispCharacter.toLowerCase(c) : c); + else // DOWNCASE + sb.append(c); + lastCharWasAlphanumeric = true; + } + else + { + sb.append(c); + lastCharWasAlphanumeric = Character.isDigit(c); + } + } + return sb.toString(); + } + + @Override + public final int sxhash() + { + int h = hash; + if (h < 0) + { + h = name.sxhash(); + hash = h; + } + return h; + } + + @Override + public LispObject execute() throws ConditionThrowable + { + try + { + return function.execute(); + } + catch (NullPointerException e) + { + return handleNPE(e, NIL); + } + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try + { + return function.execute(arg); + } + catch (NullPointerException e) + { + return handleNPE(e, list1(arg)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try + { + return function.execute(first, second); + } + catch (NullPointerException e) + { + return handleNPE(e, list2(first, second)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + try + { + return function.execute(first, second, third); + } + catch (NullPointerException e) + { + return handleNPE(e, list3(first, second, third)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + throws ConditionThrowable + { + try + { + return function.execute(first, second, third, fourth); + } + catch (NullPointerException e) + { + return handleNPE(e, list4(first, second, third, fourth)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + throws ConditionThrowable + { + try + { + return function.execute(first, second, third, fourth, fifth); + } + catch (NullPointerException e) + { + return handleNPE(e, list5(first, second, third, fourth, fifth)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + throws ConditionThrowable + { + try + { + return function.execute(first, second, third, fourth, fifth, sixth); + } + catch (NullPointerException e) + { + return handleNPE(e, list6(first, second, third, fourth, fifth, + sixth)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + throws ConditionThrowable + { + try + { + return function.execute(first, second, third, fourth, fifth, sixth, + seventh); + } + catch (NullPointerException e) + { + return handleNPE(e, + list7(first, second, third, fourth, fifth, sixth, + seventh)); + } + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + throws ConditionThrowable + { + try + { + return function.execute(first, second, third, fourth, fifth, sixth, + seventh, eighth); + } + catch (NullPointerException e) + { + return handleNPE(e, + list8(first, second, third, fourth, fifth, sixth, + seventh, eighth)); + } + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + try + { + return function.execute(args); + } + catch (NullPointerException e) + { + LispObject list = NIL; + for (int i = args.length; i-- > 0;) + list = new Cons(args[i], list); + return handleNPE(e, list); + } + } + + private final LispObject handleNPE(NullPointerException e, LispObject args) + throws ConditionThrowable + { + if (function == null) + return LispThread.currentThread().execute(Symbol.UNDEFINED_FUNCTION_CALLED, + this, args); + Debug.trace(e); + return error(new LispError("Null pointer exception")); + } + + @Override + public void incrementCallCount() + { + if (function != null) + function.incrementCallCount(); + } + + private void readObject(java.io.ObjectInputStream stream) throws java.io.IOException, ClassNotFoundException { + stream.defaultReadObject(); + Object pkg = stream.readObject(); + if(pkg == NIL) { + this.pkg = NIL; + } else { + this.pkg = Packages.findPackage(pkg.toString()); + } + } + + public Object readResolve() throws java.io.ObjectStreamException { + if(pkg instanceof Package) { + Symbol s = ((Package) pkg).intern(name.getStringValue()); + s.value = value; + s.function = function; + s.propertyList = propertyList; + s.hash = hash; + s.flags = flags; + return s; + } + return this; + } + + private void writeObject(java.io.ObjectOutputStream stream) throws java.io.IOException { + stream.defaultWriteObject(); + stream.writeObject(this.pkg == NIL ? NIL : ((Package) pkg).getName()); + } + + + // External symbols in CL package. + public static final Symbol AND_ALLOW_OTHER_KEYS = + PACKAGE_CL.addExternalSymbol("&ALLOW-OTHER-KEYS"); + public static final Symbol AND_AUX = + PACKAGE_CL.addExternalSymbol("&AUX"); + public static final Symbol AND_BODY = + PACKAGE_CL.addExternalSymbol("&BODY"); + public static final Symbol AND_ENVIRONMENT = + PACKAGE_CL.addExternalSymbol("&ENVIRONMENT"); + public static final Symbol AND_KEY = + PACKAGE_CL.addExternalSymbol("&KEY"); + public static final Symbol AND_OPTIONAL = + PACKAGE_CL.addExternalSymbol("&OPTIONAL"); + public static final Symbol AND_REST = + PACKAGE_CL.addExternalSymbol("&REST"); + public static final Symbol AND_WHOLE = + PACKAGE_CL.addExternalSymbol("&WHOLE"); + public static final Symbol STAR = + PACKAGE_CL.addExternalSymbol("*"); + public static final Symbol STAR_STAR = + PACKAGE_CL.addExternalSymbol("**"); + public static final Symbol STAR_STAR_STAR = + PACKAGE_CL.addExternalSymbol("***"); + public static final Symbol BREAK_ON_SIGNALS = + PACKAGE_CL.addExternalSymbol("*BREAK-ON-SIGNALS*"); + public static final Symbol _COMPILE_FILE_PATHNAME_ = + PACKAGE_CL.addExternalSymbol("*COMPILE-FILE-PATHNAME*"); + public static final Symbol COMPILE_FILE_TRUENAME = + PACKAGE_CL.addExternalSymbol("*COMPILE-FILE-TRUENAME*"); + public static final Symbol COMPILE_PRINT = + PACKAGE_CL.addExternalSymbol("*COMPILE-PRINT*"); + public static final Symbol COMPILE_VERBOSE = + PACKAGE_CL.addExternalSymbol("*COMPILE-VERBOSE*"); + public static final Symbol DEBUG_IO = + PACKAGE_CL.addExternalSymbol("*DEBUG-IO*"); + public static final Symbol DEBUGGER_HOOK = + PACKAGE_CL.addExternalSymbol("*DEBUGGER-HOOK*"); + public static final Symbol DEFAULT_PATHNAME_DEFAULTS = + PACKAGE_CL.addExternalSymbol("*DEFAULT-PATHNAME-DEFAULTS*"); + public static final Symbol ERROR_OUTPUT = + PACKAGE_CL.addExternalSymbol("*ERROR-OUTPUT*"); + public static final Symbol FEATURES = + PACKAGE_CL.addExternalSymbol("*FEATURES*"); + public static final Symbol GENSYM_COUNTER = + PACKAGE_CL.addExternalSymbol("*GENSYM-COUNTER*"); + public static final Symbol LOAD_PATHNAME = + PACKAGE_CL.addExternalSymbol("*LOAD-PATHNAME*"); + public static final Symbol LOAD_PRINT = + PACKAGE_CL.addExternalSymbol("*LOAD-PRINT*"); + public static final Symbol LOAD_TRUENAME = + PACKAGE_CL.addExternalSymbol("*LOAD-TRUENAME*"); + public static final Symbol LOAD_VERBOSE = + PACKAGE_CL.addExternalSymbol("*LOAD-VERBOSE*"); + public static final Symbol MACROEXPAND_HOOK = + PACKAGE_CL.addExternalSymbol("*MACROEXPAND-HOOK*"); + public static final Symbol MODULES = + PACKAGE_CL.addExternalSymbol("*MODULES*"); + public static final Symbol _PACKAGE_ = + PACKAGE_CL.addExternalSymbol("*PACKAGE*"); + public static final Symbol PRINT_ARRAY = + PACKAGE_CL.addExternalSymbol("*PRINT-ARRAY*"); + public static final Symbol PRINT_BASE = + PACKAGE_CL.addExternalSymbol("*PRINT-BASE*"); + public static final Symbol PRINT_CASE = + PACKAGE_CL.addExternalSymbol("*PRINT-CASE*"); + public static final Symbol PRINT_CIRCLE = + PACKAGE_CL.addExternalSymbol("*PRINT-CIRCLE*"); + public static final Symbol PRINT_ESCAPE = + PACKAGE_CL.addExternalSymbol("*PRINT-ESCAPE*"); + public static final Symbol PRINT_GENSYM = + PACKAGE_CL.addExternalSymbol("*PRINT-GENSYM*"); + public static final Symbol PRINT_LENGTH = + PACKAGE_CL.addExternalSymbol("*PRINT-LENGTH*"); + public static final Symbol PRINT_LEVEL = + PACKAGE_CL.addExternalSymbol("*PRINT-LEVEL*"); + public static final Symbol PRINT_LINES = + PACKAGE_CL.addExternalSymbol("*PRINT-LINES*"); + public static final Symbol PRINT_MISER_WIDTH = + PACKAGE_CL.addExternalSymbol("*PRINT-MISER-WIDTH*"); + public static final Symbol PRINT_PPRINT_DISPATCH = + PACKAGE_CL.addExternalSymbol("*PRINT-PPRINT-DISPATCH*"); + public static final Symbol PRINT_PRETTY = + PACKAGE_CL.addExternalSymbol("*PRINT-PRETTY*"); + public static final Symbol PRINT_RADIX = + PACKAGE_CL.addExternalSymbol("*PRINT-RADIX*"); + public static final Symbol PRINT_READABLY = + PACKAGE_CL.addExternalSymbol("*PRINT-READABLY*"); + public static final Symbol PRINT_RIGHT_MARGIN = + PACKAGE_CL.addExternalSymbol("*PRINT-RIGHT-MARGIN*"); + public static final Symbol QUERY_IO = + PACKAGE_CL.addExternalSymbol("*QUERY-IO*"); + public static final Symbol _RANDOM_STATE_ = + PACKAGE_CL.addExternalSymbol("*RANDOM-STATE*"); + public static final Symbol READ_BASE = + PACKAGE_CL.addExternalSymbol("*READ-BASE*"); + public static final Symbol READ_DEFAULT_FLOAT_FORMAT = + PACKAGE_CL.addExternalSymbol("*READ-DEFAULT-FLOAT-FORMAT*"); + public static final Symbol READ_EVAL = + PACKAGE_CL.addExternalSymbol("*READ-EVAL*"); + public static final Symbol READ_SUPPRESS = + PACKAGE_CL.addExternalSymbol("*READ-SUPPRESS*"); + public static final Symbol CURRENT_READTABLE = + PACKAGE_CL.addExternalSymbol("*READTABLE*"); + public static final Symbol STANDARD_INPUT = + PACKAGE_CL.addExternalSymbol("*STANDARD-INPUT*"); + public static final Symbol STANDARD_OUTPUT = + PACKAGE_CL.addExternalSymbol("*STANDARD-OUTPUT*"); + public static final Symbol TERMINAL_IO = + PACKAGE_CL.addExternalSymbol("*TERMINAL-IO*"); + public static final Symbol TRACE_OUTPUT = + PACKAGE_CL.addExternalSymbol("*TRACE-OUTPUT*"); + public static final Symbol PLUS = + PACKAGE_CL.addExternalSymbol("+"); + public static final Symbol PLUS_PLUS = + PACKAGE_CL.addExternalSymbol("++"); + public static final Symbol PLUS_PLUS_PLUS = + PACKAGE_CL.addExternalSymbol("+++"); + public static final Symbol MINUS = + PACKAGE_CL.addExternalSymbol("-"); + public static final Symbol SLASH = + PACKAGE_CL.addExternalSymbol("/"); + public static final Symbol SLASH_SLASH = + PACKAGE_CL.addExternalSymbol("//"); + public static final Symbol SLASH_SLASH_SLASH = + PACKAGE_CL.addExternalSymbol("///"); + public static final Symbol NOT_EQUALS = + PACKAGE_CL.addExternalSymbol("/="); + public static final Symbol ONE_PLUS = + PACKAGE_CL.addExternalSymbol("1+"); + public static final Symbol ONE_MINUS = + PACKAGE_CL.addExternalSymbol("1-"); + public static final Symbol LT = + PACKAGE_CL.addExternalSymbol("<"); + public static final Symbol LE = + PACKAGE_CL.addExternalSymbol("<="); + public static final Symbol EQUALS = + PACKAGE_CL.addExternalSymbol("="); + public static final Symbol GT = + PACKAGE_CL.addExternalSymbol(">"); + public static final Symbol GE = + PACKAGE_CL.addExternalSymbol(">="); + public static final Symbol ABORT = + PACKAGE_CL.addExternalSymbol("ABORT"); + public static final Symbol ABS = + PACKAGE_CL.addExternalSymbol("ABS"); + public static final Symbol ACONS = + PACKAGE_CL.addExternalSymbol("ACONS"); + public static final Symbol ACOS = + PACKAGE_CL.addExternalSymbol("ACOS"); + public static final Symbol ACOSH = + PACKAGE_CL.addExternalSymbol("ACOSH"); + public static final Symbol ADD_METHOD = + PACKAGE_CL.addExternalSymbol("ADD-METHOD"); + public static final Symbol ADJOIN = + PACKAGE_CL.addExternalSymbol("ADJOIN"); + public static final Symbol ADJUST_ARRAY = + PACKAGE_CL.addExternalSymbol("ADJUST-ARRAY"); + public static final Symbol ADJUSTABLE_ARRAY_P = + PACKAGE_CL.addExternalSymbol("ADJUSTABLE-ARRAY-P"); + public static final Symbol ALLOCATE_INSTANCE = + PACKAGE_CL.addExternalSymbol("ALLOCATE-INSTANCE"); + public static final Symbol ALPHA_CHAR_P = + PACKAGE_CL.addExternalSymbol("ALPHA-CHAR-P"); + public static final Symbol ALPHANUMERICP = + PACKAGE_CL.addExternalSymbol("ALPHANUMERICP"); + public static final Symbol AND = + PACKAGE_CL.addExternalSymbol("AND"); + public static final Symbol APPEND = + PACKAGE_CL.addExternalSymbol("APPEND"); + public static final Symbol APPLY = + PACKAGE_CL.addExternalSymbol("APPLY"); + public static final Symbol APROPOS = + PACKAGE_CL.addExternalSymbol("APROPOS"); + public static final Symbol APROPOS_LIST = + PACKAGE_CL.addExternalSymbol("APROPOS-LIST"); + public static final Symbol AREF = + PACKAGE_CL.addExternalSymbol("AREF"); + public static final Symbol ARITHMETIC_ERROR = + PACKAGE_CL.addExternalSymbol("ARITHMETIC-ERROR"); + public static final Symbol ARITHMETIC_ERROR_OPERANDS = + PACKAGE_CL.addExternalSymbol("ARITHMETIC-ERROR-OPERANDS"); + public static final Symbol ARITHMETIC_ERROR_OPERATION = + PACKAGE_CL.addExternalSymbol("ARITHMETIC-ERROR-OPERATION"); + public static final Symbol ARRAY = + PACKAGE_CL.addExternalSymbol("ARRAY"); + public static final Symbol ARRAY_DIMENSION = + PACKAGE_CL.addExternalSymbol("ARRAY-DIMENSION"); + public static final Symbol ARRAY_DIMENSION_LIMIT = + PACKAGE_CL.addExternalSymbol("ARRAY-DIMENSION-LIMIT"); + public static final Symbol ARRAY_DIMENSIONS = + PACKAGE_CL.addExternalSymbol("ARRAY-DIMENSIONS"); + public static final Symbol ARRAY_DISPLACEMENT = + PACKAGE_CL.addExternalSymbol("ARRAY-DISPLACEMENT"); + public static final Symbol ARRAY_ELEMENT_TYPE = + PACKAGE_CL.addExternalSymbol("ARRAY-ELEMENT-TYPE"); + public static final Symbol ARRAY_HAS_FILL_POINTER_P = + PACKAGE_CL.addExternalSymbol("ARRAY-HAS-FILL-POINTER-P"); + public static final Symbol ARRAY_IN_BOUNDS_P = + PACKAGE_CL.addExternalSymbol("ARRAY-IN-BOUNDS-P"); + public static final Symbol ARRAY_RANK = + PACKAGE_CL.addExternalSymbol("ARRAY-RANK"); + public static final Symbol ARRAY_RANK_LIMIT = + PACKAGE_CL.addExternalSymbol("ARRAY-RANK-LIMIT"); + public static final Symbol ARRAY_ROW_MAJOR_INDEX = + PACKAGE_CL.addExternalSymbol("ARRAY-ROW-MAJOR-INDEX"); + public static final Symbol ARRAY_TOTAL_SIZE = + PACKAGE_CL.addExternalSymbol("ARRAY-TOTAL-SIZE"); + public static final Symbol ARRAY_TOTAL_SIZE_LIMIT = + PACKAGE_CL.addExternalSymbol("ARRAY-TOTAL-SIZE-LIMIT"); + public static final Symbol ARRAYP = + PACKAGE_CL.addExternalSymbol("ARRAYP"); + public static final Symbol ASH = + PACKAGE_CL.addExternalSymbol("ASH"); + public static final Symbol ASIN = + PACKAGE_CL.addExternalSymbol("ASIN"); + public static final Symbol ASINH = + PACKAGE_CL.addExternalSymbol("ASINH"); + public static final Symbol ASSERT = + PACKAGE_CL.addExternalSymbol("ASSERT"); + public static final Symbol ASSOC = + PACKAGE_CL.addExternalSymbol("ASSOC"); + public static final Symbol ASSOC_IF = + PACKAGE_CL.addExternalSymbol("ASSOC-IF"); + public static final Symbol ASSOC_IF_NOT = + PACKAGE_CL.addExternalSymbol("ASSOC-IF-NOT"); + public static final Symbol ATAN = + PACKAGE_CL.addExternalSymbol("ATAN"); + public static final Symbol ATANH = + PACKAGE_CL.addExternalSymbol("ATANH"); + public static final Symbol ATOM = + PACKAGE_CL.addExternalSymbol("ATOM"); + public static final Symbol BASE_CHAR = + PACKAGE_CL.addExternalSymbol("BASE-CHAR"); + public static final Symbol BASE_STRING = + PACKAGE_CL.addExternalSymbol("BASE-STRING"); + public static final Symbol BIGNUM = + PACKAGE_CL.addExternalSymbol("BIGNUM"); + public static final Symbol BIT = + PACKAGE_CL.addExternalSymbol("BIT"); + public static final Symbol BIT_AND = + PACKAGE_CL.addExternalSymbol("BIT-AND"); + public static final Symbol BIT_ANDC1 = + PACKAGE_CL.addExternalSymbol("BIT-ANDC1"); + public static final Symbol BIT_ANDC2 = + PACKAGE_CL.addExternalSymbol("BIT-ANDC2"); + public static final Symbol BIT_EQV = + PACKAGE_CL.addExternalSymbol("BIT-EQV"); + public static final Symbol BIT_IOR = + PACKAGE_CL.addExternalSymbol("BIT-IOR"); + public static final Symbol BIT_NAND = + PACKAGE_CL.addExternalSymbol("BIT-NAND"); + public static final Symbol BIT_NOR = + PACKAGE_CL.addExternalSymbol("BIT-NOR"); + public static final Symbol BIT_NOT = + PACKAGE_CL.addExternalSymbol("BIT-NOT"); + public static final Symbol BIT_ORC1 = + PACKAGE_CL.addExternalSymbol("BIT-ORC1"); + public static final Symbol BIT_ORC2 = + PACKAGE_CL.addExternalSymbol("BIT-ORC2"); + public static final Symbol BIT_VECTOR = + PACKAGE_CL.addExternalSymbol("BIT-VECTOR"); + public static final Symbol BIT_VECTOR_P = + PACKAGE_CL.addExternalSymbol("BIT-VECTOR-P"); + public static final Symbol BIT_XOR = + PACKAGE_CL.addExternalSymbol("BIT-XOR"); + public static final Symbol BLOCK = + PACKAGE_CL.addExternalSymbol("BLOCK"); + public static final Symbol BOOLE = + PACKAGE_CL.addExternalSymbol("BOOLE"); + public static final Symbol BOOLE_1 = + PACKAGE_CL.addExternalSymbol("BOOLE-1"); + public static final Symbol BOOLE_2 = + PACKAGE_CL.addExternalSymbol("BOOLE-2"); + public static final Symbol BOOLE_AND = + PACKAGE_CL.addExternalSymbol("BOOLE-AND"); + public static final Symbol BOOLE_ANDC1 = + PACKAGE_CL.addExternalSymbol("BOOLE-ANDC1"); + public static final Symbol BOOLE_ANDC2 = + PACKAGE_CL.addExternalSymbol("BOOLE-ANDC2"); + public static final Symbol BOOLE_C1 = + PACKAGE_CL.addExternalSymbol("BOOLE-C1"); + public static final Symbol BOOLE_C2 = + PACKAGE_CL.addExternalSymbol("BOOLE-C2"); + public static final Symbol BOOLE_CLR = + PACKAGE_CL.addExternalSymbol("BOOLE-CLR"); + public static final Symbol BOOLE_EQV = + PACKAGE_CL.addExternalSymbol("BOOLE-EQV"); + public static final Symbol BOOLE_IOR = + PACKAGE_CL.addExternalSymbol("BOOLE-IOR"); + public static final Symbol BOOLE_NAND = + PACKAGE_CL.addExternalSymbol("BOOLE-NAND"); + public static final Symbol BOOLE_NOR = + PACKAGE_CL.addExternalSymbol("BOOLE-NOR"); + public static final Symbol BOOLE_ORC1 = + PACKAGE_CL.addExternalSymbol("BOOLE-ORC1"); + public static final Symbol BOOLE_ORC2 = + PACKAGE_CL.addExternalSymbol("BOOLE-ORC2"); + public static final Symbol BOOLE_SET = + PACKAGE_CL.addExternalSymbol("BOOLE-SET"); + public static final Symbol BOOLE_XOR = + PACKAGE_CL.addExternalSymbol("BOOLE-XOR"); + public static final Symbol BOOLEAN = + PACKAGE_CL.addExternalSymbol("BOOLEAN"); + public static final Symbol BOTH_CASE_P = + PACKAGE_CL.addExternalSymbol("BOTH-CASE-P"); + public static final Symbol BOUNDP = + PACKAGE_CL.addExternalSymbol("BOUNDP"); + public static final Symbol BREAK = + PACKAGE_CL.addExternalSymbol("BREAK"); + public static final Symbol BROADCAST_STREAM = + PACKAGE_CL.addExternalSymbol("BROADCAST-STREAM"); + public static final Symbol BROADCAST_STREAM_STREAMS = + PACKAGE_CL.addExternalSymbol("BROADCAST-STREAM-STREAMS"); + public static final Symbol BUILT_IN_CLASS = + PACKAGE_CL.addExternalSymbol("BUILT-IN-CLASS"); + public static final Symbol BUTLAST = + PACKAGE_CL.addExternalSymbol("BUTLAST"); + public static final Symbol BYTE = + PACKAGE_CL.addExternalSymbol("BYTE"); + public static final Symbol BYTE_POSITION = + PACKAGE_CL.addExternalSymbol("BYTE-POSITION"); + public static final Symbol BYTE_SIZE = + PACKAGE_CL.addExternalSymbol("BYTE-SIZE"); + public static final Symbol CAAAAR = + PACKAGE_CL.addExternalSymbol("CAAAAR"); + public static final Symbol CAAADR = + PACKAGE_CL.addExternalSymbol("CAAADR"); + public static final Symbol CAAAR = + PACKAGE_CL.addExternalSymbol("CAAAR"); + public static final Symbol CAADAR = + PACKAGE_CL.addExternalSymbol("CAADAR"); + public static final Symbol CAADDR = + PACKAGE_CL.addExternalSymbol("CAADDR"); + public static final Symbol CAADR = + PACKAGE_CL.addExternalSymbol("CAADR"); + public static final Symbol CAAR = + PACKAGE_CL.addExternalSymbol("CAAR"); + public static final Symbol CADAAR = + PACKAGE_CL.addExternalSymbol("CADAAR"); + public static final Symbol CADADR = + PACKAGE_CL.addExternalSymbol("CADADR"); + public static final Symbol CADAR = + PACKAGE_CL.addExternalSymbol("CADAR"); + public static final Symbol CADDAR = + PACKAGE_CL.addExternalSymbol("CADDAR"); + public static final Symbol CADDDR = + PACKAGE_CL.addExternalSymbol("CADDDR"); + public static final Symbol CADDR = + PACKAGE_CL.addExternalSymbol("CADDR"); + public static final Symbol CADR = + PACKAGE_CL.addExternalSymbol("CADR"); + public static final Symbol CALL_ARGUMENTS_LIMIT = + PACKAGE_CL.addExternalSymbol("CALL-ARGUMENTS-LIMIT"); + public static final Symbol CALL_METHOD = + PACKAGE_CL.addExternalSymbol("CALL-METHOD"); + public static final Symbol CALL_NEXT_METHOD = + PACKAGE_CL.addExternalSymbol("CALL-NEXT-METHOD"); + public static final Symbol CAR = + PACKAGE_CL.addExternalSymbol("CAR"); + public static final Symbol CASE = + PACKAGE_CL.addExternalSymbol("CASE"); + public static final Symbol CATCH = + PACKAGE_CL.addExternalSymbol("CATCH"); + public static final Symbol CCASE = + PACKAGE_CL.addExternalSymbol("CCASE"); + public static final Symbol CDAAAR = + PACKAGE_CL.addExternalSymbol("CDAAAR"); + public static final Symbol CDAADR = + PACKAGE_CL.addExternalSymbol("CDAADR"); + public static final Symbol CDAAR = + PACKAGE_CL.addExternalSymbol("CDAAR"); + public static final Symbol CDADAR = + PACKAGE_CL.addExternalSymbol("CDADAR"); + public static final Symbol CDADDR = + PACKAGE_CL.addExternalSymbol("CDADDR"); + public static final Symbol CDADR = + PACKAGE_CL.addExternalSymbol("CDADR"); + public static final Symbol CDAR = + PACKAGE_CL.addExternalSymbol("CDAR"); + public static final Symbol CDDAAR = + PACKAGE_CL.addExternalSymbol("CDDAAR"); + public static final Symbol CDDADR = + PACKAGE_CL.addExternalSymbol("CDDADR"); + public static final Symbol CDDAR = + PACKAGE_CL.addExternalSymbol("CDDAR"); + public static final Symbol CDDDAR = + PACKAGE_CL.addExternalSymbol("CDDDAR"); + public static final Symbol CDDDDR = + PACKAGE_CL.addExternalSymbol("CDDDDR"); + public static final Symbol CDDDR = + PACKAGE_CL.addExternalSymbol("CDDDR"); + public static final Symbol CDDR = + PACKAGE_CL.addExternalSymbol("CDDR"); + public static final Symbol CDR = + PACKAGE_CL.addExternalSymbol("CDR"); + public static final Symbol CEILING = + PACKAGE_CL.addExternalSymbol("CEILING"); + public static final Symbol CELL_ERROR = + PACKAGE_CL.addExternalSymbol("CELL-ERROR"); + public static final Symbol CELL_ERROR_NAME = + PACKAGE_CL.addExternalSymbol("CELL-ERROR-NAME"); + public static final Symbol CERROR = + PACKAGE_CL.addExternalSymbol("CERROR"); + public static final Symbol CHANGE_CLASS = + PACKAGE_CL.addExternalSymbol("CHANGE-CLASS"); + public static final Symbol CHAR = + PACKAGE_CL.addExternalSymbol("CHAR"); + public static final Symbol CHAR_CODE = + PACKAGE_CL.addExternalSymbol("CHAR-CODE"); + public static final Symbol CHAR_CODE_LIMIT = + PACKAGE_CL.addExternalSymbol("CHAR-CODE-LIMIT"); + public static final Symbol CHAR_DOWNCASE = + PACKAGE_CL.addExternalSymbol("CHAR-DOWNCASE"); + public static final Symbol CHAR_EQUAL = + PACKAGE_CL.addExternalSymbol("CHAR-EQUAL"); + public static final Symbol CHAR_GREATERP = + PACKAGE_CL.addExternalSymbol("CHAR-GREATERP"); + public static final Symbol CHAR_INT = + PACKAGE_CL.addExternalSymbol("CHAR-INT"); + public static final Symbol CHAR_LESSP = + PACKAGE_CL.addExternalSymbol("CHAR-LESSP"); + public static final Symbol CHAR_NAME = + PACKAGE_CL.addExternalSymbol("CHAR-NAME"); + public static final Symbol CHAR_NOT_EQUAL = + PACKAGE_CL.addExternalSymbol("CHAR-NOT-EQUAL"); + public static final Symbol CHAR_NOT_GREATERP = + PACKAGE_CL.addExternalSymbol("CHAR-NOT-GREATERP"); + public static final Symbol CHAR_NOT_LESSP = + PACKAGE_CL.addExternalSymbol("CHAR-NOT-LESSP"); + public static final Symbol CHAR_UPCASE = + PACKAGE_CL.addExternalSymbol("CHAR-UPCASE"); + public static final Symbol CHAR_NE = + PACKAGE_CL.addExternalSymbol("CHAR/="); + public static final Symbol CHAR_LT = + PACKAGE_CL.addExternalSymbol("CHAR<"); + public static final Symbol CHAR_LE = + PACKAGE_CL.addExternalSymbol("CHAR<="); + public static final Symbol CHAR_EQUALS = + PACKAGE_CL.addExternalSymbol("CHAR="); + public static final Symbol CHAR_GT = + PACKAGE_CL.addExternalSymbol("CHAR>"); + public static final Symbol CHAR_GE = + PACKAGE_CL.addExternalSymbol("CHAR>="); + public static final Symbol CHARACTER = + PACKAGE_CL.addExternalSymbol("CHARACTER"); + public static final Symbol CHARACTERP = + PACKAGE_CL.addExternalSymbol("CHARACTERP"); + public static final Symbol CHECK_TYPE = + PACKAGE_CL.addExternalSymbol("CHECK-TYPE"); + public static final Symbol CIS = + PACKAGE_CL.addExternalSymbol("CIS"); + public static final Symbol CLASS = + PACKAGE_CL.addExternalSymbol("CLASS"); + public static final Symbol CLASS_NAME = + PACKAGE_CL.addExternalSymbol("CLASS-NAME"); + public static final Symbol CLASS_OF = + PACKAGE_CL.addExternalSymbol("CLASS-OF"); + public static final Symbol CLEAR_INPUT = + PACKAGE_CL.addExternalSymbol("CLEAR-INPUT"); + public static final Symbol CLEAR_OUTPUT = + PACKAGE_CL.addExternalSymbol("CLEAR-OUTPUT"); + public static final Symbol CLOSE = + PACKAGE_CL.addExternalSymbol("CLOSE"); + public static final Symbol CLRHASH = + PACKAGE_CL.addExternalSymbol("CLRHASH"); + public static final Symbol CODE_CHAR = + PACKAGE_CL.addExternalSymbol("CODE-CHAR"); + public static final Symbol COERCE = + PACKAGE_CL.addExternalSymbol("COERCE"); + public static final Symbol COMPILATION_SPEED = + PACKAGE_CL.addExternalSymbol("COMPILATION-SPEED"); + public static final Symbol COMPILE = + PACKAGE_CL.addExternalSymbol("COMPILE"); + public static final Symbol COMPILE_FILE = + PACKAGE_CL.addExternalSymbol("COMPILE-FILE"); + public static final Symbol COMPILE_FILE_PATHNAME = + PACKAGE_CL.addExternalSymbol("COMPILE-FILE-PATHNAME"); + public static final Symbol COMPILED_FUNCTION = + PACKAGE_CL.addExternalSymbol("COMPILED-FUNCTION"); + public static final Symbol COMPILED_FUNCTION_P = + PACKAGE_CL.addExternalSymbol("COMPILED-FUNCTION-P"); + public static final Symbol COMPILER_MACRO = + PACKAGE_CL.addExternalSymbol("COMPILER-MACRO"); + public static final Symbol COMPILER_MACRO_FUNCTION = + PACKAGE_CL.addExternalSymbol("COMPILER-MACRO-FUNCTION"); + public static final Symbol COMPLEMENT = + PACKAGE_CL.addExternalSymbol("COMPLEMENT"); + public static final Symbol COMPLEX = + PACKAGE_CL.addExternalSymbol("COMPLEX"); + public static final Symbol COMPLEXP = + PACKAGE_CL.addExternalSymbol("COMPLEXP"); + public static final Symbol COMPUTE_APPLICABLE_METHODS = + PACKAGE_CL.addExternalSymbol("COMPUTE-APPLICABLE-METHODS"); + public static final Symbol COMPUTE_RESTARTS = + PACKAGE_CL.addExternalSymbol("COMPUTE-RESTARTS"); + public static final Symbol CONCATENATE = + PACKAGE_CL.addExternalSymbol("CONCATENATE"); + public static final Symbol CONCATENATED_STREAM = + PACKAGE_CL.addExternalSymbol("CONCATENATED-STREAM"); + public static final Symbol CONCATENATED_STREAM_STREAMS = + PACKAGE_CL.addExternalSymbol("CONCATENATED-STREAM-STREAMS"); + public static final Symbol COND = + PACKAGE_CL.addExternalSymbol("COND"); + public static final Symbol CONDITION = + PACKAGE_CL.addExternalSymbol("CONDITION"); + public static final Symbol CONJUGATE = + PACKAGE_CL.addExternalSymbol("CONJUGATE"); + public static final Symbol CONS = + PACKAGE_CL.addExternalSymbol("CONS"); + public static final Symbol CONSP = + PACKAGE_CL.addExternalSymbol("CONSP"); + public static final Symbol CONSTANTLY = + PACKAGE_CL.addExternalSymbol("CONSTANTLY"); + public static final Symbol CONSTANTP = + PACKAGE_CL.addExternalSymbol("CONSTANTP"); + public static final Symbol CONTINUE = + PACKAGE_CL.addExternalSymbol("CONTINUE"); + public static final Symbol CONTROL_ERROR = + PACKAGE_CL.addExternalSymbol("CONTROL-ERROR"); + public static final Symbol COPY_ALIST = + PACKAGE_CL.addExternalSymbol("COPY-ALIST"); + public static final Symbol COPY_LIST = + PACKAGE_CL.addExternalSymbol("COPY-LIST"); + public static final Symbol COPY_PPRINT_DISPATCH = + PACKAGE_CL.addExternalSymbol("COPY-PPRINT-DISPATCH"); + public static final Symbol COPY_READTABLE = + PACKAGE_CL.addExternalSymbol("COPY-READTABLE"); + public static final Symbol COPY_SEQ = + PACKAGE_CL.addExternalSymbol("COPY-SEQ"); + public static final Symbol COPY_STRUCTURE = + PACKAGE_CL.addExternalSymbol("COPY-STRUCTURE"); + public static final Symbol COPY_SYMBOL = + PACKAGE_CL.addExternalSymbol("COPY-SYMBOL"); + public static final Symbol COPY_TREE = + PACKAGE_CL.addExternalSymbol("COPY-TREE"); + public static final Symbol COS = + PACKAGE_CL.addExternalSymbol("COS"); + public static final Symbol COSH = + PACKAGE_CL.addExternalSymbol("COSH"); + public static final Symbol COUNT = + PACKAGE_CL.addExternalSymbol("COUNT"); + public static final Symbol COUNT_IF = + PACKAGE_CL.addExternalSymbol("COUNT-IF"); + public static final Symbol COUNT_IF_NOT = + PACKAGE_CL.addExternalSymbol("COUNT-IF-NOT"); + public static final Symbol CTYPECASE = + PACKAGE_CL.addExternalSymbol("CTYPECASE"); + public static final Symbol DEBUG = + PACKAGE_CL.addExternalSymbol("DEBUG"); + public static final Symbol DECF = + PACKAGE_CL.addExternalSymbol("DECF"); + public static final Symbol DECLAIM = + PACKAGE_CL.addExternalSymbol("DECLAIM"); + public static final Symbol DECLARATION = + PACKAGE_CL.addExternalSymbol("DECLARATION"); + public static final Symbol DECLARE = + PACKAGE_CL.addExternalSymbol("DECLARE"); + public static final Symbol DECODE_FLOAT = + PACKAGE_CL.addExternalSymbol("DECODE-FLOAT"); + public static final Symbol DECODE_UNIVERSAL_TIME = + PACKAGE_CL.addExternalSymbol("DECODE-UNIVERSAL-TIME"); + public static final Symbol DEFCLASS = + PACKAGE_CL.addExternalSymbol("DEFCLASS"); + public static final Symbol DEFCONSTANT = + PACKAGE_CL.addExternalSymbol("DEFCONSTANT"); + public static final Symbol DEFGENERIC = + PACKAGE_CL.addExternalSymbol("DEFGENERIC"); + public static final Symbol DEFINE_COMPILER_MACRO = + PACKAGE_CL.addExternalSymbol("DEFINE-COMPILER-MACRO"); + public static final Symbol DEFINE_CONDITION = + PACKAGE_CL.addExternalSymbol("DEFINE-CONDITION"); + public static final Symbol DEFINE_METHOD_COMBINATION = + PACKAGE_CL.addExternalSymbol("DEFINE-METHOD-COMBINATION"); + public static final Symbol DEFINE_MODIFY_MACRO = + PACKAGE_CL.addExternalSymbol("DEFINE-MODIFY-MACRO"); + public static final Symbol DEFINE_SETF_EXPANDER = + PACKAGE_CL.addExternalSymbol("DEFINE-SETF-EXPANDER"); + public static final Symbol DEFINE_SYMBOL_MACRO = + PACKAGE_CL.addExternalSymbol("DEFINE-SYMBOL-MACRO"); + public static final Symbol DEFMACRO = + PACKAGE_CL.addExternalSymbol("DEFMACRO"); + public static final Symbol DEFMETHOD = + PACKAGE_CL.addExternalSymbol("DEFMETHOD"); + public static final Symbol DEFPACKAGE = + PACKAGE_CL.addExternalSymbol("DEFPACKAGE"); + public static final Symbol DEFPARAMETER = + PACKAGE_CL.addExternalSymbol("DEFPARAMETER"); + public static final Symbol DEFSETF = + PACKAGE_CL.addExternalSymbol("DEFSETF"); + public static final Symbol DEFSTRUCT = + PACKAGE_CL.addExternalSymbol("DEFSTRUCT"); + public static final Symbol DEFTYPE = + PACKAGE_CL.addExternalSymbol("DEFTYPE"); + public static final Symbol DEFUN = + PACKAGE_CL.addExternalSymbol("DEFUN"); + public static final Symbol DEFVAR = + PACKAGE_CL.addExternalSymbol("DEFVAR"); + public static final Symbol DELETE = + PACKAGE_CL.addExternalSymbol("DELETE"); + public static final Symbol DELETE_DUPLICATES = + PACKAGE_CL.addExternalSymbol("DELETE-DUPLICATES"); + public static final Symbol DELETE_FILE = + PACKAGE_CL.addExternalSymbol("DELETE-FILE"); + public static final Symbol DELETE_IF = + PACKAGE_CL.addExternalSymbol("DELETE-IF"); + public static final Symbol DELETE_IF_NOT = + PACKAGE_CL.addExternalSymbol("DELETE-IF-NOT"); + public static final Symbol DELETE_PACKAGE = + PACKAGE_CL.addExternalSymbol("DELETE-PACKAGE"); + public static final Symbol DENOMINATOR = + PACKAGE_CL.addExternalSymbol("DENOMINATOR"); + public static final Symbol DEPOSIT_FIELD = + PACKAGE_CL.addExternalSymbol("DEPOSIT-FIELD"); + public static final Symbol DESCRIBE = + PACKAGE_CL.addExternalSymbol("DESCRIBE"); + public static final Symbol DESCRIBE_OBJECT = + PACKAGE_CL.addExternalSymbol("DESCRIBE-OBJECT"); + public static final Symbol DESTRUCTURING_BIND = + PACKAGE_CL.addExternalSymbol("DESTRUCTURING-BIND"); + public static final Symbol DIGIT_CHAR = + PACKAGE_CL.addExternalSymbol("DIGIT-CHAR"); + public static final Symbol DIGIT_CHAR_P = + PACKAGE_CL.addExternalSymbol("DIGIT-CHAR-P"); + public static final Symbol DIRECTORY = + PACKAGE_CL.addExternalSymbol("DIRECTORY"); + public static final Symbol DIRECTORY_NAMESTRING = + PACKAGE_CL.addExternalSymbol("DIRECTORY-NAMESTRING"); + public static final Symbol DISASSEMBLE = + PACKAGE_CL.addExternalSymbol("DISASSEMBLE"); + public static final Symbol DIVISION_BY_ZERO = + PACKAGE_CL.addExternalSymbol("DIVISION-BY-ZERO"); + public static final Symbol DO = + PACKAGE_CL.addExternalSymbol("DO"); + public static final Symbol DO_STAR = + PACKAGE_CL.addExternalSymbol("DO*"); + public static final Symbol DO_ALL_SYMBOLS = + PACKAGE_CL.addExternalSymbol("DO-ALL-SYMBOLS"); + public static final Symbol DO_EXTERNAL_SYMBOLS = + PACKAGE_CL.addExternalSymbol("DO-EXTERNAL-SYMBOLS"); + public static final Symbol DO_SYMBOLS = + PACKAGE_CL.addExternalSymbol("DO-SYMBOLS"); + public static final Symbol DOCUMENTATION = + PACKAGE_CL.addExternalSymbol("DOCUMENTATION"); + public static final Symbol DOLIST = + PACKAGE_CL.addExternalSymbol("DOLIST"); + public static final Symbol DOTIMES = + PACKAGE_CL.addExternalSymbol("DOTIMES"); + public static final Symbol DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("DOUBLE-FLOAT"); + public static final Symbol DOUBLE_FLOAT_EPSILON = + PACKAGE_CL.addExternalSymbol("DOUBLE-FLOAT-EPSILON"); + public static final Symbol DOUBLE_FLOAT_NEGATIVE_EPSILON = + PACKAGE_CL.addExternalSymbol("DOUBLE-FLOAT-NEGATIVE-EPSILON"); + public static final Symbol DPB = + PACKAGE_CL.addExternalSymbol("DPB"); + public static final Symbol DRIBBLE = + PACKAGE_CL.addExternalSymbol("DRIBBLE"); + public static final Symbol DYNAMIC_EXTENT = + PACKAGE_CL.addExternalSymbol("DYNAMIC-EXTENT"); + public static final Symbol ECASE = + PACKAGE_CL.addExternalSymbol("ECASE"); + public static final Symbol ECHO_STREAM = + PACKAGE_CL.addExternalSymbol("ECHO-STREAM"); + public static final Symbol ECHO_STREAM_INPUT_STREAM = + PACKAGE_CL.addExternalSymbol("ECHO-STREAM-INPUT-STREAM"); + public static final Symbol ECHO_STREAM_OUTPUT_STREAM = + PACKAGE_CL.addExternalSymbol("ECHO-STREAM-OUTPUT-STREAM"); + public static final Symbol ED = + PACKAGE_CL.addExternalSymbol("ED"); + public static final Symbol EIGHTH = + PACKAGE_CL.addExternalSymbol("EIGHTH"); + public static final Symbol ELT = + PACKAGE_CL.addExternalSymbol("ELT"); + public static final Symbol ENCODE_UNIVERSAL_TIME = + PACKAGE_CL.addExternalSymbol("ENCODE-UNIVERSAL-TIME"); + public static final Symbol END_OF_FILE = + PACKAGE_CL.addExternalSymbol("END-OF-FILE"); + public static final Symbol ENDP = + PACKAGE_CL.addExternalSymbol("ENDP"); + public static final Symbol ENOUGH_NAMESTRING = + PACKAGE_CL.addExternalSymbol("ENOUGH-NAMESTRING"); + public static final Symbol ENSURE_DIRECTORIES_EXIST = + PACKAGE_CL.addExternalSymbol("ENSURE-DIRECTORIES-EXIST"); + public static final Symbol ENSURE_GENERIC_FUNCTION = + PACKAGE_CL.addExternalSymbol("ENSURE-GENERIC-FUNCTION"); + public static final Symbol EQ = + PACKAGE_CL.addExternalSymbol("EQ"); + public static final Symbol EQL = + PACKAGE_CL.addExternalSymbol("EQL"); + public static final Symbol EQUAL = + PACKAGE_CL.addExternalSymbol("EQUAL"); + public static final Symbol EQUALP = + PACKAGE_CL.addExternalSymbol("EQUALP"); + public static final Symbol ERROR = + PACKAGE_CL.addExternalSymbol("ERROR"); + public static final Symbol ETYPECASE = + PACKAGE_CL.addExternalSymbol("ETYPECASE"); + public static final Symbol EVAL = + PACKAGE_CL.addExternalSymbol("EVAL"); + public static final Symbol EVAL_WHEN = + PACKAGE_CL.addExternalSymbol("EVAL-WHEN"); + public static final Symbol EVENP = + PACKAGE_CL.addExternalSymbol("EVENP"); + public static final Symbol EVERY = + PACKAGE_CL.addExternalSymbol("EVERY"); + public static final Symbol EXP = + PACKAGE_CL.addExternalSymbol("EXP"); + public static final Symbol EXPORT = + PACKAGE_CL.addExternalSymbol("EXPORT"); + public static final Symbol EXPT = + PACKAGE_CL.addExternalSymbol("EXPT"); + public static final Symbol EXTENDED_CHAR = + PACKAGE_CL.addExternalSymbol("EXTENDED-CHAR"); + public static final Symbol FBOUNDP = + PACKAGE_CL.addExternalSymbol("FBOUNDP"); + public static final Symbol FCEILING = + PACKAGE_CL.addExternalSymbol("FCEILING"); + public static final Symbol FDEFINITION = + PACKAGE_CL.addExternalSymbol("FDEFINITION"); + public static final Symbol FFLOOR = + PACKAGE_CL.addExternalSymbol("FFLOOR"); + public static final Symbol FIFTH = + PACKAGE_CL.addExternalSymbol("FIFTH"); + public static final Symbol FILE_AUTHOR = + PACKAGE_CL.addExternalSymbol("FILE-AUTHOR"); + public static final Symbol FILE_ERROR = + PACKAGE_CL.addExternalSymbol("FILE-ERROR"); + public static final Symbol FILE_ERROR_PATHNAME = + PACKAGE_CL.addExternalSymbol("FILE-ERROR-PATHNAME"); + public static final Symbol FILE_LENGTH = + PACKAGE_CL.addExternalSymbol("FILE-LENGTH"); + public static final Symbol FILE_NAMESTRING = + PACKAGE_CL.addExternalSymbol("FILE-NAMESTRING"); + public static final Symbol FILE_POSITION = + PACKAGE_CL.addExternalSymbol("FILE-POSITION"); + public static final Symbol FILE_STREAM = + PACKAGE_CL.addExternalSymbol("FILE-STREAM"); + public static final Symbol FILE_STRING_LENGTH = + PACKAGE_CL.addExternalSymbol("FILE-STRING-LENGTH"); + public static final Symbol FILE_WRITE_DATE = + PACKAGE_CL.addExternalSymbol("FILE-WRITE-DATE"); + public static final Symbol FILL = + PACKAGE_CL.addExternalSymbol("FILL"); + public static final Symbol FILL_POINTER = + PACKAGE_CL.addExternalSymbol("FILL-POINTER"); + public static final Symbol FIND = + PACKAGE_CL.addExternalSymbol("FIND"); + public static final Symbol FIND_ALL_SYMBOLS = + PACKAGE_CL.addExternalSymbol("FIND-ALL-SYMBOLS"); + public static final Symbol FIND_CLASS = + PACKAGE_CL.addExternalSymbol("FIND-CLASS"); + public static final Symbol FIND_IF = + PACKAGE_CL.addExternalSymbol("FIND-IF"); + public static final Symbol FIND_IF_NOT = + PACKAGE_CL.addExternalSymbol("FIND-IF-NOT"); + public static final Symbol FIND_METHOD = + PACKAGE_CL.addExternalSymbol("FIND-METHOD"); + public static final Symbol FIND_PACKAGE = + PACKAGE_CL.addExternalSymbol("FIND-PACKAGE"); + public static final Symbol FIND_RESTART = + PACKAGE_CL.addExternalSymbol("FIND-RESTART"); + public static final Symbol FIND_SYMBOL = + PACKAGE_CL.addExternalSymbol("FIND-SYMBOL"); + public static final Symbol FINISH_OUTPUT = + PACKAGE_CL.addExternalSymbol("FINISH-OUTPUT"); + public static final Symbol FIRST = + PACKAGE_CL.addExternalSymbol("FIRST"); + public static final Symbol FIXNUM = + PACKAGE_CL.addExternalSymbol("FIXNUM"); + public static final Symbol FLET = + PACKAGE_CL.addExternalSymbol("FLET"); + public static final Symbol FLOAT = + PACKAGE_CL.addExternalSymbol("FLOAT"); + public static final Symbol FLOAT_DIGITS = + PACKAGE_CL.addExternalSymbol("FLOAT-DIGITS"); + public static final Symbol FLOAT_PRECISION = + PACKAGE_CL.addExternalSymbol("FLOAT-PRECISION"); + public static final Symbol FLOAT_RADIX = + PACKAGE_CL.addExternalSymbol("FLOAT-RADIX"); + public static final Symbol FLOAT_SIGN = + PACKAGE_CL.addExternalSymbol("FLOAT-SIGN"); + public static final Symbol FLOATING_POINT_INEXACT = + PACKAGE_CL.addExternalSymbol("FLOATING-POINT-INEXACT"); + public static final Symbol FLOATING_POINT_INVALID_OPERATION = + PACKAGE_CL.addExternalSymbol("FLOATING-POINT-INVALID-OPERATION"); + public static final Symbol FLOATING_POINT_OVERFLOW = + PACKAGE_CL.addExternalSymbol("FLOATING-POINT-OVERFLOW"); + public static final Symbol FLOATING_POINT_UNDERFLOW = + PACKAGE_CL.addExternalSymbol("FLOATING-POINT-UNDERFLOW"); + public static final Symbol FLOATP = + PACKAGE_CL.addExternalSymbol("FLOATP"); + public static final Symbol FLOOR = + PACKAGE_CL.addExternalSymbol("FLOOR"); + public static final Symbol FMAKUNBOUND = + PACKAGE_CL.addExternalSymbol("FMAKUNBOUND"); + public static final Symbol FORCE_OUTPUT = + PACKAGE_CL.addExternalSymbol("FORCE-OUTPUT"); + public static final Symbol FORMAT = + PACKAGE_CL.addExternalSymbol("FORMAT"); + public static final Symbol FORMATTER = + PACKAGE_CL.addExternalSymbol("FORMATTER"); + public static final Symbol FOURTH = + PACKAGE_CL.addExternalSymbol("FOURTH"); + public static final Symbol FRESH_LINE = + PACKAGE_CL.addExternalSymbol("FRESH-LINE"); + public static final Symbol FROUND = + PACKAGE_CL.addExternalSymbol("FROUND"); + public static final Symbol FTRUNCATE = + PACKAGE_CL.addExternalSymbol("FTRUNCATE"); + public static final Symbol FTYPE = + PACKAGE_CL.addExternalSymbol("FTYPE"); + public static final Symbol FUNCALL = + PACKAGE_CL.addExternalSymbol("FUNCALL"); + public static final Symbol FUNCTION = + PACKAGE_CL.addExternalSymbol("FUNCTION"); + public static final Symbol FUNCTION_KEYWORDS = + PACKAGE_CL.addExternalSymbol("FUNCTION-KEYWORDS"); + public static final Symbol FUNCTION_LAMBDA_EXPRESSION = + PACKAGE_CL.addExternalSymbol("FUNCTION-LAMBDA-EXPRESSION"); + public static final Symbol FUNCTIONP = + PACKAGE_CL.addExternalSymbol("FUNCTIONP"); + public static final Symbol GCD = + PACKAGE_CL.addExternalSymbol("GCD"); + public static final Symbol GENERIC_FUNCTION = + PACKAGE_CL.addExternalSymbol("GENERIC-FUNCTION"); + public static final Symbol GENSYM = + PACKAGE_CL.addExternalSymbol("GENSYM"); + public static final Symbol GENTEMP = + PACKAGE_CL.addExternalSymbol("GENTEMP"); + public static final Symbol GET = + PACKAGE_CL.addExternalSymbol("GET"); + public static final Symbol GET_DECODED_TIME = + PACKAGE_CL.addExternalSymbol("GET-DECODED-TIME"); + public static final Symbol GET_DISPATCH_MACRO_CHARACTER = + PACKAGE_CL.addExternalSymbol("GET-DISPATCH-MACRO-CHARACTER"); + public static final Symbol GET_INTERNAL_REAL_TIME = + PACKAGE_CL.addExternalSymbol("GET-INTERNAL-REAL-TIME"); + public static final Symbol GET_INTERNAL_RUN_TIME = + PACKAGE_CL.addExternalSymbol("GET-INTERNAL-RUN-TIME"); + public static final Symbol GET_MACRO_CHARACTER = + PACKAGE_CL.addExternalSymbol("GET-MACRO-CHARACTER"); + public static final Symbol GET_OUTPUT_STREAM_STRING = + PACKAGE_CL.addExternalSymbol("GET-OUTPUT-STREAM-STRING"); + public static final Symbol GET_PROPERTIES = + PACKAGE_CL.addExternalSymbol("GET-PROPERTIES"); + public static final Symbol GET_SETF_EXPANSION = + PACKAGE_CL.addExternalSymbol("GET-SETF-EXPANSION"); + public static final Symbol GET_UNIVERSAL_TIME = + PACKAGE_CL.addExternalSymbol("GET-UNIVERSAL-TIME"); + public static final Symbol GETF = + PACKAGE_CL.addExternalSymbol("GETF"); + public static final Symbol GETHASH = + PACKAGE_CL.addExternalSymbol("GETHASH"); + public static final Symbol GO = + PACKAGE_CL.addExternalSymbol("GO"); + public static final Symbol GRAPHIC_CHAR_P = + PACKAGE_CL.addExternalSymbol("GRAPHIC-CHAR-P"); + public static final Symbol HANDLER_BIND = + PACKAGE_CL.addExternalSymbol("HANDLER-BIND"); + public static final Symbol HANDLER_CASE = + PACKAGE_CL.addExternalSymbol("HANDLER-CASE"); + public static final Symbol HASH_TABLE = + PACKAGE_CL.addExternalSymbol("HASH-TABLE"); + public static final Symbol HASH_TABLE_COUNT = + PACKAGE_CL.addExternalSymbol("HASH-TABLE-COUNT"); + public static final Symbol HASH_TABLE_P = + PACKAGE_CL.addExternalSymbol("HASH-TABLE-P"); + public static final Symbol HASH_TABLE_REHASH_SIZE = + PACKAGE_CL.addExternalSymbol("HASH-TABLE-REHASH-SIZE"); + public static final Symbol HASH_TABLE_REHASH_THRESHOLD = + PACKAGE_CL.addExternalSymbol("HASH-TABLE-REHASH-THRESHOLD"); + public static final Symbol HASH_TABLE_SIZE = + PACKAGE_CL.addExternalSymbol("HASH-TABLE-SIZE"); + public static final Symbol HASH_TABLE_TEST = + PACKAGE_CL.addExternalSymbol("HASH-TABLE-TEST"); + public static final Symbol HOST_NAMESTRING = + PACKAGE_CL.addExternalSymbol("HOST-NAMESTRING"); + public static final Symbol IDENTITY = + PACKAGE_CL.addExternalSymbol("IDENTITY"); + public static final Symbol IF = + PACKAGE_CL.addExternalSymbol("IF"); + public static final Symbol IGNORABLE = + PACKAGE_CL.addExternalSymbol("IGNORABLE"); + public static final Symbol IGNORE = + PACKAGE_CL.addExternalSymbol("IGNORE"); + public static final Symbol IGNORE_ERRORS = + PACKAGE_CL.addExternalSymbol("IGNORE-ERRORS"); + public static final Symbol IMAGPART = + PACKAGE_CL.addExternalSymbol("IMAGPART"); + public static final Symbol IMPORT = + PACKAGE_CL.addExternalSymbol("IMPORT"); + public static final Symbol IN_PACKAGE = + PACKAGE_CL.addExternalSymbol("IN-PACKAGE"); + public static final Symbol INCF = + PACKAGE_CL.addExternalSymbol("INCF"); + public static final Symbol INITIALIZE_INSTANCE = + PACKAGE_CL.addExternalSymbol("INITIALIZE-INSTANCE"); + public static final Symbol INLINE = + PACKAGE_CL.addExternalSymbol("INLINE"); + public static final Symbol INPUT_STREAM_P = + PACKAGE_CL.addExternalSymbol("INPUT-STREAM-P"); + public static final Symbol INSPECT = + PACKAGE_CL.addExternalSymbol("INSPECT"); + public static final Symbol INTEGER = + PACKAGE_CL.addExternalSymbol("INTEGER"); + public static final Symbol INTEGER_DECODE_FLOAT = + PACKAGE_CL.addExternalSymbol("INTEGER-DECODE-FLOAT"); + public static final Symbol INTEGER_LENGTH = + PACKAGE_CL.addExternalSymbol("INTEGER-LENGTH"); + public static final Symbol INTEGERP = + PACKAGE_CL.addExternalSymbol("INTEGERP"); + public static final Symbol INTERACTIVE_STREAM_P = + PACKAGE_CL.addExternalSymbol("INTERACTIVE-STREAM-P"); + public static final Symbol INTERN = + PACKAGE_CL.addExternalSymbol("INTERN"); + public static final Symbol INTERNAL_TIME_UNITS_PER_SECOND = + PACKAGE_CL.addExternalSymbol("INTERNAL-TIME-UNITS-PER-SECOND"); + public static final Symbol INTERSECTION = + PACKAGE_CL.addExternalSymbol("INTERSECTION"); + public static final Symbol INVALID_METHOD_ERROR = + PACKAGE_CL.addExternalSymbol("INVALID-METHOD-ERROR"); + public static final Symbol INVOKE_DEBUGGER = + PACKAGE_CL.addExternalSymbol("INVOKE-DEBUGGER"); + public static final Symbol INVOKE_RESTART = + PACKAGE_CL.addExternalSymbol("INVOKE-RESTART"); + public static final Symbol INVOKE_RESTART_INTERACTIVELY = + PACKAGE_CL.addExternalSymbol("INVOKE-RESTART-INTERACTIVELY"); + public static final Symbol ISQRT = + PACKAGE_CL.addExternalSymbol("ISQRT"); + public static final Symbol KEYWORD = + PACKAGE_CL.addExternalSymbol("KEYWORD"); + public static final Symbol KEYWORDP = + PACKAGE_CL.addExternalSymbol("KEYWORDP"); + public static final Symbol LABELS = + PACKAGE_CL.addExternalSymbol("LABELS"); + public static final Symbol LAMBDA = + PACKAGE_CL.addExternalSymbol("LAMBDA"); + public static final Symbol LAMBDA_LIST_KEYWORDS = + PACKAGE_CL.addExternalSymbol("LAMBDA-LIST-KEYWORDS"); + public static final Symbol LAMBDA_PARAMETERS_LIMIT = + PACKAGE_CL.addExternalSymbol("LAMBDA-PARAMETERS-LIMIT"); + public static final Symbol LAST = + PACKAGE_CL.addExternalSymbol("LAST"); + public static final Symbol LCM = + PACKAGE_CL.addExternalSymbol("LCM"); + public static final Symbol LDB = + PACKAGE_CL.addExternalSymbol("LDB"); + public static final Symbol LDB_TEST = + PACKAGE_CL.addExternalSymbol("LDB-TEST"); + public static final Symbol LDIFF = + PACKAGE_CL.addExternalSymbol("LDIFF"); + public static final Symbol LEAST_NEGATIVE_DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-DOUBLE-FLOAT"); + public static final Symbol LEAST_NEGATIVE_LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-LONG-FLOAT"); + public static final Symbol LEAST_NEGATIVE_NORMALIZED_DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT"); + public static final Symbol LEAST_NEGATIVE_NORMALIZED_LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT"); + public static final Symbol LEAST_NEGATIVE_NORMALIZED_SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT"); + public static final Symbol LEAST_NEGATIVE_NORMALIZED_SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT"); + public static final Symbol LEAST_NEGATIVE_SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-SHORT-FLOAT"); + public static final Symbol LEAST_NEGATIVE_SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-NEGATIVE-SINGLE-FLOAT"); + public static final Symbol LEAST_POSITIVE_DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-DOUBLE-FLOAT"); + public static final Symbol LEAST_POSITIVE_LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-LONG-FLOAT"); + public static final Symbol LEAST_POSITIVE_NORMALIZED_DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT"); + public static final Symbol LEAST_POSITIVE_NORMALIZED_LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-NORMALIZED-LONG-FLOAT"); + public static final Symbol LEAST_POSITIVE_NORMALIZED_SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT"); + public static final Symbol LEAST_POSITIVE_NORMALIZED_SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT"); + public static final Symbol LEAST_POSITIVE_SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-SHORT-FLOAT"); + public static final Symbol LEAST_POSITIVE_SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("LEAST-POSITIVE-SINGLE-FLOAT"); + public static final Symbol LENGTH = + PACKAGE_CL.addExternalSymbol("LENGTH"); + public static final Symbol LET = + PACKAGE_CL.addExternalSymbol("LET"); + public static final Symbol LET_STAR = + PACKAGE_CL.addExternalSymbol("LET*"); + public static final Symbol LISP_IMPLEMENTATION_TYPE = + PACKAGE_CL.addExternalSymbol("LISP-IMPLEMENTATION-TYPE"); + public static final Symbol LISP_IMPLEMENTATION_VERSION = + PACKAGE_CL.addExternalSymbol("LISP-IMPLEMENTATION-VERSION"); + public static final Symbol LIST = + PACKAGE_CL.addExternalSymbol("LIST"); + public static final Symbol LIST_STAR = + PACKAGE_CL.addExternalSymbol("LIST*"); + public static final Symbol LIST_ALL_PACKAGES = + PACKAGE_CL.addExternalSymbol("LIST-ALL-PACKAGES"); + public static final Symbol LIST_LENGTH = + PACKAGE_CL.addExternalSymbol("LIST-LENGTH"); + public static final Symbol LISTEN = + PACKAGE_CL.addExternalSymbol("LISTEN"); + public static final Symbol LISTP = + PACKAGE_CL.addExternalSymbol("LISTP"); + public static final Symbol LOAD = + PACKAGE_CL.addExternalSymbol("LOAD"); + public static final Symbol LOAD_LOGICAL_PATHNAME_TRANSLATIONS = + PACKAGE_CL.addExternalSymbol("LOAD-LOGICAL-PATHNAME-TRANSLATIONS"); + public static final Symbol LOAD_TIME_VALUE = + PACKAGE_CL.addExternalSymbol("LOAD-TIME-VALUE"); + public static final Symbol LOCALLY = + PACKAGE_CL.addExternalSymbol("LOCALLY"); + public static final Symbol LOG = + PACKAGE_CL.addExternalSymbol("LOG"); + public static final Symbol LOGAND = + PACKAGE_CL.addExternalSymbol("LOGAND"); + public static final Symbol LOGANDC1 = + PACKAGE_CL.addExternalSymbol("LOGANDC1"); + public static final Symbol LOGANDC2 = + PACKAGE_CL.addExternalSymbol("LOGANDC2"); + public static final Symbol LOGBITP = + PACKAGE_CL.addExternalSymbol("LOGBITP"); + public static final Symbol LOGCOUNT = + PACKAGE_CL.addExternalSymbol("LOGCOUNT"); + public static final Symbol LOGEQV = + PACKAGE_CL.addExternalSymbol("LOGEQV"); + public static final Symbol LOGICAL_PATHNAME = + PACKAGE_CL.addExternalSymbol("LOGICAL-PATHNAME"); + public static final Symbol LOGICAL_PATHNAME_TRANSLATIONS = + PACKAGE_CL.addExternalSymbol("LOGICAL-PATHNAME-TRANSLATIONS"); + public static final Symbol LOGIOR = + PACKAGE_CL.addExternalSymbol("LOGIOR"); + public static final Symbol LOGNAND = + PACKAGE_CL.addExternalSymbol("LOGNAND"); + public static final Symbol LOGNOR = + PACKAGE_CL.addExternalSymbol("LOGNOR"); + public static final Symbol LOGNOT = + PACKAGE_CL.addExternalSymbol("LOGNOT"); + public static final Symbol LOGORC1 = + PACKAGE_CL.addExternalSymbol("LOGORC1"); + public static final Symbol LOGORC2 = + PACKAGE_CL.addExternalSymbol("LOGORC2"); + public static final Symbol LOGTEST = + PACKAGE_CL.addExternalSymbol("LOGTEST"); + public static final Symbol LOGXOR = + PACKAGE_CL.addExternalSymbol("LOGXOR"); + public static final Symbol LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("LONG-FLOAT"); + public static final Symbol LONG_FLOAT_EPSILON = + PACKAGE_CL.addExternalSymbol("LONG-FLOAT-EPSILON"); + public static final Symbol LONG_FLOAT_NEGATIVE_EPSILON = + PACKAGE_CL.addExternalSymbol("LONG-FLOAT-NEGATIVE-EPSILON"); + public static final Symbol LONG_SITE_NAME = + PACKAGE_CL.addExternalSymbol("LONG-SITE-NAME"); + public static final Symbol LOOP = + PACKAGE_CL.addExternalSymbol("LOOP"); + public static final Symbol LOOP_FINISH = + PACKAGE_CL.addExternalSymbol("LOOP-FINISH"); + public static final Symbol LOWER_CASE_P = + PACKAGE_CL.addExternalSymbol("LOWER-CASE-P"); + public static final Symbol MACHINE_INSTANCE = + PACKAGE_CL.addExternalSymbol("MACHINE-INSTANCE"); + public static final Symbol MACHINE_TYPE = + PACKAGE_CL.addExternalSymbol("MACHINE-TYPE"); + public static final Symbol MACHINE_VERSION = + PACKAGE_CL.addExternalSymbol("MACHINE-VERSION"); + public static final Symbol MACRO_FUNCTION = + PACKAGE_CL.addExternalSymbol("MACRO-FUNCTION"); + public static final Symbol MACROEXPAND = + PACKAGE_CL.addExternalSymbol("MACROEXPAND"); + public static final Symbol MACROEXPAND_1 = + PACKAGE_CL.addExternalSymbol("MACROEXPAND-1"); + public static final Symbol MACROLET = + PACKAGE_CL.addExternalSymbol("MACROLET"); + public static final Symbol MAKE_ARRAY = + PACKAGE_CL.addExternalSymbol("MAKE-ARRAY"); + public static final Symbol MAKE_BROADCAST_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-BROADCAST-STREAM"); + public static final Symbol MAKE_CONCATENATED_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-CONCATENATED-STREAM"); + public static final Symbol MAKE_CONDITION = + PACKAGE_CL.addExternalSymbol("MAKE-CONDITION"); + public static final Symbol MAKE_DISPATCH_MACRO_CHARACTER = + PACKAGE_CL.addExternalSymbol("MAKE-DISPATCH-MACRO-CHARACTER"); + public static final Symbol MAKE_ECHO_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-ECHO-STREAM"); + public static final Symbol MAKE_HASH_TABLE = + PACKAGE_CL.addExternalSymbol("MAKE-HASH-TABLE"); + public static final Symbol MAKE_INSTANCE = + PACKAGE_CL.addExternalSymbol("MAKE-INSTANCE"); + public static final Symbol MAKE_INSTANCES_OBSOLETE = + PACKAGE_CL.addExternalSymbol("MAKE-INSTANCES-OBSOLETE"); + public static final Symbol MAKE_LIST = + PACKAGE_CL.addExternalSymbol("MAKE-LIST"); + public static final Symbol MAKE_LOAD_FORM = + PACKAGE_CL.addExternalSymbol("MAKE-LOAD-FORM"); + public static final Symbol MAKE_LOAD_FORM_SAVING_SLOTS = + PACKAGE_CL.addExternalSymbol("MAKE-LOAD-FORM-SAVING-SLOTS"); + public static final Symbol MAKE_METHOD = + PACKAGE_CL.addExternalSymbol("MAKE-METHOD"); + public static final Symbol MAKE_PACKAGE = + PACKAGE_CL.addExternalSymbol("MAKE-PACKAGE"); + public static final Symbol MAKE_PATHNAME = + PACKAGE_CL.addExternalSymbol("MAKE-PATHNAME"); + public static final Symbol MAKE_RANDOM_STATE = + PACKAGE_CL.addExternalSymbol("MAKE-RANDOM-STATE"); + public static final Symbol MAKE_SEQUENCE = + PACKAGE_CL.addExternalSymbol("MAKE-SEQUENCE"); + public static final Symbol MAKE_STRING = + PACKAGE_CL.addExternalSymbol("MAKE-STRING"); + public static final Symbol MAKE_STRING_INPUT_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-STRING-INPUT-STREAM"); + public static final Symbol MAKE_STRING_OUTPUT_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-STRING-OUTPUT-STREAM"); + public static final Symbol MAKE_SYMBOL = + PACKAGE_CL.addExternalSymbol("MAKE-SYMBOL"); + public static final Symbol MAKE_SYNONYM_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-SYNONYM-STREAM"); + public static final Symbol MAKE_TWO_WAY_STREAM = + PACKAGE_CL.addExternalSymbol("MAKE-TWO-WAY-STREAM"); + public static final Symbol MAKUNBOUND = + PACKAGE_CL.addExternalSymbol("MAKUNBOUND"); + public static final Symbol MAP = + PACKAGE_CL.addExternalSymbol("MAP"); + public static final Symbol MAP_INTO = + PACKAGE_CL.addExternalSymbol("MAP-INTO"); + public static final Symbol MAPC = + PACKAGE_CL.addExternalSymbol("MAPC"); + public static final Symbol MAPCAN = + PACKAGE_CL.addExternalSymbol("MAPCAN"); + public static final Symbol MAPCAR = + PACKAGE_CL.addExternalSymbol("MAPCAR"); + public static final Symbol MAPCON = + PACKAGE_CL.addExternalSymbol("MAPCON"); + public static final Symbol MAPHASH = + PACKAGE_CL.addExternalSymbol("MAPHASH"); + public static final Symbol MAPL = + PACKAGE_CL.addExternalSymbol("MAPL"); + public static final Symbol MAPLIST = + PACKAGE_CL.addExternalSymbol("MAPLIST"); + public static final Symbol MASK_FIELD = + PACKAGE_CL.addExternalSymbol("MASK-FIELD"); + public static final Symbol MAX = + PACKAGE_CL.addExternalSymbol("MAX"); + public static final Symbol MEMBER = + PACKAGE_CL.addExternalSymbol("MEMBER"); + public static final Symbol MEMBER_IF = + PACKAGE_CL.addExternalSymbol("MEMBER-IF"); + public static final Symbol MEMBER_IF_NOT = + PACKAGE_CL.addExternalSymbol("MEMBER-IF-NOT"); + public static final Symbol MERGE = + PACKAGE_CL.addExternalSymbol("MERGE"); + public static final Symbol MERGE_PATHNAMES = + PACKAGE_CL.addExternalSymbol("MERGE-PATHNAMES"); + public static final Symbol METHOD = + PACKAGE_CL.addExternalSymbol("METHOD"); + public static final Symbol METHOD_COMBINATION = + PACKAGE_CL.addExternalSymbol("METHOD-COMBINATION"); + public static final Symbol METHOD_COMBINATION_ERROR = + PACKAGE_CL.addExternalSymbol("METHOD-COMBINATION-ERROR"); + public static final Symbol METHOD_QUALIFIERS = + PACKAGE_CL.addExternalSymbol("METHOD-QUALIFIERS"); + public static final Symbol MIN = + PACKAGE_CL.addExternalSymbol("MIN"); + public static final Symbol MINUSP = + PACKAGE_CL.addExternalSymbol("MINUSP"); + public static final Symbol MISMATCH = + PACKAGE_CL.addExternalSymbol("MISMATCH"); + public static final Symbol MOD = + PACKAGE_CL.addExternalSymbol("MOD"); + public static final Symbol MOST_NEGATIVE_DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-NEGATIVE-DOUBLE-FLOAT"); + public static final Symbol MOST_NEGATIVE_FIXNUM = + PACKAGE_CL.addExternalSymbol("MOST-NEGATIVE-FIXNUM"); + public static final Symbol MOST_NEGATIVE_LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-NEGATIVE-LONG-FLOAT"); + public static final Symbol MOST_NEGATIVE_SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-NEGATIVE-SHORT-FLOAT"); + public static final Symbol MOST_NEGATIVE_SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-NEGATIVE-SINGLE-FLOAT"); + public static final Symbol MOST_POSITIVE_DOUBLE_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-POSITIVE-DOUBLE-FLOAT"); + public static final Symbol MOST_POSITIVE_FIXNUM = + PACKAGE_CL.addExternalSymbol("MOST-POSITIVE-FIXNUM"); + public static final Symbol MOST_POSITIVE_LONG_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-POSITIVE-LONG-FLOAT"); + public static final Symbol MOST_POSITIVE_SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-POSITIVE-SHORT-FLOAT"); + public static final Symbol MOST_POSITIVE_SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("MOST-POSITIVE-SINGLE-FLOAT"); + public static final Symbol MUFFLE_WARNING = + PACKAGE_CL.addExternalSymbol("MUFFLE-WARNING"); + public static final Symbol MULTIPLE_VALUE_BIND = + PACKAGE_CL.addExternalSymbol("MULTIPLE-VALUE-BIND"); + public static final Symbol MULTIPLE_VALUE_CALL = + PACKAGE_CL.addExternalSymbol("MULTIPLE-VALUE-CALL"); + public static final Symbol MULTIPLE_VALUE_LIST = + PACKAGE_CL.addExternalSymbol("MULTIPLE-VALUE-LIST"); + public static final Symbol MULTIPLE_VALUE_PROG1 = + PACKAGE_CL.addExternalSymbol("MULTIPLE-VALUE-PROG1"); + public static final Symbol MULTIPLE_VALUE_SETQ = + PACKAGE_CL.addExternalSymbol("MULTIPLE-VALUE-SETQ"); + public static final Symbol MULTIPLE_VALUES_LIMIT = + PACKAGE_CL.addExternalSymbol("MULTIPLE-VALUES-LIMIT"); + public static final Symbol NAME_CHAR = + PACKAGE_CL.addExternalSymbol("NAME-CHAR"); + public static final Symbol NAMESTRING = + PACKAGE_CL.addExternalSymbol("NAMESTRING"); + public static final Symbol NBUTLAST = + PACKAGE_CL.addExternalSymbol("NBUTLAST"); + public static final Symbol NCONC = + PACKAGE_CL.addExternalSymbol("NCONC"); + public static final Symbol NEXT_METHOD_P = + PACKAGE_CL.addExternalSymbol("NEXT-METHOD-P"); + // NIL is a special case. + // public static final Symbol NIL = + // PACKAGE_CL.addExternalSymbol("NIL"); + public static final Symbol NINTERSECTION = + PACKAGE_CL.addExternalSymbol("NINTERSECTION"); + public static final Symbol NINTH = + PACKAGE_CL.addExternalSymbol("NINTH"); + public static final Symbol NO_APPLICABLE_METHOD = + PACKAGE_CL.addExternalSymbol("NO-APPLICABLE-METHOD"); + public static final Symbol NO_NEXT_METHOD = + PACKAGE_CL.addExternalSymbol("NO-NEXT-METHOD"); + public static final Symbol NOT = + PACKAGE_CL.addExternalSymbol("NOT"); + public static final Symbol NOTANY = + PACKAGE_CL.addExternalSymbol("NOTANY"); + public static final Symbol NOTEVERY = + PACKAGE_CL.addExternalSymbol("NOTEVERY"); + public static final Symbol NOTINLINE = + PACKAGE_CL.addExternalSymbol("NOTINLINE"); + public static final Symbol NRECONC = + PACKAGE_CL.addExternalSymbol("NRECONC"); + public static final Symbol NREVERSE = + PACKAGE_CL.addExternalSymbol("NREVERSE"); + public static final Symbol NSET_DIFFERENCE = + PACKAGE_CL.addExternalSymbol("NSET-DIFFERENCE"); + public static final Symbol NSET_EXCLUSIVE_OR = + PACKAGE_CL.addExternalSymbol("NSET-EXCLUSIVE-OR"); + public static final Symbol NSTRING_CAPITALIZE = + PACKAGE_CL.addExternalSymbol("NSTRING-CAPITALIZE"); + public static final Symbol NSTRING_DOWNCASE = + PACKAGE_CL.addExternalSymbol("NSTRING-DOWNCASE"); + public static final Symbol NSTRING_UPCASE = + PACKAGE_CL.addExternalSymbol("NSTRING-UPCASE"); + public static final Symbol NSUBLIS = + PACKAGE_CL.addExternalSymbol("NSUBLIS"); + public static final Symbol NSUBST = + PACKAGE_CL.addExternalSymbol("NSUBST"); + public static final Symbol NSUBST_IF = + PACKAGE_CL.addExternalSymbol("NSUBST-IF"); + public static final Symbol NSUBST_IF_NOT = + PACKAGE_CL.addExternalSymbol("NSUBST-IF-NOT"); + public static final Symbol NSUBSTITUTE = + PACKAGE_CL.addExternalSymbol("NSUBSTITUTE"); + public static final Symbol NSUBSTITUTE_IF = + PACKAGE_CL.addExternalSymbol("NSUBSTITUTE-IF"); + public static final Symbol NSUBSTITUTE_IF_NOT = + PACKAGE_CL.addExternalSymbol("NSUBSTITUTE-IF-NOT"); + public static final Symbol NTH = + PACKAGE_CL.addExternalSymbol("NTH"); + public static final Symbol NTH_VALUE = + PACKAGE_CL.addExternalSymbol("NTH-VALUE"); + public static final Symbol NTHCDR = + PACKAGE_CL.addExternalSymbol("NTHCDR"); + public static final Symbol NULL = + PACKAGE_CL.addExternalSymbol("NULL"); + public static final Symbol NUMBER = + PACKAGE_CL.addExternalSymbol("NUMBER"); + public static final Symbol NUMBERP = + PACKAGE_CL.addExternalSymbol("NUMBERP"); + public static final Symbol NUMERATOR = + PACKAGE_CL.addExternalSymbol("NUMERATOR"); + public static final Symbol NUNION = + PACKAGE_CL.addExternalSymbol("NUNION"); + public static final Symbol ODDP = + PACKAGE_CL.addExternalSymbol("ODDP"); + public static final Symbol OPEN = + PACKAGE_CL.addExternalSymbol("OPEN"); + public static final Symbol OPEN_STREAM_P = + PACKAGE_CL.addExternalSymbol("OPEN-STREAM-P"); + public static final Symbol OPTIMIZE = + PACKAGE_CL.addExternalSymbol("OPTIMIZE"); + public static final Symbol OR = + PACKAGE_CL.addExternalSymbol("OR"); + public static final Symbol OTHERWISE = + PACKAGE_CL.addExternalSymbol("OTHERWISE"); + public static final Symbol OUTPUT_STREAM_P = + PACKAGE_CL.addExternalSymbol("OUTPUT-STREAM-P"); + public static final Symbol PACKAGE = + PACKAGE_CL.addExternalSymbol("PACKAGE"); + public static final Symbol PACKAGE_ERROR = + PACKAGE_CL.addExternalSymbol("PACKAGE-ERROR"); + public static final Symbol PACKAGE_ERROR_PACKAGE = + PACKAGE_CL.addExternalSymbol("PACKAGE-ERROR-PACKAGE"); + public static final Symbol PACKAGE_NAME = + PACKAGE_CL.addExternalSymbol("PACKAGE-NAME"); + public static final Symbol PACKAGE_NICKNAMES = + PACKAGE_CL.addExternalSymbol("PACKAGE-NICKNAMES"); + public static final Symbol PACKAGE_SHADOWING_SYMBOLS = + PACKAGE_CL.addExternalSymbol("PACKAGE-SHADOWING-SYMBOLS"); + public static final Symbol PACKAGE_USE_LIST = + PACKAGE_CL.addExternalSymbol("PACKAGE-USE-LIST"); + public static final Symbol PACKAGE_USED_BY_LIST = + PACKAGE_CL.addExternalSymbol("PACKAGE-USED-BY-LIST"); + public static final Symbol PACKAGEP = + PACKAGE_CL.addExternalSymbol("PACKAGEP"); + public static final Symbol PAIRLIS = + PACKAGE_CL.addExternalSymbol("PAIRLIS"); + public static final Symbol PARSE_ERROR = + PACKAGE_CL.addExternalSymbol("PARSE-ERROR"); + public static final Symbol PARSE_INTEGER = + PACKAGE_CL.addExternalSymbol("PARSE-INTEGER"); + public static final Symbol PARSE_NAMESTRING = + PACKAGE_CL.addExternalSymbol("PARSE-NAMESTRING"); + public static final Symbol PATHNAME = + PACKAGE_CL.addExternalSymbol("PATHNAME"); + public static final Symbol PATHNAME_DEVICE = + PACKAGE_CL.addExternalSymbol("PATHNAME-DEVICE"); + public static final Symbol PATHNAME_DIRECTORY = + PACKAGE_CL.addExternalSymbol("PATHNAME-DIRECTORY"); + public static final Symbol PATHNAME_HOST = + PACKAGE_CL.addExternalSymbol("PATHNAME-HOST"); + public static final Symbol PATHNAME_MATCH_P = + PACKAGE_CL.addExternalSymbol("PATHNAME-MATCH-P"); + public static final Symbol PATHNAME_NAME = + PACKAGE_CL.addExternalSymbol("PATHNAME-NAME"); + public static final Symbol PATHNAME_TYPE = + PACKAGE_CL.addExternalSymbol("PATHNAME-TYPE"); + public static final Symbol PATHNAME_VERSION = + PACKAGE_CL.addExternalSymbol("PATHNAME-VERSION"); + public static final Symbol PATHNAMEP = + PACKAGE_CL.addExternalSymbol("PATHNAMEP"); + public static final Symbol PEEK_CHAR = + PACKAGE_CL.addExternalSymbol("PEEK-CHAR"); + public static final Symbol PHASE = + PACKAGE_CL.addExternalSymbol("PHASE"); + public static final Symbol PI = + PACKAGE_CL.addExternalSymbol("PI"); + public static final Symbol PLUSP = + PACKAGE_CL.addExternalSymbol("PLUSP"); + public static final Symbol POP = + PACKAGE_CL.addExternalSymbol("POP"); + public static final Symbol POSITION = + PACKAGE_CL.addExternalSymbol("POSITION"); + public static final Symbol POSITION_IF = + PACKAGE_CL.addExternalSymbol("POSITION-IF"); + public static final Symbol POSITION_IF_NOT = + PACKAGE_CL.addExternalSymbol("POSITION-IF-NOT"); + public static final Symbol PPRINT = + PACKAGE_CL.addExternalSymbol("PPRINT"); + public static final Symbol PPRINT_DISPATCH = + PACKAGE_CL.addExternalSymbol("PPRINT-DISPATCH"); + public static final Symbol PPRINT_EXIT_IF_LIST_EXHAUSTED = + PACKAGE_CL.addExternalSymbol("PPRINT-EXIT-IF-LIST-EXHAUSTED"); + public static final Symbol PPRINT_FILL = + PACKAGE_CL.addExternalSymbol("PPRINT-FILL"); + public static final Symbol PPRINT_INDENT = + PACKAGE_CL.addExternalSymbol("PPRINT-INDENT"); + public static final Symbol PPRINT_LINEAR = + PACKAGE_CL.addExternalSymbol("PPRINT-LINEAR"); + public static final Symbol PPRINT_LOGICAL_BLOCK = + PACKAGE_CL.addExternalSymbol("PPRINT-LOGICAL-BLOCK"); + public static final Symbol PPRINT_NEWLINE = + PACKAGE_CL.addExternalSymbol("PPRINT-NEWLINE"); + public static final Symbol PPRINT_POP = + PACKAGE_CL.addExternalSymbol("PPRINT-POP"); + public static final Symbol PPRINT_TAB = + PACKAGE_CL.addExternalSymbol("PPRINT-TAB"); + public static final Symbol PPRINT_TABULAR = + PACKAGE_CL.addExternalSymbol("PPRINT-TABULAR"); + public static final Symbol PRIN1 = + PACKAGE_CL.addExternalSymbol("PRIN1"); + public static final Symbol PRIN1_TO_STRING = + PACKAGE_CL.addExternalSymbol("PRIN1-TO-STRING"); + public static final Symbol PRINC = + PACKAGE_CL.addExternalSymbol("PRINC"); + public static final Symbol PRINC_TO_STRING = + PACKAGE_CL.addExternalSymbol("PRINC-TO-STRING"); + public static final Symbol PRINT = + PACKAGE_CL.addExternalSymbol("PRINT"); + public static final Symbol PRINT_NOT_READABLE = + PACKAGE_CL.addExternalSymbol("PRINT-NOT-READABLE"); + public static final Symbol PRINT_NOT_READABLE_OBJECT = + PACKAGE_CL.addExternalSymbol("PRINT-NOT-READABLE-OBJECT"); + public static final Symbol PRINT_OBJECT = + PACKAGE_CL.addExternalSymbol("PRINT-OBJECT"); + public static final Symbol PRINT_UNREADABLE_OBJECT = + PACKAGE_CL.addExternalSymbol("PRINT-UNREADABLE-OBJECT"); + public static final Symbol PROBE_FILE = + PACKAGE_CL.addExternalSymbol("PROBE-FILE"); + public static final Symbol PROCLAIM = + PACKAGE_CL.addExternalSymbol("PROCLAIM"); + public static final Symbol PROG = + PACKAGE_CL.addExternalSymbol("PROG"); + public static final Symbol PROG_STAR = + PACKAGE_CL.addExternalSymbol("PROG*"); + public static final Symbol PROG1 = + PACKAGE_CL.addExternalSymbol("PROG1"); + public static final Symbol PROG2 = + PACKAGE_CL.addExternalSymbol("PROG2"); + public static final Symbol PROGN = + PACKAGE_CL.addExternalSymbol("PROGN"); + public static final Symbol PROGRAM_ERROR = + PACKAGE_CL.addExternalSymbol("PROGRAM-ERROR"); + public static final Symbol PROGV = + PACKAGE_CL.addExternalSymbol("PROGV"); + public static final Symbol PROVIDE = + PACKAGE_CL.addExternalSymbol("PROVIDE"); + public static final Symbol PSETF = + PACKAGE_CL.addExternalSymbol("PSETF"); + public static final Symbol PSETQ = + PACKAGE_CL.addExternalSymbol("PSETQ"); + public static final Symbol PUSH = + PACKAGE_CL.addExternalSymbol("PUSH"); + public static final Symbol PUSHNEW = + PACKAGE_CL.addExternalSymbol("PUSHNEW"); + public static final Symbol QUOTE = + PACKAGE_CL.addExternalSymbol("QUOTE"); + public static final Symbol RANDOM = + PACKAGE_CL.addExternalSymbol("RANDOM"); + public static final Symbol RANDOM_STATE = + PACKAGE_CL.addExternalSymbol("RANDOM-STATE"); + public static final Symbol RANDOM_STATE_P = + PACKAGE_CL.addExternalSymbol("RANDOM-STATE-P"); + public static final Symbol RASSOC = + PACKAGE_CL.addExternalSymbol("RASSOC"); + public static final Symbol RASSOC_IF = + PACKAGE_CL.addExternalSymbol("RASSOC-IF"); + public static final Symbol RASSOC_IF_NOT = + PACKAGE_CL.addExternalSymbol("RASSOC-IF-NOT"); + public static final Symbol RATIO = + PACKAGE_CL.addExternalSymbol("RATIO"); + public static final Symbol RATIONAL = + PACKAGE_CL.addExternalSymbol("RATIONAL"); + public static final Symbol RATIONALIZE = + PACKAGE_CL.addExternalSymbol("RATIONALIZE"); + public static final Symbol RATIONALP = + PACKAGE_CL.addExternalSymbol("RATIONALP"); + public static final Symbol READ = + PACKAGE_CL.addExternalSymbol("READ"); + public static final Symbol READ_BYTE = + PACKAGE_CL.addExternalSymbol("READ-BYTE"); + public static final Symbol READ_CHAR = + PACKAGE_CL.addExternalSymbol("READ-CHAR"); + public static final Symbol READ_CHAR_NO_HANG = + PACKAGE_CL.addExternalSymbol("READ-CHAR-NO-HANG"); + public static final Symbol READ_DELIMITED_LIST = + PACKAGE_CL.addExternalSymbol("READ-DELIMITED-LIST"); + public static final Symbol READ_FROM_STRING = + PACKAGE_CL.addExternalSymbol("READ-FROM-STRING"); + public static final Symbol READ_LINE = + PACKAGE_CL.addExternalSymbol("READ-LINE"); + public static final Symbol READ_PRESERVING_WHITESPACE = + PACKAGE_CL.addExternalSymbol("READ-PRESERVING-WHITESPACE"); + public static final Symbol READ_SEQUENCE = + PACKAGE_CL.addExternalSymbol("READ-SEQUENCE"); + public static final Symbol READER_ERROR = + PACKAGE_CL.addExternalSymbol("READER-ERROR"); + public static final Symbol READTABLE = + PACKAGE_CL.addExternalSymbol("READTABLE"); + public static final Symbol READTABLE_CASE = + PACKAGE_CL.addExternalSymbol("READTABLE-CASE"); + public static final Symbol READTABLEP = + PACKAGE_CL.addExternalSymbol("READTABLEP"); + public static final Symbol REAL = + PACKAGE_CL.addExternalSymbol("REAL"); + public static final Symbol REALP = + PACKAGE_CL.addExternalSymbol("REALP"); + public static final Symbol REALPART = + PACKAGE_CL.addExternalSymbol("REALPART"); + public static final Symbol REDUCE = + PACKAGE_CL.addExternalSymbol("REDUCE"); + public static final Symbol REINITIALIZE_INSTANCE = + PACKAGE_CL.addExternalSymbol("REINITIALIZE-INSTANCE"); + public static final Symbol REM = + PACKAGE_CL.addExternalSymbol("REM"); + public static final Symbol REMF = + PACKAGE_CL.addExternalSymbol("REMF"); + public static final Symbol REMHASH = + PACKAGE_CL.addExternalSymbol("REMHASH"); + public static final Symbol REMOVE = + PACKAGE_CL.addExternalSymbol("REMOVE"); + public static final Symbol REMOVE_DUPLICATES = + PACKAGE_CL.addExternalSymbol("REMOVE-DUPLICATES"); + public static final Symbol REMOVE_IF = + PACKAGE_CL.addExternalSymbol("REMOVE-IF"); + public static final Symbol REMOVE_IF_NOT = + PACKAGE_CL.addExternalSymbol("REMOVE-IF-NOT"); + public static final Symbol REMOVE_METHOD = + PACKAGE_CL.addExternalSymbol("REMOVE-METHOD"); + public static final Symbol REMPROP = + PACKAGE_CL.addExternalSymbol("REMPROP"); + public static final Symbol RENAME_FILE = + PACKAGE_CL.addExternalSymbol("RENAME-FILE"); + public static final Symbol RENAME_PACKAGE = + PACKAGE_CL.addExternalSymbol("RENAME-PACKAGE"); + public static final Symbol REPLACE = + PACKAGE_CL.addExternalSymbol("REPLACE"); + public static final Symbol REQUIRE = + PACKAGE_CL.addExternalSymbol("REQUIRE"); + public static final Symbol REST = + PACKAGE_CL.addExternalSymbol("REST"); + public static final Symbol RESTART = + PACKAGE_CL.addExternalSymbol("RESTART"); + public static final Symbol RESTART_BIND = + PACKAGE_CL.addExternalSymbol("RESTART-BIND"); + public static final Symbol RESTART_CASE = + PACKAGE_CL.addExternalSymbol("RESTART-CASE"); + public static final Symbol RESTART_NAME = + PACKAGE_CL.addExternalSymbol("RESTART-NAME"); + public static final Symbol RETURN = + PACKAGE_CL.addExternalSymbol("RETURN"); + public static final Symbol RETURN_FROM = + PACKAGE_CL.addExternalSymbol("RETURN-FROM"); + public static final Symbol REVAPPEND = + PACKAGE_CL.addExternalSymbol("REVAPPEND"); + public static final Symbol REVERSE = + PACKAGE_CL.addExternalSymbol("REVERSE"); + public static final Symbol ROOM = + PACKAGE_CL.addExternalSymbol("ROOM"); + public static final Symbol ROTATEF = + PACKAGE_CL.addExternalSymbol("ROTATEF"); + public static final Symbol ROUND = + PACKAGE_CL.addExternalSymbol("ROUND"); + public static final Symbol ROW_MAJOR_AREF = + PACKAGE_CL.addExternalSymbol("ROW-MAJOR-AREF"); + public static final Symbol RPLACA = + PACKAGE_CL.addExternalSymbol("RPLACA"); + public static final Symbol RPLACD = + PACKAGE_CL.addExternalSymbol("RPLACD"); + public static final Symbol SAFETY = + PACKAGE_CL.addExternalSymbol("SAFETY"); + public static final Symbol SATISFIES = + PACKAGE_CL.addExternalSymbol("SATISFIES"); + public static final Symbol SBIT = + PACKAGE_CL.addExternalSymbol("SBIT"); + public static final Symbol SCALE_FLOAT = + PACKAGE_CL.addExternalSymbol("SCALE-FLOAT"); + public static final Symbol SCHAR = + PACKAGE_CL.addExternalSymbol("SCHAR"); + public static final Symbol SEARCH = + PACKAGE_CL.addExternalSymbol("SEARCH"); + public static final Symbol SECOND = + PACKAGE_CL.addExternalSymbol("SECOND"); + public static final Symbol SEQUENCE = + PACKAGE_CL.addExternalSymbol("SEQUENCE"); + public static final Symbol SERIOUS_CONDITION = + PACKAGE_CL.addExternalSymbol("SERIOUS-CONDITION"); + public static final Symbol SET = + PACKAGE_CL.addExternalSymbol("SET"); + public static final Symbol SET_DIFFERENCE = + PACKAGE_CL.addExternalSymbol("SET-DIFFERENCE"); + public static final Symbol SET_DISPATCH_MACRO_CHARACTER = + PACKAGE_CL.addExternalSymbol("SET-DISPATCH-MACRO-CHARACTER"); + public static final Symbol SET_EXCLUSIVE_OR = + PACKAGE_CL.addExternalSymbol("SET-EXCLUSIVE-OR"); + public static final Symbol SET_MACRO_CHARACTER = + PACKAGE_CL.addExternalSymbol("SET-MACRO-CHARACTER"); + public static final Symbol SET_PPRINT_DISPATCH = + PACKAGE_CL.addExternalSymbol("SET-PPRINT-DISPATCH"); + public static final Symbol SET_SYNTAX_FROM_CHAR = + PACKAGE_CL.addExternalSymbol("SET-SYNTAX-FROM-CHAR"); + public static final Symbol SETF = + PACKAGE_CL.addExternalSymbol("SETF"); + public static final Symbol SETQ = + PACKAGE_CL.addExternalSymbol("SETQ"); + public static final Symbol SEVENTH = + PACKAGE_CL.addExternalSymbol("SEVENTH"); + public static final Symbol SHADOW = + PACKAGE_CL.addExternalSymbol("SHADOW"); + public static final Symbol SHADOWING_IMPORT = + PACKAGE_CL.addExternalSymbol("SHADOWING-IMPORT"); + public static final Symbol SHARED_INITIALIZE = + PACKAGE_CL.addExternalSymbol("SHARED-INITIALIZE"); + public static final Symbol SHIFTF = + PACKAGE_CL.addExternalSymbol("SHIFTF"); + public static final Symbol SHORT_FLOAT = + PACKAGE_CL.addExternalSymbol("SHORT-FLOAT"); + public static final Symbol SHORT_FLOAT_EPSILON = + PACKAGE_CL.addExternalSymbol("SHORT-FLOAT-EPSILON"); + public static final Symbol SHORT_FLOAT_NEGATIVE_EPSILON = + PACKAGE_CL.addExternalSymbol("SHORT-FLOAT-NEGATIVE-EPSILON"); + public static final Symbol SHORT_SITE_NAME = + PACKAGE_CL.addExternalSymbol("SHORT-SITE-NAME"); + public static final Symbol SIGNAL = + PACKAGE_CL.addExternalSymbol("SIGNAL"); + public static final Symbol SIGNED_BYTE = + PACKAGE_CL.addExternalSymbol("SIGNED-BYTE"); + public static final Symbol SIGNUM = + PACKAGE_CL.addExternalSymbol("SIGNUM"); + public static final Symbol SIMPLE_ARRAY = + PACKAGE_CL.addExternalSymbol("SIMPLE-ARRAY"); + public static final Symbol SIMPLE_BASE_STRING = + PACKAGE_CL.addExternalSymbol("SIMPLE-BASE-STRING"); + public static final Symbol SIMPLE_BIT_VECTOR = + PACKAGE_CL.addExternalSymbol("SIMPLE-BIT-VECTOR"); + public static final Symbol SIMPLE_BIT_VECTOR_P = + PACKAGE_CL.addExternalSymbol("SIMPLE-BIT-VECTOR-P"); + public static final Symbol SIMPLE_CONDITION = + PACKAGE_CL.addExternalSymbol("SIMPLE-CONDITION"); + public static final Symbol SIMPLE_CONDITION_FORMAT_ARGUMENTS = + PACKAGE_CL.addExternalSymbol("SIMPLE-CONDITION-FORMAT-ARGUMENTS"); + public static final Symbol SIMPLE_CONDITION_FORMAT_CONTROL = + PACKAGE_CL.addExternalSymbol("SIMPLE-CONDITION-FORMAT-CONTROL"); + public static final Symbol SIMPLE_ERROR = + PACKAGE_CL.addExternalSymbol("SIMPLE-ERROR"); + public static final Symbol SIMPLE_STRING = + PACKAGE_CL.addExternalSymbol("SIMPLE-STRING"); + public static final Symbol SIMPLE_STRING_P = + PACKAGE_CL.addExternalSymbol("SIMPLE-STRING-P"); + public static final Symbol SIMPLE_TYPE_ERROR = + PACKAGE_CL.addExternalSymbol("SIMPLE-TYPE-ERROR"); + public static final Symbol SIMPLE_VECTOR = + PACKAGE_CL.addExternalSymbol("SIMPLE-VECTOR"); + public static final Symbol SIMPLE_VECTOR_P = + PACKAGE_CL.addExternalSymbol("SIMPLE-VECTOR-P"); + public static final Symbol SIMPLE_WARNING = + PACKAGE_CL.addExternalSymbol("SIMPLE-WARNING"); + public static final Symbol SIN = + PACKAGE_CL.addExternalSymbol("SIN"); + public static final Symbol SINGLE_FLOAT = + PACKAGE_CL.addExternalSymbol("SINGLE-FLOAT"); + public static final Symbol SINGLE_FLOAT_EPSILON = + PACKAGE_CL.addExternalSymbol("SINGLE-FLOAT-EPSILON"); + public static final Symbol SINGLE_FLOAT_NEGATIVE_EPSILON = + PACKAGE_CL.addExternalSymbol("SINGLE-FLOAT-NEGATIVE-EPSILON"); + public static final Symbol SINH = + PACKAGE_CL.addExternalSymbol("SINH"); + public static final Symbol SIXTH = + PACKAGE_CL.addExternalSymbol("SIXTH"); + public static final Symbol SLEEP = + PACKAGE_CL.addExternalSymbol("SLEEP"); + public static final Symbol SLOT_BOUNDP = + PACKAGE_CL.addExternalSymbol("SLOT-BOUNDP"); + public static final Symbol SLOT_EXISTS_P = + PACKAGE_CL.addExternalSymbol("SLOT-EXISTS-P"); + public static final Symbol SLOT_MAKUNBOUND = + PACKAGE_CL.addExternalSymbol("SLOT-MAKUNBOUND"); + public static final Symbol SLOT_MISSING = + PACKAGE_CL.addExternalSymbol("SLOT-MISSING"); + public static final Symbol SLOT_UNBOUND = + PACKAGE_CL.addExternalSymbol("SLOT-UNBOUND"); + public static final Symbol SLOT_VALUE = + PACKAGE_CL.addExternalSymbol("SLOT-VALUE"); + public static final Symbol SOFTWARE_TYPE = + PACKAGE_CL.addExternalSymbol("SOFTWARE-TYPE"); + public static final Symbol SOFTWARE_VERSION = + PACKAGE_CL.addExternalSymbol("SOFTWARE-VERSION"); + public static final Symbol SOME = + PACKAGE_CL.addExternalSymbol("SOME"); + public static final Symbol SORT = + PACKAGE_CL.addExternalSymbol("SORT"); + public static final Symbol SPACE = + PACKAGE_CL.addExternalSymbol("SPACE"); + public static final Symbol SPECIAL = + PACKAGE_CL.addExternalSymbol("SPECIAL"); + public static final Symbol SPECIAL_OPERATOR_P = + PACKAGE_CL.addExternalSymbol("SPECIAL-OPERATOR-P"); + public static final Symbol SPEED = + PACKAGE_CL.addExternalSymbol("SPEED"); + public static final Symbol SQRT = + PACKAGE_CL.addExternalSymbol("SQRT"); + public static final Symbol STABLE_SORT = + PACKAGE_CL.addExternalSymbol("STABLE-SORT"); + public static final Symbol STANDARD = + PACKAGE_CL.addExternalSymbol("STANDARD"); + public static final Symbol STANDARD_CHAR = + PACKAGE_CL.addExternalSymbol("STANDARD-CHAR"); + public static final Symbol STANDARD_CHAR_P = + PACKAGE_CL.addExternalSymbol("STANDARD-CHAR-P"); + public static final Symbol STANDARD_CLASS = + PACKAGE_CL.addExternalSymbol("STANDARD-CLASS"); + public static final Symbol STANDARD_GENERIC_FUNCTION = + PACKAGE_CL.addExternalSymbol("STANDARD-GENERIC-FUNCTION"); + public static final Symbol STANDARD_METHOD = + PACKAGE_CL.addExternalSymbol("STANDARD-METHOD"); + public static final Symbol STANDARD_OBJECT = + PACKAGE_CL.addExternalSymbol("STANDARD-OBJECT"); + public static final Symbol STEP = + PACKAGE_CL.addExternalSymbol("STEP"); + public static final Symbol STORAGE_CONDITION = + PACKAGE_CL.addExternalSymbol("STORAGE-CONDITION"); + public static final Symbol STORE_VALUE = + PACKAGE_CL.addExternalSymbol("STORE-VALUE"); + public static final Symbol STREAM = + PACKAGE_CL.addExternalSymbol("STREAM"); + public static final Symbol STREAM_ELEMENT_TYPE = + PACKAGE_CL.addExternalSymbol("STREAM-ELEMENT-TYPE"); + public static final Symbol STREAM_ERROR = + PACKAGE_CL.addExternalSymbol("STREAM-ERROR"); + public static final Symbol STREAM_ERROR_STREAM = + PACKAGE_CL.addExternalSymbol("STREAM-ERROR-STREAM"); + public static final Symbol STREAM_EXTERNAL_FORMAT = + PACKAGE_CL.addExternalSymbol("STREAM-EXTERNAL-FORMAT"); + public static final Symbol STREAMP = + PACKAGE_CL.addExternalSymbol("STREAMP"); + public static final Symbol STRING = + PACKAGE_CL.addExternalSymbol("STRING"); + public static final Symbol STRING_CAPITALIZE = + PACKAGE_CL.addExternalSymbol("STRING-CAPITALIZE"); + public static final Symbol STRING_DOWNCASE = + PACKAGE_CL.addExternalSymbol("STRING-DOWNCASE"); + public static final Symbol STRING_EQUAL = + PACKAGE_CL.addExternalSymbol("STRING-EQUAL"); + public static final Symbol STRING_GREATERP = + PACKAGE_CL.addExternalSymbol("STRING-GREATERP"); + public static final Symbol STRING_LEFT_TRIM = + PACKAGE_CL.addExternalSymbol("STRING-LEFT-TRIM"); + public static final Symbol STRING_LESSP = + PACKAGE_CL.addExternalSymbol("STRING-LESSP"); + public static final Symbol STRING_NOT_EQUAL = + PACKAGE_CL.addExternalSymbol("STRING-NOT-EQUAL"); + public static final Symbol STRING_NOT_GREATERP = + PACKAGE_CL.addExternalSymbol("STRING-NOT-GREATERP"); + public static final Symbol STRING_NOT_LESSP = + PACKAGE_CL.addExternalSymbol("STRING-NOT-LESSP"); + public static final Symbol STRING_RIGHT_TRIM = + PACKAGE_CL.addExternalSymbol("STRING-RIGHT-TRIM"); + public static final Symbol STRING_STREAM = + PACKAGE_CL.addExternalSymbol("STRING-STREAM"); + public static final Symbol STRING_TRIM = + PACKAGE_CL.addExternalSymbol("STRING-TRIM"); + public static final Symbol STRING_UPCASE = + PACKAGE_CL.addExternalSymbol("STRING-UPCASE"); + public static final Symbol STRING_NE = + PACKAGE_CL.addExternalSymbol("STRING/="); + public static final Symbol STRING_LT = + PACKAGE_CL.addExternalSymbol("STRING<"); + public static final Symbol STRING_LE = + PACKAGE_CL.addExternalSymbol("STRING<="); + public static final Symbol STRING_EQUALS = + PACKAGE_CL.addExternalSymbol("STRING="); + public static final Symbol STRING_GT = + PACKAGE_CL.addExternalSymbol("STRING>"); + public static final Symbol STRING_GE = + PACKAGE_CL.addExternalSymbol("STRING>="); + public static final Symbol STRINGP = + PACKAGE_CL.addExternalSymbol("STRINGP"); + public static final Symbol STRUCTURE = + PACKAGE_CL.addExternalSymbol("STRUCTURE"); + public static final Symbol STRUCTURE_CLASS = + PACKAGE_CL.addExternalSymbol("STRUCTURE-CLASS"); + public static final Symbol STRUCTURE_OBJECT = + PACKAGE_CL.addExternalSymbol("STRUCTURE-OBJECT"); + public static final Symbol STYLE_WARNING = + PACKAGE_CL.addExternalSymbol("STYLE-WARNING"); + public static final Symbol SUBLIS = + PACKAGE_CL.addExternalSymbol("SUBLIS"); + public static final Symbol SUBSEQ = + PACKAGE_CL.addExternalSymbol("SUBSEQ"); + public static final Symbol SUBSETP = + PACKAGE_CL.addExternalSymbol("SUBSETP"); + public static final Symbol SUBST = + PACKAGE_CL.addExternalSymbol("SUBST"); + public static final Symbol SUBST_IF = + PACKAGE_CL.addExternalSymbol("SUBST-IF"); + public static final Symbol SUBST_IF_NOT = + PACKAGE_CL.addExternalSymbol("SUBST-IF-NOT"); + public static final Symbol SUBSTITUTE = + PACKAGE_CL.addExternalSymbol("SUBSTITUTE"); + public static final Symbol SUBSTITUTE_IF = + PACKAGE_CL.addExternalSymbol("SUBSTITUTE-IF"); + public static final Symbol SUBSTITUTE_IF_NOT = + PACKAGE_CL.addExternalSymbol("SUBSTITUTE-IF-NOT"); + public static final Symbol SUBTYPEP = + PACKAGE_CL.addExternalSymbol("SUBTYPEP"); + public static final Symbol SVREF = + PACKAGE_CL.addExternalSymbol("SVREF"); + public static final Symbol SXHASH = + PACKAGE_CL.addExternalSymbol("SXHASH"); + public static final Symbol SYMBOL = + PACKAGE_CL.addExternalSymbol("SYMBOL"); + public static final Symbol SYMBOL_FUNCTION = + PACKAGE_CL.addExternalSymbol("SYMBOL-FUNCTION"); + public static final Symbol SYMBOL_MACROLET = + PACKAGE_CL.addExternalSymbol("SYMBOL-MACROLET"); + public static final Symbol SYMBOL_NAME = + PACKAGE_CL.addExternalSymbol("SYMBOL-NAME"); + public static final Symbol SYMBOL_PACKAGE = + PACKAGE_CL.addExternalSymbol("SYMBOL-PACKAGE"); + public static final Symbol SYMBOL_PLIST = + PACKAGE_CL.addExternalSymbol("SYMBOL-PLIST"); + public static final Symbol SYMBOL_VALUE = + PACKAGE_CL.addExternalSymbol("SYMBOL-VALUE"); + public static final Symbol SYMBOLP = + PACKAGE_CL.addExternalSymbol("SYMBOLP"); + public static final Symbol SYNONYM_STREAM = + PACKAGE_CL.addExternalSymbol("SYNONYM-STREAM"); + public static final Symbol SYNONYM_STREAM_SYMBOL = + PACKAGE_CL.addExternalSymbol("SYNONYM-STREAM-SYMBOL"); + public static final Symbol T = + PACKAGE_CL.addExternalSymbol("T"); + public static final Symbol TAGBODY = + PACKAGE_CL.addExternalSymbol("TAGBODY"); + public static final Symbol TAILP = + PACKAGE_CL.addExternalSymbol("TAILP"); + public static final Symbol TAN = + PACKAGE_CL.addExternalSymbol("TAN"); + public static final Symbol TANH = + PACKAGE_CL.addExternalSymbol("TANH"); + public static final Symbol TENTH = + PACKAGE_CL.addExternalSymbol("TENTH"); + public static final Symbol TERPRI = + PACKAGE_CL.addExternalSymbol("TERPRI"); + public static final Symbol THE = + PACKAGE_CL.addExternalSymbol("THE"); + public static final Symbol THIRD = + PACKAGE_CL.addExternalSymbol("THIRD"); + public static final Symbol THROW = + PACKAGE_CL.addExternalSymbol("THROW"); + public static final Symbol TIME = + PACKAGE_CL.addExternalSymbol("TIME"); + public static final Symbol TRACE = + PACKAGE_CL.addExternalSymbol("TRACE"); + public static final Symbol TRANSLATE_LOGICAL_PATHNAME = + PACKAGE_CL.addExternalSymbol("TRANSLATE-LOGICAL-PATHNAME"); + public static final Symbol TRANSLATE_PATHNAME = + PACKAGE_CL.addExternalSymbol("TRANSLATE-PATHNAME"); + public static final Symbol TREE_EQUAL = + PACKAGE_CL.addExternalSymbol("TREE-EQUAL"); + public static final Symbol TRUENAME = + PACKAGE_CL.addExternalSymbol("TRUENAME"); + public static final Symbol TRUNCATE = + PACKAGE_CL.addExternalSymbol("TRUNCATE"); + public static final Symbol TWO_WAY_STREAM = + PACKAGE_CL.addExternalSymbol("TWO-WAY-STREAM"); + public static final Symbol TWO_WAY_STREAM_INPUT_STREAM = + PACKAGE_CL.addExternalSymbol("TWO-WAY-STREAM-INPUT-STREAM"); + public static final Symbol TWO_WAY_STREAM_OUTPUT_STREAM = + PACKAGE_CL.addExternalSymbol("TWO-WAY-STREAM-OUTPUT-STREAM"); + public static final Symbol TYPE = + PACKAGE_CL.addExternalSymbol("TYPE"); + public static final Symbol TYPE_ERROR = + PACKAGE_CL.addExternalSymbol("TYPE-ERROR"); + public static final Symbol TYPE_ERROR_DATUM = + PACKAGE_CL.addExternalSymbol("TYPE-ERROR-DATUM"); + public static final Symbol TYPE_ERROR_EXPECTED_TYPE = + PACKAGE_CL.addExternalSymbol("TYPE-ERROR-EXPECTED-TYPE"); + public static final Symbol TYPE_OF = + PACKAGE_CL.addExternalSymbol("TYPE-OF"); + public static final Symbol TYPECASE = + PACKAGE_CL.addExternalSymbol("TYPECASE"); + public static final Symbol TYPEP = + PACKAGE_CL.addExternalSymbol("TYPEP"); + public static final Symbol UNBOUND_SLOT = + PACKAGE_CL.addExternalSymbol("UNBOUND-SLOT"); + public static final Symbol UNBOUND_SLOT_INSTANCE = + PACKAGE_CL.addExternalSymbol("UNBOUND-SLOT-INSTANCE"); + public static final Symbol UNBOUND_VARIABLE = + PACKAGE_CL.addExternalSymbol("UNBOUND-VARIABLE"); + public static final Symbol UNDEFINED_FUNCTION = + PACKAGE_CL.addExternalSymbol("UNDEFINED-FUNCTION"); + public static final Symbol UNEXPORT = + PACKAGE_CL.addExternalSymbol("UNEXPORT"); + public static final Symbol UNINTERN = + PACKAGE_CL.addExternalSymbol("UNINTERN"); + public static final Symbol UNION = + PACKAGE_CL.addExternalSymbol("UNION"); + public static final Symbol UNLESS = + PACKAGE_CL.addExternalSymbol("UNLESS"); + public static final Symbol UNREAD_CHAR = + PACKAGE_CL.addExternalSymbol("UNREAD-CHAR"); + public static final Symbol UNSIGNED_BYTE = + PACKAGE_CL.addExternalSymbol("UNSIGNED-BYTE"); + public static final Symbol UNTRACE = + PACKAGE_CL.addExternalSymbol("UNTRACE"); + public static final Symbol UNUSE_PACKAGE = + PACKAGE_CL.addExternalSymbol("UNUSE-PACKAGE"); + public static final Symbol UNWIND_PROTECT = + PACKAGE_CL.addExternalSymbol("UNWIND-PROTECT"); + public static final Symbol UPDATE_INSTANCE_FOR_DIFFERENT_CLASS = + PACKAGE_CL.addExternalSymbol("UPDATE-INSTANCE-FOR-DIFFERENT-CLASS"); + public static final Symbol UPDATE_INSTANCE_FOR_REDEFINED_CLASS = + PACKAGE_CL.addExternalSymbol("UPDATE-INSTANCE-FOR-REDEFINED-CLASS"); + public static final Symbol UPGRADED_ARRAY_ELEMENT_TYPE = + PACKAGE_CL.addExternalSymbol("UPGRADED-ARRAY-ELEMENT-TYPE"); + public static final Symbol UPGRADED_COMPLEX_PART_TYPE = + PACKAGE_CL.addExternalSymbol("UPGRADED-COMPLEX-PART-TYPE"); + public static final Symbol UPPER_CASE_P = + PACKAGE_CL.addExternalSymbol("UPPER-CASE-P"); + public static final Symbol USE_PACKAGE = + PACKAGE_CL.addExternalSymbol("USE-PACKAGE"); + public static final Symbol USE_VALUE = + PACKAGE_CL.addExternalSymbol("USE-VALUE"); + public static final Symbol USER_HOMEDIR_PATHNAME = + PACKAGE_CL.addExternalSymbol("USER-HOMEDIR-PATHNAME"); + public static final Symbol VALUES = + PACKAGE_CL.addExternalSymbol("VALUES"); + public static final Symbol VALUES_LIST = + PACKAGE_CL.addExternalSymbol("VALUES-LIST"); + public static final Symbol VARIABLE = + PACKAGE_CL.addExternalSymbol("VARIABLE"); + public static final Symbol VECTOR = + PACKAGE_CL.addExternalSymbol("VECTOR"); + public static final Symbol VECTOR_POP = + PACKAGE_CL.addExternalSymbol("VECTOR-POP"); + public static final Symbol VECTOR_PUSH = + PACKAGE_CL.addExternalSymbol("VECTOR-PUSH"); + public static final Symbol VECTOR_PUSH_EXTEND = + PACKAGE_CL.addExternalSymbol("VECTOR-PUSH-EXTEND"); + public static final Symbol VECTORP = + PACKAGE_CL.addExternalSymbol("VECTORP"); + public static final Symbol WARN = + PACKAGE_CL.addExternalSymbol("WARN"); + public static final Symbol WARNING = + PACKAGE_CL.addExternalSymbol("WARNING"); + public static final Symbol WHEN = + PACKAGE_CL.addExternalSymbol("WHEN"); + public static final Symbol WILD_PATHNAME_P = + PACKAGE_CL.addExternalSymbol("WILD-PATHNAME-P"); + public static final Symbol WITH_ACCESSORS = + PACKAGE_CL.addExternalSymbol("WITH-ACCESSORS"); + public static final Symbol WITH_COMPILATION_UNIT = + PACKAGE_CL.addExternalSymbol("WITH-COMPILATION-UNIT"); + public static final Symbol WITH_CONDITION_RESTARTS = + PACKAGE_CL.addExternalSymbol("WITH-CONDITION-RESTARTS"); + public static final Symbol WITH_HASH_TABLE_ITERATOR = + PACKAGE_CL.addExternalSymbol("WITH-HASH-TABLE-ITERATOR"); + public static final Symbol WITH_INPUT_FROM_STRING = + PACKAGE_CL.addExternalSymbol("WITH-INPUT-FROM-STRING"); + public static final Symbol WITH_OPEN_FILE = + PACKAGE_CL.addExternalSymbol("WITH-OPEN-FILE"); + public static final Symbol WITH_OPEN_STREAM = + PACKAGE_CL.addExternalSymbol("WITH-OPEN-STREAM"); + public static final Symbol WITH_OUTPUT_TO_STRING = + PACKAGE_CL.addExternalSymbol("WITH-OUTPUT-TO-STRING"); + public static final Symbol WITH_PACKAGE_ITERATOR = + PACKAGE_CL.addExternalSymbol("WITH-PACKAGE-ITERATOR"); + public static final Symbol WITH_SIMPLE_RESTART = + PACKAGE_CL.addExternalSymbol("WITH-SIMPLE-RESTART"); + public static final Symbol WITH_SLOTS = + PACKAGE_CL.addExternalSymbol("WITH-SLOTS"); + public static final Symbol WITH_STANDARD_IO_SYNTAX = + PACKAGE_CL.addExternalSymbol("WITH-STANDARD-IO-SYNTAX"); + public static final Symbol WRITE = + PACKAGE_CL.addExternalSymbol("WRITE"); + public static final Symbol WRITE_BYTE = + PACKAGE_CL.addExternalSymbol("WRITE-BYTE"); + public static final Symbol WRITE_CHAR = + PACKAGE_CL.addExternalSymbol("WRITE-CHAR"); + public static final Symbol WRITE_LINE = + PACKAGE_CL.addExternalSymbol("WRITE-LINE"); + public static final Symbol WRITE_SEQUENCE = + PACKAGE_CL.addExternalSymbol("WRITE-SEQUENCE"); + public static final Symbol WRITE_STRING = + PACKAGE_CL.addExternalSymbol("WRITE-STRING"); + public static final Symbol WRITE_TO_STRING = + PACKAGE_CL.addExternalSymbol("WRITE-TO-STRING"); + public static final Symbol Y_OR_N_P = + PACKAGE_CL.addExternalSymbol("Y-OR-N-P"); + public static final Symbol YES_OR_NO_P = + PACKAGE_CL.addExternalSymbol("YES-OR-NO-P"); + public static final Symbol ZEROP = + PACKAGE_CL.addExternalSymbol("ZEROP"); + // End of CL symbols. + + // Extensions. + public static final Symbol MOST_POSITIVE_JAVA_LONG = + PACKAGE_EXT.addExternalSymbol("MOST-POSITIVE-JAVA-LONG"); + public static final Symbol MOST_NEGATIVE_JAVA_LONG= + PACKAGE_EXT.addExternalSymbol("MOST-NEGATIVE-JAVA-LONG"); + public static final Symbol SINGLE_FLOAT_POSITIVE_INFINITY = + PACKAGE_EXT.addExternalSymbol("SINGLE-FLOAT-POSITIVE-INFINITY"); + public static final Symbol SINGLE_FLOAT_NEGATIVE_INFINITY = + PACKAGE_EXT.addExternalSymbol("SINGLE-FLOAT-NEGATIVE-INFINITY"); + public static final Symbol DOUBLE_FLOAT_POSITIVE_INFINITY = + PACKAGE_EXT.addExternalSymbol("DOUBLE-FLOAT-POSITIVE-INFINITY"); + public static final Symbol DOUBLE_FLOAT_NEGATIVE_INFINITY = + PACKAGE_EXT.addExternalSymbol("DOUBLE-FLOAT-NEGATIVE-INFINITY"); + public static final Symbol STYLE_WARN = + PACKAGE_EXT.addExternalSymbol("STYLE-WARN"); + public static final Symbol MEMQ = + PACKAGE_EXT.addExternalSymbol("MEMQ"); + public static final Symbol MEMQL = + PACKAGE_EXT.addExternalSymbol("MEMQL"); + public static final Symbol COMPILER_ERROR = + PACKAGE_EXT.addExternalSymbol("COMPILER-ERROR"); + public static final Symbol COMPILER_UNSUPPORTED_FEATURE_ERROR = + PACKAGE_EXT.addExternalSymbol("COMPILER-UNSUPPORTED-FEATURE-ERROR"); + public static final Symbol MUTEX = + PACKAGE_EXT.addExternalSymbol("MUTEX"); + public static final Symbol THREAD = + PACKAGE_EXT.addExternalSymbol("THREAD"); + public static final Symbol SUPPRESS_COMPILER_WARNINGS = + PACKAGE_EXT.addExternalSymbol("*SUPPRESS-COMPILER-WARNINGS*"); + public static final Symbol NEQ = + PACKAGE_EXT.addExternalSymbol("NEQ"); + public static final Symbol ADJOIN_EQL = + PACKAGE_EXT.addExternalSymbol("ADJOIN-EQL"); + public static final Symbol CHARACTER_DESIGNATOR = + PACKAGE_EXT.addExternalSymbol("CHARACTER-DESIGNATOR"); + public static final Symbol INTERRUPT_LISP = + PACKAGE_EXT.addExternalSymbol("INTERRUPT-LISP"); + public static final Symbol GETENV = + PACKAGE_EXT.addExternalSymbol("GETENV"); + + // MOP. + public static final Symbol STANDARD_READER_METHOD = + PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); + + // Java interface. + public static final Symbol JAVA_EXCEPTION = + PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION"); + public static final Symbol JAVA_EXCEPTION_CAUSE = + PACKAGE_JAVA.addExternalSymbol("JAVA-EXCEPTION-CAUSE"); + public static final Symbol JAVA_OBJECT = + PACKAGE_JAVA.addExternalSymbol("JAVA-OBJECT"); + public static final Symbol JAVA_CLASS = + PACKAGE_JAVA.addExternalSymbol("JAVA-CLASS"); + public static final Symbol JCALL = + PACKAGE_JAVA.addExternalSymbol("JCALL"); + public static final Symbol JCALL_RAW = + PACKAGE_JAVA.addExternalSymbol("JCALL-RAW"); + public static final Symbol JCLASS = + PACKAGE_JAVA.addExternalSymbol("JCLASS"); + public static final Symbol JCLASS_NAME = + PACKAGE_JAVA.addExternalSymbol("JCLASS-NAME"); + public static final Symbol JCLASS_OF = + PACKAGE_JAVA.addExternalSymbol("JCLASS-OF"); + public static final Symbol JMETHOD_RETURN_TYPE = + PACKAGE_JAVA.addExternalSymbol("JMETHOD-RETURN-TYPE"); + + // External symbols in SYSTEM package. + public static final Symbol ENVIRONMENT = + PACKAGE_SYS.addExternalSymbol("ENVIRONMENT"); + public static final Symbol FORWARD_REFERENCED_CLASS = + PACKAGE_SYS.addExternalSymbol("FORWARD-REFERENCED-CLASS"); + public static final Symbol MAILBOX = + PACKAGE_EXT.addExternalSymbol("MAILBOX"); + public static final Symbol NIL_VECTOR = + PACKAGE_EXT.addExternalSymbol("NIL-VECTOR"); + public static final Symbol SLIME_INPUT_STREAM = + PACKAGE_EXT.addExternalSymbol("SLIME-INPUT-STREAM"); + public static final Symbol SLIME_OUTPUT_STREAM = + PACKAGE_EXT.addExternalSymbol("SLIME-OUTPUT-STREAM"); + public static final Symbol CLASS_BYTES = + PACKAGE_SYS.addExternalSymbol("CLASS-BYTES"); + public static final Symbol _CLASS_SLOTS = + PACKAGE_SYS.addExternalSymbol("%CLASS-SLOTS"); + public static final Symbol LAYOUT = + PACKAGE_SYS.addExternalSymbol("LAYOUT"); + public static final Symbol NAMED_LAMBDA = + PACKAGE_SYS.addExternalSymbol("NAMED-LAMBDA"); + public static final Symbol OUTPUT_OBJECT = + PACKAGE_SYS.addExternalSymbol("OUTPUT-OBJECT"); + public static final Symbol SET_CLASS_SLOTS = + PACKAGE_SYS.addExternalSymbol("SET-CLASS-SLOTS"); + public static final Symbol SETF_FUNCTION = + PACKAGE_SYS.addExternalSymbol("SETF-FUNCTION"); + public static final Symbol SETF_INVERSE = + PACKAGE_SYS.addExternalSymbol("SETF-INVERSE"); + public static final Symbol SLOT_DEFINITION = + PACKAGE_SYS.addExternalSymbol("SLOT-DEFINITION"); + public static final Symbol _SLOT_DEFINITION_NAME = + PACKAGE_SYS.addExternalSymbol("%SLOT-DEFINITION-NAME"); + public static final Symbol _SLOT_DEFINITION_INITARGS = + PACKAGE_SYS.addExternalSymbol("%SLOT-DEFINITION-INITARGS"); + public static final Symbol _SLOT_DEFINITION_INITFUNCTION = + PACKAGE_SYS.addExternalSymbol("%SLOT-DEFINITION-INITFUNCTION"); + public static final Symbol _DOCUMENTATION = + PACKAGE_SYS.addExternalSymbol("%DOCUMENTATION"); + public static final Symbol STD_SLOT_BOUNDP = + PACKAGE_SYS.addExternalSymbol("STD-SLOT-BOUNDP"); + public static final Symbol STD_SLOT_VALUE = + PACKAGE_SYS.addExternalSymbol("STD-SLOT-VALUE"); + public static final Symbol SET_STD_SLOT_VALUE = + PACKAGE_SYS.addExternalSymbol("SET-STD-SLOT-VALUE"); + public static final Symbol SUBCLASSP = + PACKAGE_SYS.addExternalSymbol("SUBCLASSP"); + public static final Symbol GETHASH1 = + PACKAGE_SYS.addExternalSymbol("GETHASH1"); + public static final Symbol PUTHASH = + PACKAGE_SYS.addExternalSymbol("PUTHASH"); + public static final Symbol UNDEFINED_FUNCTION_CALLED = + PACKAGE_SYS.addExternalSymbol("UNDEFINED-FUNCTION-CALLED"); + public static final Symbol SET_CHAR = + PACKAGE_SYS.addExternalSymbol("SET-CHAR"); + public static final Symbol SET_SCHAR = + PACKAGE_SYS.addExternalSymbol("SET-SCHAR"); + + // Internal symbols in SYSTEM package. + public static final Symbol BACKQUOTE_MACRO = + PACKAGE_SYS.addInternalSymbol("BACKQUOTE-MACRO"); + public static final Symbol CASE_FROB_STREAM = + PACKAGE_SYS.addInternalSymbol("CASE-FROB-STREAM"); + public static final Symbol CAUSE = + PACKAGE_SYS.addInternalSymbol("CAUSE"); + public static final Symbol COMMA_MACRO = + PACKAGE_SYS.addInternalSymbol("COMMA-MACRO"); + public static final Symbol DATUM = + PACKAGE_SYS.addInternalSymbol("DATUM"); + public static final Symbol EXPECTED_TYPE = + PACKAGE_SYS.addInternalSymbol("EXPECTED-TYPE"); + public static final Symbol FORMAT_ARGUMENTS = + PACKAGE_SYS.addInternalSymbol("FORMAT-ARGUMENTS"); + public static final Symbol FORMAT_CONTROL = + PACKAGE_SYS.addInternalSymbol("FORMAT-CONTROL"); + public static final Symbol FSET = + PACKAGE_SYS.addInternalSymbol("FSET"); + public static final Symbol INSTANCE = + PACKAGE_SYS.addInternalSymbol("INSTANCE"); + public static final Symbol MACROEXPAND_MACRO = + PACKAGE_SYS.addInternalSymbol("MACROEXPAND-MACRO"); + public static final Symbol NAME = + PACKAGE_SYS.addInternalSymbol("NAME"); + public static final Symbol OBJECT = + PACKAGE_SYS.addInternalSymbol("OBJECT"); + public static final Symbol OPERANDS = + PACKAGE_SYS.addInternalSymbol("OPERANDS"); + public static final Symbol OPERATION = + PACKAGE_SYS.addInternalSymbol("OPERATION"); + public static final Symbol _SOURCE = + PACKAGE_SYS.addInternalSymbol("%SOURCE"); + public static final Symbol SOCKET_STREAM = + PACKAGE_SYS.addInternalSymbol("SOCKET-STREAM"); + public static final Symbol STRING_INPUT_STREAM = + PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM"); + public static final Symbol STRING_OUTPUT_STREAM = + PACKAGE_SYS.addInternalSymbol("STRING-OUTPUT-STREAM"); + + // CDR6 + public static final Symbol _INSPECTOR_HOOK_ = + PACKAGE_EXT.addExternalSymbol("*INSPECTOR-HOOK*"); + +} Added: branches/save-image/src/org/armedbear/lisp/SymbolHashTable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SymbolHashTable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,234 @@ +/* + * SymbolHashTable.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: SymbolHashTable.java 11697 2009-03-05 23:12:24Z astalla $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.ArrayList; +import java.util.List; + +public final class SymbolHashTable implements java.io.Serializable +{ + private static final float LOAD_FACTOR = 0.75f; + + private int threshold; + private HashEntry[] buckets; + private int count; + + private int mask; + + public SymbolHashTable(int size) + { + buckets = new HashEntry[calculateInitialCapacity(size)]; + threshold = (int) (size * LOAD_FACTOR); + mask = buckets.length - 1; + } + + private static int calculateInitialCapacity(int size) + { + int capacity = 1; + while (capacity < size) + capacity <<= 1; + return capacity; + } + + public Symbol get(SimpleString key) + { + HashEntry e = buckets[key.sxhash() & mask]; + while (e != null) { + try { + if (key.equal(e.symbol.name)) + return e.symbol; // Return the symbol. + } + catch (Throwable t) { + Debug.trace(t); // Shouldn't happen. + } + e = e.next; + } + return null; + } + + public Symbol get(SimpleString key, int hash) + { + HashEntry e = buckets[hash & mask]; + while (e != null) { + try { + if (key.equal(e.symbol.name)) + return e.symbol; // Return the symbol. + } + catch (Throwable t) { + Debug.trace(t); // Shouldn't happen. + } + e = e.next; + } + return null; + } + + public void put(final SimpleString key, final Symbol symbol) + { + int index = key.sxhash() & mask; + HashEntry e = buckets[index]; + while (e != null) { + try { + if (key.equal(e.symbol.name)) { + if (e.symbol != symbol) { + Debug.trace("replacing existing key for " + key.getStringValue() + + " in package " + e.symbol.getPackage().writeToString()); + Thread.dumpStack(); + e.symbol = symbol; + } + return; + } + } + catch (Throwable t) { + Debug.trace(t); // FIXME + } + e = e.next; + } + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); + // We need a new index for the bigger table. + index = key.sxhash() & mask; + } + e = new HashEntry(symbol); + e.next = buckets[index]; + buckets[index] = e; + } + + public void put(Symbol symbol) + { + int index = symbol.sxhash() & mask; + HashEntry e = buckets[index]; + while (e != null) { + try { + if (symbol.name.equal(e.symbol.name)) { + if (e.symbol != symbol) { + Debug.trace("replacing existing key for " + symbol.getName()); + Thread.dumpStack(); + e.symbol = symbol; // Replace existing key. + } + return; + } + } + catch (Throwable t) { + Debug.trace(t); // FIXME + } + e = e.next; + } + // Not found. We need to add a new entry. + if (++count > threshold) { + rehash(); + // Need a new hash value to suit the bigger table. + index = symbol.sxhash() & mask; + } + e = new HashEntry(symbol); + e.next = buckets[index]; + buckets[index] = e; + } + + public LispObject remove(LispObject key) + { + if (key instanceof Symbol) + key = ((Symbol)key).name; + int index = key.sxhash() & mask; + HashEntry e = buckets[index]; + HashEntry last = null; + while (e != null) { + try { + if (key.equal(e.symbol.name)) { + if (last == null) + buckets[index] = e.next; + else + last.next = e.next; + --count; + return e.symbol; // The key is the value! + } + } + catch (Throwable t) { + Debug.trace(t); // FIXME + } + last = e; + e = e.next; + } + return null; + } + + private void rehash() + { + HashEntry[] oldBuckets = buckets; + int newCapacity = buckets.length * 2; + threshold = (int) (newCapacity * LOAD_FACTOR); + buckets = new HashEntry[newCapacity]; + mask = buckets.length - 1; + for (int i = oldBuckets.length; i-- > 0;) { + HashEntry e = oldBuckets[i]; + while (e != null) { + final int index = e.symbol.sxhash() & mask; + HashEntry dest = buckets[index]; + if (dest != null) { + while (dest.next != null) + dest = dest.next; + dest.next = e; + } else + buckets[index] = e; + HashEntry next = e.next; + e.next = null; + e = next; + } + } + } + + public List getSymbols() + { + ArrayList list = new ArrayList(); + for (int i = 0; i < buckets.length; i++) { + HashEntry e = buckets[i]; + while (e != null) { + list.add(e.symbol); + e = e.next; + } + } + return list; + } + + private static class HashEntry implements java.io.Serializable + { + Symbol symbol; + HashEntry next; + + HashEntry(Symbol symbol) + { + this.symbol = symbol; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/SymbolMacro.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SymbolMacro.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +/* + * SymbolMacro.java + * + * Copyright (C) 2003 Peter Graves + * $Id: SymbolMacro.java 11441 2008-12-14 12:07:52Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SymbolMacro extends LispObject +{ + private LispObject expansion; + + public SymbolMacro(LispObject expansion) + { + this.expansion = expansion; + } + + public LispObject getExpansion() + { + return expansion; + } + +} Added: branches/save-image/src/org/armedbear/lisp/SynonymStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/SynonymStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,248 @@ +/* + * SynonymStream.java + * + * Copyright (C) 2004 Peter Graves + * $Id: SynonymStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class SynonymStream extends Stream +{ + private final Symbol symbol; + + private SynonymStream(Symbol symbol) + { + this.symbol = symbol; + } + + @Override + public boolean isInputStream() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).isInputStream(); + } + + @Override + public boolean isOutputStream() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).isOutputStream(); + } + + @Override + public boolean isCharacterInputStream() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).isCharacterInputStream(); + } + + @Override + public boolean isBinaryInputStream() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).isBinaryInputStream(); + } + + @Override + public boolean isCharacterOutputStream() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).isCharacterOutputStream(); + } + + @Override + public boolean isBinaryOutputStream() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).isBinaryOutputStream(); + } + + @Override + public LispObject typeOf() + { + return Symbol.SYNONYM_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.SYNONYM_STREAM; + } + + @Override + public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable + { + if (typeSpecifier == Symbol.SYNONYM_STREAM) + return T; + if (typeSpecifier == BuiltInClass.SYNONYM_STREAM) + return T; + return super.typep(typeSpecifier); + } + + @Override + public LispObject getElementType() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).getElementType(); + } + + @Override + public LispObject listen() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).listen(); + } + + @Override + public LispObject fileLength() throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).fileLength(); + } + + @Override + public LispObject fileStringLength(LispObject arg) throws ConditionThrowable + { + return checkStream(symbol.symbolValue()).fileStringLength(arg); + } + + @Override + protected int _readChar() throws ConditionThrowable + { + return checkStream(symbol.symbolValue())._readChar(); + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + checkStream(symbol.symbolValue())._unreadChar(n); + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + return checkStream(symbol.symbolValue())._charReady(); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + checkStream(symbol.symbolValue())._writeChar(c); + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + checkStream(symbol.symbolValue())._writeChars(chars, start, end); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + checkStream(symbol.symbolValue())._writeString(s); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + checkStream(symbol.symbolValue())._writeLine(s); + } + + // Reads an 8-bit byte. + @Override + public int _readByte() throws ConditionThrowable + { + return checkStream(symbol.symbolValue())._readByte(); + } + + // Writes an 8-bit byte. + @Override + public void _writeByte(int n) throws ConditionThrowable + { + checkStream(symbol.symbolValue())._writeByte(n); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + checkStream(symbol.symbolValue())._finishOutput(); + } + + @Override + public void _clearInput() throws ConditionThrowable + { + checkStream(symbol.symbolValue())._clearInput(); + } + + @Override + protected long _getFilePosition() throws ConditionThrowable + { + return checkStream(symbol.symbolValue())._getFilePosition(); + } + + @Override + protected boolean _setFilePosition(LispObject arg) throws ConditionThrowable + { + return checkStream(symbol.symbolValue())._setFilePosition(arg); + } + + @Override + public void _close() throws ConditionThrowable + { + checkStream(symbol.symbolValue())._close(); + } + + @Override + public String writeToString() throws ConditionThrowable + { + StringBuffer sb = new StringBuffer("SYNONYM-STREAM "); + sb.append(symbol.writeToString()); + return unreadableString(sb.toString()); + } + + // ### make-synonym-stream symbol => synonym-stream + private static final Primitive MAKE_SYNONYM_STREAM = + new Primitive("make-synonym-stream", "symbol") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new SynonymStream(checkSymbol(arg)); + } + }; + + // ### synonym-stream-symbol synonym-stream => symbol + private static final Primitive SYNONYM_STREAM_STREAMS = + new Primitive("synonym-stream-symbol", "synonym-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((SynonymStream)arg).symbol; + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.SYNONYM_STREAM)); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/ThreadDestroyed.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ThreadDestroyed.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,46 @@ +/* + * ThreadDestroyed.java + * + * Copyright (C) 2003 Peter Graves + * $Id: ThreadDestroyed.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class ThreadDestroyed extends ConditionThrowable +{ + public ThreadDestroyed() + { + } + + public ThreadDestroyed(String message) + { + super(message); + } +} Added: branches/save-image/src/org/armedbear/lisp/ThreadLock.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ThreadLock.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,109 @@ +/* + * ThreadLock.java + * + * Copyright (C) 2004 Peter Graves + * $Id: ThreadLock.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ThreadLock extends LispObject +{ + private LispThread thread; + + private void lock() throws ConditionThrowable + { + LispThread currentThread = LispThread.currentThread(); + if (!currentThread.equals(thread)) { + while (thread != null) { + synchronized(this) { + try { + wait(); + } catch(InterruptedException e) { + throw new RuntimeException(e); + } + } + } + thread = currentThread; + } + } + + private void unlock() throws ConditionThrowable + { + if (thread.equals(LispThread.currentThread())) { + synchronized(this) { + thread = null; + notifyAll(); + } + } + } + + @Override + public String writeToString() + { + return unreadableString("THREAD-LOCK"); + } + + // ### make-thread-lock + private static final Primitive MAKE_THREAD_LOCK = + new Primitive("make-thread-lock", PACKAGE_EXT, true) + { + @Override + public LispObject execute() throws ConditionThrowable + { + return new ThreadLock(); + } + }; + + // ### thread-lock lock + private static final Primitive THREAD_LOCK = + new Primitive("thread-lock", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + ThreadLock threadLock = (ThreadLock) arg; + threadLock.lock(); + return NIL; + } + }; + + // ### thread-unlock lock + private static final Primitive THREAD_UNLOCK = + new Primitive("thread-unlock", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + ThreadLock threadLock = (ThreadLock) arg; + threadLock.unlock(); + return NIL; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/Throw.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Throw.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,68 @@ +/* + * Throw.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: Throw.java 11526 2009-01-03 00:08:31Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Throw extends ConditionThrowable +{ + public final LispObject tag; + private final LispObject result; + private final LispObject[] values; + + public Throw(LispObject tag, LispObject result, LispThread thread) + throws ConditionThrowable + { + this.tag = tag; + this.result = result; + values = thread._values; + } + + public LispObject getResult(LispThread thread) throws ConditionThrowable + { + thread._values = values; + return result; + } + + @Override + public LispObject getCondition() throws ConditionThrowable + { + try { + return new ControlError("Attempt to throw to the nonexistent tag " + + tag.writeToString() + "."); + } + catch (Throwable t) { + Debug.trace(t); + return new Condition(); + } + } +} Added: branches/save-image/src/org/armedbear/lisp/Time.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Time.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,202 @@ +/* + * Time.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Time.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.lang.reflect.Method; +import java.util.Date; +import java.util.TimeZone; + +public final class Time extends Lisp +{ + private static final long getCurrentThreadUserTime() + { + try + { + Class c = Class.forName("org.armedbear.lisp.Native"); + Method m = c.getMethod("getCurrentThreadUserTime", (Class[]) null); + Object result = m.invoke((Object) null, (Object[]) null); + if (result instanceof Long) + return ((Long)result).longValue(); + } + catch (Throwable t) {} + return -1; + } + + private static final long getCurrentThreadSystemTime() + { + try + { + Class c = Class.forName("org.armedbear.lisp.Native"); + Method m = c.getMethod("getCurrentThreadSystemTime", (Class[]) null); + Object result = m.invoke((Object) null, (Object[]) null); + if (result instanceof Long) + return ((Long)result).longValue(); + } + catch (Throwable t) {} + return -1; + } + + // ### %time + private static final Primitive _TIME = + new Primitive("%time", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Cons.setCount(0); + long userStart = -1; + long systemStart = -1; + try + { + userStart = getCurrentThreadUserTime(); + systemStart = getCurrentThreadSystemTime(); + } + catch (Throwable t) {} + long realStart = System.currentTimeMillis(); + try + { + return arg.execute(); + } + finally + { + long realElapsed = System.currentTimeMillis() - realStart; + final long userStop; + final long systemStop; + if (userStart > 0) + { + userStop = getCurrentThreadUserTime(); + systemStop = getCurrentThreadSystemTime(); + } + else + { + userStop = -1; + systemStop = -1; + } + long count = Cons.getCount(); + Stream out = + checkCharacterOutputStream(Symbol.TRACE_OUTPUT.symbolValue()); + out.freshLine(); + FastStringBuffer sb = new FastStringBuffer(); + sb.append(String.valueOf((float)realElapsed / 1000)); + sb.append(" seconds real time"); + sb.append(System.getProperty("line.separator")); + if (userStart > 0) + { + sb.append(String.valueOf((float)(userStop - userStart) / 100)); + sb.append(" seconds user run time"); + sb.append(System.getProperty("line.separator")); + sb.append(String.valueOf((float)(systemStop - systemStart) / 100)); + sb.append(" seconds system run time"); + sb.append(System.getProperty("line.separator")); + } + sb.append(count); + sb.append(" cons cell"); + if (count != 1) + sb.append('s'); + sb.append(System.getProperty("line.separator")); + out._writeString(sb.toString()); + out._finishOutput(); + } + } + }; + + // ### get-internal-real-time + private static final Primitive GET_INTERNAL_REAL_TIME = + new Primitive("get-internal-real-time", "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + return number(System.currentTimeMillis()); + } + }; + + // ### get-internal-run-time + private static final Primitive GET_INTERNAL_RUN_TIME = + new Primitive("get-internal-run-time", "") + { + @Override + public LispObject execute() throws ConditionThrowable + { + if (Utilities.isPlatformUnix) + { + long userTime = -1; + long systemTime = -1; + try + { + userTime = getCurrentThreadUserTime(); + systemTime = getCurrentThreadSystemTime(); + } + catch (Throwable t) {} + if (userTime >= 0 && systemTime >= 0) + return number((userTime + systemTime) * 10); + } + return number(System.currentTimeMillis()); + } + }; + + // ### get-universal-time + private static final Primitive GET_UNIVERSAL_TIME = + new Primitive("get-universal-time", "") + { + @Override + public LispObject execute() + { + return number(System.currentTimeMillis() / 1000 + 2208988800L); + } + }; + + // ### default-time-zone => offset daylight-p + private static final Primitive DEFAULT_TIME_ZONE = + new Primitive("default-time-zone", PACKAGE_SYS, false) + { + @Override + public LispObject execute() throws ConditionThrowable + { + TimeZone tz = TimeZone.getDefault(); + //int offset = tz.getOffset(System.currentTimeMillis()); + // Classpath hasn't implemented TimeZone.getOffset(long). + int rawOffset = tz.getRawOffset(); + final boolean inDaylightTime = + tz.inDaylightTime(new Date(System.currentTimeMillis())); + if (inDaylightTime) + rawOffset += tz.getDSTSavings(); + // "Time zone values increase with motion to the west..." + // Convert milliseconds to hours. + return LispThread.currentThread().setValues( + new Fixnum(- rawOffset).divideBy(new Fixnum(3600000)), + inDaylightTime ? T : NIL); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/TwoWayStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/TwoWayStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,282 @@ +/* + * TwoWayStream.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: TwoWayStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class TwoWayStream extends Stream +{ + public final Stream in; + public final Stream out; + + public TwoWayStream(Stream in, Stream out) + { + this.in = in; + this.out = out; + isInputStream = true; + isOutputStream = true; + } + + public TwoWayStream(Stream in, Stream out, boolean interactive) + { + this(in, out); + setInteractive(interactive); + } + + @Override + public LispObject getElementType() throws ConditionThrowable + { + LispObject itype = in.getElementType(); + LispObject otype = out.getElementType(); + if (itype.equal(otype)) + return itype; + return list3(Symbol.AND, itype, otype); + } + + public Stream getInputStream() + { + return in; + } + + public Stream getOutputStream() + { + return out; + } + + @Override + public boolean isCharacterInputStream() throws ConditionThrowable + { + return in.isCharacterInputStream(); + } + + @Override + public boolean isBinaryInputStream() throws ConditionThrowable + { + return in.isBinaryInputStream(); + } + + @Override + public boolean isCharacterOutputStream() throws ConditionThrowable + { + return out.isCharacterOutputStream(); + } + + @Override + public boolean isBinaryOutputStream() throws ConditionThrowable + { + return out.isBinaryOutputStream(); + } + + @Override + public LispObject typeOf() + { + return Symbol.TWO_WAY_STREAM; + } + + @Override + public LispObject classOf() + { + return BuiltInClass.TWO_WAY_STREAM; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.TWO_WAY_STREAM) + return T; + if (type == BuiltInClass.TWO_WAY_STREAM) + return T; + return super.typep(type); + } + + // Returns -1 at end of file. + @Override + protected int _readChar() throws ConditionThrowable + { + return in._readChar(); + } + + @Override + protected void _unreadChar(int n) throws ConditionThrowable + { + in._unreadChar(n); + } + + @Override + protected boolean _charReady() throws ConditionThrowable + { + return in._charReady(); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + out._writeChar(c); + } + + @Override + public void _writeChars(char[] chars, int start, int end) + throws ConditionThrowable + { + out._writeChars(chars, start, end); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + out._writeString(s); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + out._writeLine(s); + } + + // Reads an 8-bit byte. + @Override + public int _readByte() throws ConditionThrowable + { + return in._readByte(); + } + + // Writes an 8-bit byte. + @Override + public void _writeByte(int n) throws ConditionThrowable + { + out._writeByte(n); + } + + @Override + public void _finishOutput() throws ConditionThrowable + { + out._finishOutput(); + } + + @Override + public void _clearInput() throws ConditionThrowable + { + in._clearInput(); + } + + @Override + public LispObject listen() throws ConditionThrowable + { + return in.listen(); + } + + @Override + public LispObject freshLine() throws ConditionThrowable + { + return out.freshLine(); + } + + @Override + public LispObject close(LispObject abort) throws ConditionThrowable + { + // "The effect of CLOSE on a constructed stream is to close the + // argument stream only. There is no effect on the constituents of + // composite streams." + setOpen(false); + return T; + } + + @Override + public String writeToString() throws ConditionThrowable + { + return unreadableString(Symbol.TWO_WAY_STREAM); + } + + // ### make-two-way-stream input-stream output-stream => two-way-stream + private static final Primitive MAKE_TWO_WAY_STREAM = + new Primitive(Symbol.MAKE_TWO_WAY_STREAM, "input-stream output-stream") + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final Stream in; + try { + in = (Stream) first; + } + catch (ClassCastException e) { + return type_error(first, Symbol.STREAM); + } + final Stream out; + try { + out = (Stream) second; + } + catch (ClassCastException e) { + return type_error(second, Symbol.STREAM); + } + if (!in.isInputStream()) + return type_error(in, list2(Symbol.SATISFIES, + Symbol.INPUT_STREAM_P)); + if (!out.isOutputStream()) + return type_error(out, list2(Symbol.SATISFIES, + Symbol.OUTPUT_STREAM_P)); + return new TwoWayStream(in, out); + } + }; + + // ### two-way-stream-input-stream two-way-stream => input-stream + private static final Primitive TWO_WAY_STREAM_INPUT_STREAM = + new Primitive(Symbol.TWO_WAY_STREAM_INPUT_STREAM, "two-way-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((TwoWayStream)arg).in; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.TWO_WAY_STREAM); + } + } + }; + + // ### two-way-stream-output-stream two-way-stream => output-stream + private static final Primitive TWO_WAY_STREAM_OUTPUT_STREAM = + new Primitive(Symbol.TWO_WAY_STREAM_OUTPUT_STREAM, "two-way-stream") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((TwoWayStream)arg).out; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.TWO_WAY_STREAM); + } + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/TypeError.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/TypeError.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,231 @@ +/* + * TypeError.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: TypeError.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class TypeError extends LispError +{ + public TypeError() throws ConditionThrowable + { + super(StandardClass.TYPE_ERROR); + } + + protected TypeError(LispClass cls) throws ConditionThrowable + { + super(cls); + } + + public TypeError(LispObject datum, LispObject expectedType) + throws ConditionThrowable + { + super(StandardClass.TYPE_ERROR); + setDatum(datum); + setExpectedType(expectedType); + } + + public TypeError(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.TYPE_ERROR); + initialize(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + LispObject datum = null; + LispObject expectedType = null; + LispObject first, second; + while (initArgs != NIL) { + first = initArgs.car(); + initArgs = initArgs.cdr(); + second = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.DATUM) { + if (datum == null) + datum = second; + } else if (first == Keyword.EXPECTED_TYPE) { + if (expectedType == null) + expectedType = second; + } + } + if (datum != null) + setDatum(datum); + if (expectedType != null) + setExpectedType(expectedType); + } + + public TypeError(String message) throws ConditionThrowable + { + super(StandardClass.TYPE_ERROR); + setFormatControl(message); + setDatum(NIL); + setExpectedType(NIL); + } + + public TypeError(String message, LispObject datum, LispObject expectedType) + throws ConditionThrowable + { + super(StandardClass.TYPE_ERROR); + setFormatControl(message); + setDatum(datum); + setExpectedType(expectedType); + } + + @Override + public LispObject typeOf() + { + return Symbol.TYPE_ERROR; + } + + @Override + public LispObject classOf() + { + return StandardClass.TYPE_ERROR; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.TYPE_ERROR) + return T; + if (type == StandardClass.TYPE_ERROR) + return T; + return super.typep(type); + } + + @Override + public String getMessage() + { + // FIXME + try { + final LispThread thread = LispThread.currentThread(); + final SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try { + String s = super.getMessage(); + if (s != null) + return s; + final LispObject datum = getDatum(); + final LispObject expectedType = getExpectedType(); + FastStringBuffer sb = new FastStringBuffer(); + String name = datum != null ? datum.writeToString() : null; + String type = null; + if (expectedType != null) + type = expectedType.writeToString(); + if (type != null) { + if (name != null) { + sb.append("The value "); + sb.append(name); + } else + sb.append("Value"); + sb.append(" is not of type "); + sb.append(type); + } else if (name != null) { + sb.append("Wrong type: "); + sb.append(name); + } + sb.append('.'); + return sb.toString(); + } + catch (Throwable t) { + // FIXME + Debug.trace(t); + return toString(); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + catch (Throwable t) { + return toString(); + } + } + + public final LispObject getDatum() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.DATUM); + } + + private final void setDatum(LispObject datum) throws ConditionThrowable + { + setInstanceSlotValue(Symbol.DATUM, datum); + } + + public final LispObject getExpectedType() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.EXPECTED_TYPE); + } + + private final void setExpectedType(LispObject expectedType) + throws ConditionThrowable + { + setInstanceSlotValue(Symbol.EXPECTED_TYPE, expectedType); + } + + // ### type-error-datum + private static final Primitive TYPE_ERROR_DATUM = + new Primitive(Symbol.TYPE_ERROR_DATUM, "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final StandardObject obj; + try { + obj = (StandardObject) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STANDARD_OBJECT); + } + return obj.getInstanceSlotValue(Symbol.DATUM); + } + }; + + // ### type-error-expected-type + private static final Primitive TYPE_ERROR_EXPECTED_TYPE = + new Primitive(Symbol.TYPE_ERROR_EXPECTED_TYPE, "condition") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final StandardObject obj; + try { + obj = (StandardObject) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STANDARD_OBJECT); + } + return obj.getInstanceSlotValue(Symbol.EXPECTED_TYPE); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/UnboundSlot.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/UnboundSlot.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,109 @@ +/* + * UnboundSlot.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: UnboundSlot.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class UnboundSlot extends CellError +{ + public UnboundSlot(LispObject initArgs) throws ConditionThrowable + { + super(StandardClass.UNBOUND_SLOT); + initialize(initArgs); + } + + @Override + protected void initialize(LispObject initArgs) throws ConditionThrowable + { + super.initialize(initArgs); + while (initArgs != NIL) { + LispObject first = initArgs.car(); + initArgs = initArgs.cdr(); + if (first == Keyword.INSTANCE) { + setInstance(initArgs.car()); + break; + } + initArgs = initArgs.cdr(); + } + } + + public LispObject getInstance() throws ConditionThrowable + { + return getInstanceSlotValue(Symbol.INSTANCE); + } + + private void setInstance(LispObject instance) throws ConditionThrowable + { + setInstanceSlotValue(Symbol.INSTANCE, instance); + } + + @Override + public String getMessage() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try { + FastStringBuffer sb = new FastStringBuffer("The slot "); + sb.append(getCellName().writeToString()); + sb.append(" is unbound in the object "); + sb.append(getInstance().writeToString()); + sb.append('.'); + return sb.toString(); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + @Override + public LispObject typeOf() + { + return Symbol.UNBOUND_SLOT; + } + + @Override + public LispObject classOf() + { + return StandardClass.UNBOUND_SLOT; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.UNBOUND_SLOT) + return T; + if (type == StandardClass.UNBOUND_SLOT) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/UnboundVariable.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/UnboundVariable.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,87 @@ +/* + * UnboundVariable.java + * + * Copyright (C) 2002-2006 Peter Graves + * $Id: UnboundVariable.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class UnboundVariable extends CellError +{ + // obj is either the unbound variable itself or an initArgs list. + public UnboundVariable(LispObject obj) throws ConditionThrowable + { + super(StandardClass.UNBOUND_VARIABLE); + if (obj instanceof Cons) + initialize(obj); + else + setCellName(obj); + } + + @Override + public String getMessage() + { + LispThread thread = LispThread.currentThread(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + StringBuffer sb = new StringBuffer("The variable "); + // FIXME + try + { + sb.append(getCellName().writeToString()); + } + catch (Throwable t) {} + sb.append(" is unbound."); + thread.lastSpecialBinding = lastSpecialBinding; + return sb.toString(); + } + + @Override + public LispObject typeOf() + { + return Symbol.UNBOUND_VARIABLE; + } + + @Override + public LispObject classOf() + { + return StandardClass.UNBOUND_VARIABLE; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.UNBOUND_VARIABLE) + return T; + if (type == StandardClass.UNBOUND_VARIABLE) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/UndefinedFunction.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/UndefinedFunction.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,78 @@ +/* + * UndefinedFunction.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: UndefinedFunction.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class UndefinedFunction extends CellError +{ + // obj is either the name of the undefined function or an initArgs list. + public UndefinedFunction(LispObject obj) throws ConditionThrowable + { + super(StandardClass.UNDEFINED_FUNCTION); + if (obj instanceof Cons) + initialize(obj); + else + setCellName(obj); + } + + @Override + public LispObject typeOf() + { + return Symbol.UNDEFINED_FUNCTION; + } + + @Override + public LispObject classOf() + { + return StandardClass.UNDEFINED_FUNCTION; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.UNDEFINED_FUNCTION) + return T; + if (type == StandardClass.UNDEFINED_FUNCTION) + return T; + return super.typep(type); + } + + @Override + public String getMessage() throws ConditionThrowable + { + FastStringBuffer sb = new FastStringBuffer("The function "); + sb.append(getCellName().writeToString()); + sb.append(" is undefined."); + return sb.toString(); + } +} Added: branches/save-image/src/org/armedbear/lisp/UpcaseStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/UpcaseStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +/* + * UpcaseStream.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: UpcaseStream.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class UpcaseStream extends CaseFrobStream +{ + public UpcaseStream(Stream target) throws ConditionThrowable + { + super(target); + } + + @Override + public void _writeChar(char c) throws ConditionThrowable + { + target._writeChar(LispCharacter.toUpperCase(c)); + } + + @Override + public void _writeString(String s) throws ConditionThrowable + { + target._writeString(s.toUpperCase()); + } + + @Override + public void _writeLine(String s) throws ConditionThrowable + { + target._writeLine(s.toUpperCase()); + } +} Added: branches/save-image/src/org/armedbear/lisp/Utilities.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Utilities.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,117 @@ +/* + * Utilities.java + * + * Copyright (C) 2003-2007 Peter Graves + * $Id: Utilities.java 11391 2008-11-15 22:38:34Z vvoutilainen $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.IOException; + +public final class Utilities extends Lisp +{ + public static final boolean isPlatformUnix; + public static final boolean isPlatformWindows; + + static { + String osName = System.getProperty("os.name"); + isPlatformUnix = osName.startsWith("Linux") || + osName.startsWith("Mac OS X") || osName.startsWith("Solaris") || + osName.startsWith("SunOS") || osName.startsWith("AIX") || + osName.startsWith("FreeBSD"); + isPlatformWindows = osName.startsWith("Windows"); + } + + public static boolean isFilenameAbsolute(String filename) + { + final int length = filename.length(); + if (length > 0) { + char c0 = filename.charAt(0); + if (c0 == '\\' || c0 == '/') + return true; + if (length > 2) { + if (isPlatformWindows) { + // Check for drive letter. + char c1 = filename.charAt(1); + if (c1 == ':') { + if (c0 >= 'a' && c0 <= 'z') + return true; + if (c0 >= 'A' && c0 <= 'Z') + return true; + } + } else { + // Unix. + if (filename.equals("~") || filename.startsWith("~/")) + return true; + } + } + } + return false; + } + + public static File getFile(Pathname pathname) throws ConditionThrowable + { + return getFile(pathname, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue())); + } + + public static File getFile(Pathname pathname, Pathname defaultPathname) + throws ConditionThrowable + { + Pathname merged = + Pathname.mergePathnames(pathname, defaultPathname, NIL); + String namestring = merged.getNamestring(); + if (namestring != null) + return new File(namestring); + error(new FileError("Pathname has no namestring: " + merged.writeToString(), + merged)); + // Not reached. + return null; + } + + public static Pathname getDirectoryPathname(File file) + throws ConditionThrowable + { + try { + String namestring = file.getCanonicalPath(); + if (namestring != null && namestring.length() > 0) { + if (namestring.charAt(namestring.length() - 1) != File.separatorChar) + namestring = namestring.concat(File.separator); + } + return new Pathname(namestring); + } + catch (IOException e) { + error(new LispError(e.getMessage())); + // Not reached. + return null; + } + } +} Added: branches/save-image/src/org/armedbear/lisp/Version.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Version.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,46 @@ +/* + * Version.java + * + * Copyright (C) 2003-2008 Peter Graves + * $Id: Version.java 11684 2009-02-22 23:17:19Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class Version +{ + private Version() + { + } + + public static String getVersion() + { + return "0.14.0-dev"; + } +} Added: branches/save-image/src/org/armedbear/lisp/Warning.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/Warning.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,68 @@ +/* + * Warning.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: Warning.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public class Warning extends Condition +{ + protected Warning() throws ConditionThrowable + { + } + + public Warning(LispObject initArgs) throws ConditionThrowable + { + super(initArgs); + } + + @Override + public LispObject typeOf() + { + return Symbol.WARNING; + } + + @Override + public LispObject classOf() + { + return StandardClass.WARNING; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.WARNING) + return T; + if (type == StandardClass.WARNING) + return T; + return super.typep(type); + } +} Added: branches/save-image/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,69 @@ +/* + * WrongNumberOfArgumentsException.java + * + * Copyright (C) 2002-2005 Peter Graves + * $Id: WrongNumberOfArgumentsException.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class WrongNumberOfArgumentsException extends ProgramError +{ + private final Operator operator; + + public WrongNumberOfArgumentsException(Operator operator) + throws ConditionThrowable + { + // This is really just an ordinary PROGRAM-ERROR, broken out into its + // own Java class as a convenience for the implementation. + super(StandardClass.PROGRAM_ERROR); + this.operator = operator; + setFormatControl(getMessage()); + setFormatArguments(NIL); + } + + @Override + public String getMessage() + { + FastStringBuffer sb = + new FastStringBuffer("Wrong number of arguments"); + LispObject lambdaName = operator.getLambdaName(); + if (lambdaName != null && lambdaName != NIL) { + sb.append(" for "); + try { + sb.append(operator.getLambdaName().writeToString()); + } + catch (Throwable t) { + Debug.trace(t); + } + } + sb.append('.'); + return sb.toString(); + } +} Added: branches/save-image/src/org/armedbear/lisp/ZeroRankArray.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ZeroRankArray.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,192 @@ +/* + * ZeroRankArray.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: ZeroRankArray.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class ZeroRankArray extends AbstractArray +{ + private final LispObject elementType; + private final boolean adjustable; + + private LispObject data; + + public ZeroRankArray(LispObject elementType, LispObject data, + boolean adjustable) + { + this.elementType = elementType; + this.data = data; + this.adjustable = adjustable; + } + + @Override + public LispObject typeOf() + { + if (adjustable) + return list3(Symbol.ARRAY, elementType, NIL); + else + return list3(Symbol.SIMPLE_ARRAY, elementType, NIL); + } + + @Override + public LispObject classOf() + { + return BuiltInClass.ARRAY; + } + + @Override + public LispObject typep(LispObject type) throws ConditionThrowable + { + if (type == Symbol.SIMPLE_ARRAY) + return adjustable ? NIL : T; + return super.typep(type); + } + + @Override + public int getRank() + { + return 0; + } + + @Override + public LispObject getDimensions() + { + return NIL; + } + + @Override + public int getDimension(int n) throws ConditionThrowable + { + error(new TypeError("Bad array dimension (" + n + ") for array of rank 0.")); + // Not reached. + return -1; + } + + @Override + public LispObject getElementType() + { + return elementType; + } + + @Override + public int getTotalSize() + { + return 1; + } + + @Override + public LispObject AREF(int index) throws ConditionThrowable + { + if (index == 0) + return data; + else + return error(new TypeError("Bad row major index " + index + ".")); + } + + @Override + public void aset(int index, LispObject obj) throws ConditionThrowable + { + if (obj.typep(elementType) == NIL) + error(new TypeError(obj, elementType)); + if (index == 0) + data = obj; + else + error(new TypeError("Bad row major index " + index + ".")); + } + + @Override + public void fill(LispObject obj) throws ConditionThrowable + { + if (obj.typep(elementType) == NIL) + error(new TypeError(obj, elementType)); + data = obj; + } + + @Override + public String writeToString() throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + boolean printReadably = (Symbol.PRINT_READABLY.symbolValue(thread) != NIL); + if (printReadably) { + if (elementType != T) { + error(new PrintNotReadable(list2(Keyword.OBJECT, this))); + // Not reached. + return null; + } + } + if (printReadably || Symbol.PRINT_ARRAY.symbolValue(thread) != NIL) { + StringBuffer sb = new StringBuffer("#0A"); + if (data == this && Symbol.PRINT_CIRCLE.symbolValue(thread) != NIL) { + StringOutputStream stream = new StringOutputStream(); + thread.execute(Symbol.OUTPUT_OBJECT.getSymbolFunction(), + data, stream); + sb.append(stream.getString().getStringValue()); + } else + sb.append(data.writeToString()); + return sb.toString(); + } + StringBuffer sb = new StringBuffer(); + if (!adjustable) + sb.append("SIMPLE-"); + sb.append("ARRAY "); + sb.append(elementType.writeToString()); + sb.append(" NIL"); + return unreadableString(sb.toString()); + } + + @Override + public AbstractArray adjustArray(int[] dims, + LispObject initialElement, + LispObject initialContents) + throws ConditionThrowable { + if (isAdjustable()) { + // initial element doesn't matter: + // we're not creating new elements + if (initialContents != null) + data = initialContents; + return this; + } else { + return new ZeroRankArray(elementType, + initialContents != null ? initialContents : + initialElement != null ? initialElement : data, false); + } + } + + @Override + public AbstractArray adjustArray(int[] dims, + AbstractArray displacedTo, + int displacement) + throws ConditionThrowable { + error(new TypeError("Displacement not supported for array of rank 0.")); + return null; + } +} Added: branches/save-image/src/org/armedbear/lisp/adjoin.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/adjoin.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,42 @@ +;;; adjoin.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: adjoin.lisp 11695 2009-03-03 22:10:25Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(defun adjoin (item list &key key (test #'eql testp) (test-not nil notp)) + "Add `item' to `list' unless it is already a member (as determined by +the test function `test'." + (when (and testp notp) + (error "test and test-not both supplied")) + (if (let ((key-val (sys::apply-key key item))) + (if notp + (member key-val list :test-not test-not :key key) + (member key-val list :test test :key key))) + list + (cons item list))) Added: branches/save-image/src/org/armedbear/lisp/adjust_array.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/adjust_array.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,131 @@ +/* + * adjust_array.java + * + * Copyright (C) 2004-2007 Peter Graves + * $Id: adjust_array.java 11562 2009-01-17 13:56:59Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### %adjust-array array new-dimensions element-type initial-element +// initial-element-p initial-contents initial-contents-p fill-pointer +// displaced-to displaced-index-offset => new-array +public final class adjust_array extends Primitive +{ + public adjust_array() + { + super("%adjust-array", PACKAGE_SYS, false); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 10) + return error(new WrongNumberOfArgumentsException(this)); + AbstractArray array = checkArray(args[0]); + LispObject dimensions = args[1]; + LispObject elementType = args[2]; + boolean initialElementProvided = args[4] != NIL; + boolean initialContentsProvided = args[6] != NIL; + LispObject initialElement = initialElementProvided ? args[3] : null; + LispObject initialContents = initialContentsProvided ? args[5] : null; + LispObject fillPointer = args[7]; + LispObject displacedTo = args[8]; + LispObject displacedIndexOffset = args[9]; + if (initialElementProvided && initialContentsProvided) { + return error(new LispError("ADJUST-ARRAY: cannot specify both initial element and initial contents.")); + } + if (elementType != array.getElementType() && + getUpgradedArrayElementType(elementType) != array.getElementType()) + { + return error(new LispError("ADJUST-ARRAY: incompatible element type.")); + } + if (array.getRank() == 0) { + return array.adjustArray(new int[0], initialElement, initialContents); + } + if (!initialElementProvided && array.getElementType() == T) + initialElement = Fixnum.ZERO; + if (array.getRank() == 1) { + final int newSize; + if (dimensions instanceof Cons && dimensions.length() == 1) + newSize = Fixnum.getValue(dimensions.car()); + else + newSize = Fixnum.getValue(dimensions); + if (array instanceof AbstractVector) { + AbstractVector v = (AbstractVector) array; + AbstractArray v2; + if (displacedTo != NIL) { + final int displacement; + if (displacedIndexOffset == NIL) + displacement = 0; + else + displacement = Fixnum.getValue(displacedIndexOffset); + v2 = v.adjustArray(newSize, + checkArray(displacedTo), + displacement); + } else { + v2 = v.adjustArray(newSize, + initialElement, + initialContents); + } + if (fillPointer != NIL) + v2.setFillPointer(fillPointer); + return v2; + } + } + // rank > 1 + final int rank = dimensions.listp() ? dimensions.length() : 1; + int[] dimv = new int[rank]; + if (dimensions.listp()) { + for (int i = 0; i < rank; i++) { + LispObject dim = dimensions.car(); + dimv[i] = Fixnum.getValue(dim); + dimensions = dimensions.cdr(); + } + } else + dimv[0] = Fixnum.getValue(dimensions); + + if (displacedTo != NIL) { + final int displacement; + if (displacedIndexOffset == NIL) + displacement = 0; + else + displacement = Fixnum.getValue(displacedIndexOffset); + return array.adjustArray(dimv, + checkArray(displacedTo), + displacement); + } else { + return array.adjustArray(dimv, + initialElement, + initialContents); + } + } + + private static final Primitive _ADJUST_ARRAY = new adjust_array(); +} Added: branches/save-image/src/org/armedbear/lisp/and.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/and.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,42 @@ +;;; and.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: and.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package "SYSTEM") + +(defmacro and (&rest forms) + (cond ((endp forms) t) + ((endp (rest forms)) (first forms)) + (t + `(if ,(first forms) + (and ,@(rest forms)) + nil)))) Added: branches/save-image/src/org/armedbear/lisp/apropos.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/apropos.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +;;; apropos.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: apropos.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(resolve 'write-string) + +(defun apropos-list (string-designator &optional package-designator) + (if package-designator + (let ((package (find-package package-designator)) + (string (string string-designator)) + (result nil)) + (dolist (symbol (package-external-symbols package)) + (declare (type symbol symbol)) + (when (search string (symbol-name symbol) :test #'char-equal) + (push symbol result))) + (dolist (symbol (package-internal-symbols package)) + (declare (type symbol symbol)) + (when (search string (symbol-name symbol) :test #'char-equal) + (push symbol result))) + result) + (mapcan (lambda (package) + (apropos-list string-designator package)) + (list-all-packages)))) + +(defun apropos (string-designator &optional package-designator) + (dolist (symbol (apropos-list string-designator package-designator)) + (fresh-line) + (prin1 symbol) + (when (boundp symbol) + (write-string " (bound)")) + (when (fboundp symbol) + (write-string " (fbound)"))) + (values)) Added: branches/save-image/src/org/armedbear/lisp/arglist.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/arglist.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,126 @@ +/* + * arglist.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: arglist.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class arglist extends Lisp +{ + private static final Operator getOperator(LispObject obj) + throws ConditionThrowable + { + if (obj instanceof Operator) + return (Operator) obj; + if (obj instanceof Symbol) { + LispObject function = obj.getSymbolFunction(); + if (function instanceof Autoload) { + Autoload autoload = (Autoload) function; + autoload.load(); + function = autoload.getSymbol().getSymbolFunction(); + } + if (function instanceof Operator) { + Operator operator = (Operator) function; + if (operator.getLambdaList() != null) + return operator; + LispObject other = get(obj, Symbol.MACROEXPAND_MACRO, null); + if (other != null) + return getOperator(other); + else + return null; + } + } else if (obj instanceof Cons && obj.car() == Symbol.LAMBDA) + return new Closure(obj, new Environment()); + return null; + } + + // ### arglist + private static final Primitive ARGLIST = + new Primitive("arglist", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispThread thread = LispThread.currentThread(); + Operator operator = getOperator(arg); + LispObject arglist = null; + if (operator != null) + arglist = operator.getLambdaList(); + final LispObject value1, value2; + if (arglist instanceof AbstractString) { + String s = arglist.getStringValue(); + // Give the string list syntax. + s = "(" + s + ")"; + // Bind *PACKAGE* so we use the EXT package if we need + // to intern any symbols. + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_EXT); + try { + arglist = readObjectFromString(s); + } + finally { + thread.lastSpecialBinding = lastSpecialBinding; + } + operator.setLambdaList(arglist); + } + if (arglist != null) { + value1 = arglist; + value2 = T; + } else { + value1 = NIL; + value2 = NIL; + } + return thread.setValues(value1, value2); + } + }; + + // ### %set-arglist + private static final Primitive _SET_ARGLIST = + new Primitive("%set-arglist", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Operator operator = null; + if (first instanceof Operator) { + operator = (Operator) first; + } else if (first instanceof Symbol) { + LispObject function = first.getSymbolFunction(); + if (function instanceof Operator) + operator = (Operator) function; + } + if (operator != null) + operator.setLambdaList(second); + return second; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/arrays.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/arrays.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,84 @@ +;;; arrays.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: arrays.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defconstant array-total-size-limit most-positive-fixnum) +(defconstant array-rank-limit 8) + +(defun make-array (dimensions &key + (element-type t) + (initial-element nil initial-element-p) + initial-contents adjustable fill-pointer + displaced-to displaced-index-offset) + (setf element-type (normalize-type element-type)) + (%make-array dimensions element-type initial-element initial-element-p + initial-contents adjustable fill-pointer displaced-to + displaced-index-offset)) + +(defun adjust-array (array new-dimensions + &key + (element-type (array-element-type array)) + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) + fill-pointer + displaced-to displaced-index-offset) + (%adjust-array array new-dimensions element-type + initial-element initial-element-p + initial-contents initial-contents-p + fill-pointer displaced-to displaced-index-offset)) + +(defun array-row-major-index (array &rest subscripts) + (%array-row-major-index array subscripts)) + +(defun bit (bit-array &rest subscripts) + (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) + +(defun sbit (simple-bit-array &rest subscripts) + (row-major-aref simple-bit-array + (%array-row-major-index simple-bit-array subscripts))) + +(defsetf row-major-aref aset) +(defsetf aref aset) +(defsetf bit aset) +(defsetf sbit aset) + +;; (SETF (APPLY #'AREF ... +(defun (setf aref) (new-value array &rest subscripts) + (aset array (%array-row-major-index array subscripts) new-value)) + +;; (SETF (APPLY #'BIT ... +(defun (setf bit) (new-value array &rest subscripts) + (aset array (%array-row-major-index array subscripts) new-value)) + +;; (SETF (APPLY #'SBIT ... +(defun (setf sbit) (new-value array &rest subscripts) + (aset array (%array-row-major-index array subscripts) new-value)) Added: branches/save-image/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/asdf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1176 @@ +;;; This is asdf: Another System Definition Facility. $Revision: 1.3 $ +;;; +;;; Feedback, bug reports, and patches are all welcome: please mail to +;;; . But note first that the canonical +;;; source for asdf is presently the cCLan CVS repository at +;;; +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the CVS HEAD +;;; is the latest development version, whereas the revision tagged +;;; RELEASE may be slightly older but is considered `stable' + +;;; Copyright (c) 2001-2003 Daniel Barlow and contributors +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;;; the problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file + +(defpackage #:asdf + (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:hyperdocumentation #:hyperdoc + + #:compile-op #:load-op #:load-source-op #:test-system-version + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + + #: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 + + #:operation-on-warnings + #:operation-on-failure + + ;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*asdf-revision* + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + #:duplicate-names + + #:retry + #:accept ; restarts + + ) + (:use :cl)) + +#+nil +(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") + + +(in-package #:asdf) + +(defvar *asdf-revision* (let* ((v "$Revision: 1.3 $") + (colon (or (position #\: v) -1)) + (dot (position #\. v))) + (and v colon dot + (list (parse-integer v :start (1+ colon) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t))))) + +(defvar *compile-file-warnings-behaviour* :warn) +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) + +(defvar *verbose-out* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; utility stuff + +(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" + (make-pathname :name nil :type nil :defaults pathname)) + +(define-modify-macro appendf (&rest args) + append "Append onto list") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; classes, condiitons + +(define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + +(define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply #'format s (format-control c) (format-arguments c))))) + +(define-condition circular-dependency (system-definition-error) + ((components :initarg :components :reader circular-dependency-components))) + +(define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name))) + +(define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (version :initform nil :reader missing-version :initarg :version) + (parent :initform nil :reader missing-parent :initarg :parent))) + +(define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + +(define-condition operation-error (error) + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s "~@" + (error-operation c) (error-component c))))) +(define-condition compile-error (operation-error) ()) +(define-condition compile-failed (compile-error) ()) +(define-condition compile-warned (compile-error) ()) + +(defclass component () + ((name :accessor component-name :initarg :name :documentation + "Component name: designator for a string composed of portable pathname characters") + (version :accessor component-version :initarg :version) + (in-order-to :initform nil :initarg :in-order-to) + ;;; XXX crap name + (do-first :initform nil :initarg :do-first) + ;; methods defined using the "inline" style inside a defsystem form: + ;; need to store them somewhere so we can delete them when the system + ;; is re-evaluated + (inline-methods :accessor component-inline-methods :initform nil) + (parent :initarg :parent :initform nil :reader component-parent) + ;; no direct accessor for pathname, we do this as a method to allow + ;; it to default in funky ways if not supplied + (relative-pathname :initarg :pathname) + (operation-times :initform (make-hash-table ) + :accessor component-operation-times) + ;; XXX we should provide some atomic interface for updating the + ;; component properties + (properties :accessor component-properties :initarg :properties + :initform nil))) + +;;;; methods: conditions + +(defmethod print-object ((c missing-dependency) s) + (format s "~@<~A, required by ~A~@:>" + (call-next-method c nil) (missing-required-by c))) + +(defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) + +;;;; methods: components + +(defmethod print-object ((c missing-component) s) + (format s "~@" + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) + +(defgeneric component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defmethod component-system ((component component)) + (aif (component-parent component) + (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)))) + +(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))) + +(defgeneric component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defun component-parent-pathname (component) + (aif (component-parent component) + (component-pathname it) + *default-pathname-defaults*)) + +(defgeneric component-relative-pathname (component) + (:documentation "Extracts the relative pathname applicable for a particular component.")) + +(defmethod component-relative-pathname ((component module)) + (or (slot-value component 'relative-pathname) + (make-pathname + :directory `(:relative ,(component-name component)) + :host (pathname-host (component-parent-pathname component))))) + +(defmethod component-pathname ((component component)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) + (merge-pathnames (component-relative-pathname component)))) + +(defgeneric component-property (component property)) + +(defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + +(defgeneric (setf component-property) (new-value component property)) + +(defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties)))))) + +(defclass system (module) + ((description :accessor system-description :initarg :description) + (long-description + :accessor system-long-description :initarg :long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence))) + +;;; version-satisfies + +;;; with apologies to christophe rhodes ... +(defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) + +(defgeneric version-satisfies (component version)) + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (return-from version-satisfies t)) + (let ((x (mapcar #'parse-integer + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding systems + +(defvar *defined-systems* (make-hash-table :test 'equal)) +(defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "~@" name)))) + +;;; for the sake of keeping things reasonably neat, we adopt a +;;; convention that functions in this list are prefixed SYSDEF- + +(defvar *system-definition-search-functions* + '(sysdef-central-registry-search)) + +(defun system-definition-pathname (system) + (some (lambda (x) (funcall x system)) + *system-definition-search-functions*)) + +(defvar *central-registry* + '(*default-pathname-defaults* + #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" + #+nil "telent:asdf;systems;")) + +(defun sysdef-central-registry-search (system) + (let ((name (coerce-name system))) + (block nil + (dolist (dir *central-registry*) + (let* ((defaults (eval dir)) + (file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file))))))) + +(defun make-temporary-package () + (flet ((try (counter) + (ignore-errors + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) + (do* ((counter 0 (+ counter 1)) + (package (try counter) (try counter))) + (package package)))) + +(defun find-system (name &optional (error-p t)) + (let* ((name (coerce-name name)) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (let ((*package* package)) + (format + *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. + on-disk + *package*) + (load on-disk)) + (delete-package package)))) + (let ((in-memory (gethash name *defined-systems*))) + (if in-memory + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) + +(defun register-system (name system) + (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (setf (gethash (coerce-name name) *defined-systems*) + (cons (get-universal-time) system))) + +(defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding components + +(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.")) + +(defmethod find-component ((module module) name &optional version) + (if (slot-boundp module 'components) + (let ((m (find name (module-components module) + :test #'equal :key #'component-name))) + (if (and m (version-satisfies m version)) m)))) + + +;;; a component with no parent is a system +(defmethod find-component ((module (eql nil)) name &optional version) + (let ((m (find-system name nil))) + (if (and m (version-satisfies m version)) m))) + +;;; component subclasses + +(defclass source-file (component) ()) + +(defclass cl-source-file (source-file) ()) +(defclass c-source-file (source-file) ()) +(defclass java-source-file (source-file) ()) +(defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) ()) + +(defgeneric source-file-type (component system)) +(defmethod source-file-type ((c cl-source-file) (s module)) "lisp") +(defmethod source-file-type ((c c-source-file) (s module)) "c") +(defmethod source-file-type ((c java-source-file) (s module)) "java") +(defmethod source-file-type ((c html-file) (s module)) "html") +(defmethod source-file-type ((c static-file) (s module)) nil) + +(defmethod component-relative-pathname ((component source-file)) + (let ((relative-pathname (slot-value component 'relative-pathname))) + (if relative-pathname + (merge-pathnames + relative-pathname + (make-pathname + :type (source-file-type component (component-system component)))) + (let* ((*default-pathname-defaults* + (component-parent-pathname component)) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) + name-type)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; operations + +;;; one of these is instantiated whenever (operate ) is called + +(defclass operation () + ((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) + (parent :initform nil :initarg :parent :accessor operation-parent))) + +(defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity t) + (ignore-errors + (prin1 (operation-original-initargs o) stream)))) + +(defmethod shared-initialize :after ((operation operation) slot-names + &key force + &allow-other-keys) + (declare (ignore slot-names force)) + ;; empty method to disable initarg validity checking + ) + +(defgeneric perform (operation component)) +(defgeneric operation-done-p (operation component)) +(defgeneric explain (operation component)) +(defgeneric output-files (operation component)) +(defgeneric input-files (operation component)) + +(defun node-for (o c) + (cons (class-name (class-of o)) c)) + +(defgeneric operation-ancestor (operation) + (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + +(defmethod operation-ancestor ((operation operation)) + (aif (operation-parent operation) + (operation-ancestor it) + operation)) + + +(defun make-sub-operation (c o dep-c dep-o) + (let* ((args (copy-list (operation-original-initargs o))) + (force-p (getf args :force))) + ;; note explicit comparison with T: any other non-NIL force value + ;; (e.g. :recursive) will pass through + (cond ((and (null (component-parent c)) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) + + +(defgeneric visit-component (operation component data)) + +(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))))) + +(defgeneric component-visited-p (operation component)) + +(defmethod component-visited-p ((o operation) (c component)) + (assoc (node-for o c) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) + +(defgeneric (setf visiting-component) (new-value operation component)) + +(defmethod (setf visiting-component) (new-value operation component) + ;; MCL complains about unused lexical variables + (declare (ignorable new-value operation component))) + +(defmethod (setf visiting-component) (new-value (o operation) (c component)) + (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))))) + +(defgeneric component-visiting-p (operation component)) + +(defmethod component-visiting-p ((o operation) (c component)) + (let ((node (cons o c))) + (member node (operation-visiting-nodes (operation-ancestor o)) + :test 'equal))) + +(defgeneric component-depends-on (operation component)) + +(defmethod component-depends-on ((o operation) (c component)) + (cdr (assoc (class-name (class-of o)) + (slot-value c 'in-order-to)))) + +(defgeneric component-self-dependencies (operation component)) + +(defmethod component-self-dependencies ((o operation) (c component)) + (let ((all-deps (component-depends-on o c))) + (remove-if-not (lambda (x) + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + +(defmethod input-files ((operation operation) (c component)) + (let ((parent (component-parent c)) + (self-deps (component-self-dependencies operation c))) + (if self-deps + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) + +(defmethod input-files ((operation operation) (c module)) nil) + +(defmethod operation-done-p ((o operation) (c component)) + (flet ((fwd-or-return-t (file) + ;; 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. + (let ((date (file-write-date file))) + (cond + (date) + (t + (warn "~@" + file o c) + (return-from operation-done-p t)))))) + (let ((out-files (output-files o c)) + (in-files (input-files o c))) + (cond ((and (not in-files) (not out-files)) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (apply #'max + (mapcar #'fwd-or-return-t in-files)))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'fwd-or-return-t in-files))))))))) + +;;; 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. And CLISP doesn't have non-standard method +;;; combinations, so let's keep it simple and aspire to portability + +(defgeneric traverse (operation component)) +(defmethod traverse ((operation operation) (c component)) + (let ((forced nil)) + (labels ((do-one-dep (required-op required-c required-v) + (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) + (error 'missing-dependency :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency :required-by c + :requires (car dep) :version nil))) + (t + (dolist (d dep) + (cond ((consp d) + (assert (string-equal + (symbol-name (first d)) + "VERSION")) + (appendf forced + (do-one-dep op (second d) (third d)))) + (t + (appendf forced (do-one-dep op d nil))))))))) + (aif (component-visited-p operation c) + (return-from traverse + (if (cdr it) (list (cons 'pruned-op c)) nil))) + ;; dependencies + (if (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) + (setf (visiting-component operation c) t) + (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) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (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 + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (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))) + + +(defmethod perform ((operation operation) (c source-file)) + (sysdef-error + "~@" + (class-of operation) (class-of c))) + +(defmethod perform ((operation operation) (c module)) + nil) + +(defmethod explain ((operation operation) (component component)) + (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) + +;;; compile-op + +(defclass compile-op (operation) + ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) + (on-warnings :initarg :on-warnings :accessor operation-on-warnings + :initform *compile-file-warnings-behaviour*) + (on-failure :initarg :on-failure :accessor operation-on-failure + :initform *compile-file-failure-behaviour*))) + +(defmethod perform :before ((operation compile-op) (c source-file)) + (map nil #'ensure-directories-exist (output-files operation c))) + +(defmethod perform :after ((operation operation) (c component)) + (setf (gethash (type-of operation) (component-operation-times c)) + (get-universal-time))) + +;;; perform is required to check output-files to find out where to put +;;; its answers, in case it has been overridden for site policy +(defmethod perform ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader + (let ((source-file (component-pathname c)) + (output-file (car (output-files operation c)))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file source-file + :output-file output-file) + ;(declare (ignore output)) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) + (unless output + (error 'compile-error :component c :operation operation))))) + +(defmethod output-files ((operation compile-op) (c cl-source-file)) + #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) + #+:broken-fasl-loader (list (component-pathname c))) + +(defmethod perform ((operation compile-op) (c static-file)) + nil) + +(defmethod output-files ((operation compile-op) (c static-file)) + nil) + +;;; load-op + +(defclass load-op (operation) ()) + +(defmethod perform ((o load-op) (c cl-source-file)) + (mapcar #'load (input-files o c))) + +(defmethod perform ((operation load-op) (c static-file)) + nil) +(defmethod operation-done-p ((operation load-op) (c static-file)) + t) + +(defmethod output-files ((o operation) (c component)) + nil) + +(defmethod component-depends-on ((operation load-op) (c component)) + (cons (list 'compile-op (component-name c)) + (call-next-method))) + +;;; load-source-op + +(defclass load-source-op (operation) ()) + +(defmethod perform ((o load-source-op) (c cl-source-file)) + (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)) + nil) + +(defmethod output-files ((operation load-source-op) (c component)) + nil) + +;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. +(defmethod component-depends-on ((o load-source-op) (c component)) + (let ((what-would-load-op-do (cdr (assoc 'load-op + (slot-value c 'in-order-to))))) + (mapcar (lambda (dep) + (if (eq (car dep) 'load-op) + (cons 'load-source-op (cdr dep)) + dep)) + what-would-load-op-do))) + +(defmethod operation-done-p ((o load-source-op) (c source-file)) + (if (or (not (component-property c 'last-loaded-as-source)) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) + nil t)) + +(defclass test-op (operation) ()) + +(defmethod perform ((operation test-op) (c component)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; invoking operations + +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) + (let* ((op (apply #'make-instance operation-class + :original-initargs args + args)) + (*verbose-out* (if verbose *trace-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) + (unless (version-satisfies system version) + (error 'missing-component :requires system :version version)) + (let ((steps (traverse op system))) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) + +(defun oos (&rest args) + "Alias of OPERATE function" + (apply #'operate args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; syntax + +(defun remove-keyword (key arglist) + (labels ((aux (key arglist) + (cond ((null arglist) nil) + ((eq key (car arglist)) (cddr arglist)) + (t (cons (car arglist) (cons (cadr arglist) + (remove-keyword + key (cddr arglist)))))))) + (aux key arglist))) + +(defmacro defsystem (name &body options) + (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options + (let ((component-options (remove-keyword :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 + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + (or ,pathname + (pathname-sans-name+type + (resolve-symlinks *load-truename*)) + *default-pathname-defaults*) + ',component-options)))))) + + +(defun class-for-type (parent type) + (let ((class + (find-class + (or (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) #.(package-name *package*))) + nil))) + (or class + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error "~@" type)))) + +(defun maybe-add-tree (tree op1 op2 c) + "Add the node C at /OP1/OP2 in TREE, unless it's there already. +Returns the new tree (which probably shares structure with the old one)" + (let ((first-op-tree (assoc op1 tree))) + (if first-op-tree + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + +(defun union-of-dependencies (&rest deps) + (let ((new-tree nil)) + (dolist (dep deps) + (dolist (op-tree dep) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + new-tree)) + + +(defun remove-keys (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(defvar *serial-depends-on*) + +(defun parse-component-form (parent options) + (destructuring-bind + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + (check-component-input type name weakly-depends-on depends-on components in-order-to) + + (when (and parent + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to) + rest)) + (ret + (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))) + (apply #'reinitialize-instance + ret + :name (coerce-name name) + :pathname pathname + :parent parent + other-args) + (when (typep ret 'module) + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop for c-form in components + for c = (parse-component-form ret c-form) + collect c + if serial + do (push (component-name c) *serial-depends-on*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) + + (setf (slot-value ret 'in-order-to) + (union-of-dependencies + in-order-to + `((compile-op (compile-op , at depends-on)) + (load-op (load-op , at depends-on)))) + (slot-value ret 'do-first) `((compile-op (load-op , at depends-on)))) + + (loop for (n v) in `((perform ,perform) (explain ,explain) + (output-files ,output-files) + (operation-done-p ,operation-done-p)) + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) (remove-method (symbol-function n) m)) + (component-inline-methods ret)) + when v + do (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) + , at body)) + (component-inline-methods ret)))) + ret))) + +(defun check-component-input (type name weakly-depends-on depends-on components in-order-to) + "A partial test of the values of a component." + (when weakly-depends-on (warn "We got one! XXXXX")) + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components)) + (unless (and (listp in-order-to) (listp (car in-order-to))) + (sysdef-error-component ":in-order-to must be NIL or a list of components." + type name in-order-to))) + +(defun sysdef-error-component (msg type name value) + (sysdef-error (concatenate 'string msg + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) + +(defun resolve-symlinks (path) + #-allegro (truename path) + #+allegro (excl:pathname-resolve-symbolic-links path) + ) + +;;; optional extras + +;;; run-shell-command functions for other lisp implementations will be +;;; gratefully accepted, if they do the same thing. If the docstring +;;; is ambiguous, send a bug report + +(defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code." + (let ((command (apply #'format nil control-string args))) + (format *verbose-out* "; $ ~A~%" command) + #+sbcl + (sb-ext:process-exit-code + (sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + #+win32 #+win32 :search t + :input nil :output *verbose-out*)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #+allegro + (excl:run-shell-command command :input nil :output *verbose-out*) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream *verbose-out*) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll + (si:system command) + + #+abcl + (ext:run-shell-command command :output *verbose-out*) + #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + )) + + +(defgeneric hyperdocumentation (package name doc-type)) +(defmethod hyperdocumentation ((package symbol) name doc-type) + (hyperdocumentation (find-package package) name doc-type)) + +(defun hyperdoc (name doc-type) + (hyperdocumentation (symbol-package name) name doc-type)) + + +(pushnew :asdf *features*) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") + (pushnew :sbcl-hooks-require *features*))) + +#+(and sbcl sbcl-hooks-require) +(progn + (defun module-provide-asdf (name) + (handler-bind ((style-warning #'muffle-warning)) + (let* ((*verbose-out* (make-broadcast-stream)) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)))) + + (defun contrib-sysdef-search (system) + (let* ((name (coerce-name system)) + (home (truename (sb-ext:posix-getenv "SBCL_HOME"))) + (contrib (merge-pathnames + (make-pathname :directory `(:relative ,name) + :name name + :type "asd" + :case :local + :version :newest) + home))) + (probe-file contrib))) + + (pushnew + '(merge-pathnames "site-systems/" + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + *central-registry*) + + (pushnew + '(merge-pathnames ".sbcl/systems/" + (user-homedir-pathname)) + *central-registry*) + + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) + (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) + +(provide 'asdf) Added: branches/save-image/src/org/armedbear/lisp/ash.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ash.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,53 @@ +/* + * ash.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: ash.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### ash +// ash integer count => shifted-integer +public final class ash extends Primitive +{ + private ash() + { + super("ash", "integer count"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.ash(second); + } + + private static final Primitive ASH = new ash(); +} Added: branches/save-image/src/org/armedbear/lisp/assert.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/assert.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,71 @@ +;;; assert.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: assert.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package #:system) + +(defmacro assert (test-form &optional places datum &rest arguments) + "Signals an error if the value of test-form is nil. Continuing from this + error using the CONTINUE restart will allow the user to alter the value of + some locations known to SETF and start over with test-form. Returns nil." + `(loop + (when ,test-form (return nil)) + (assert-error ',test-form ',places ,datum , at arguments) + ,@(mapcar #'(lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places))) + +(defun assert-error (assertion places datum &rest arguments) + (declare (ignore places)) + (let ((c (if datum + (coerce-to-condition + datum arguments + 'simple-error 'error) + (make-condition 'simple-error + :format-control "The assertion ~S failed." + :format-arguments (list assertion))))) + (restart-case (error c) + (continue () + :report (lambda (stream) (format stream "Retry assertion.")) + nil)))) + + +(defun assert-prompt (name value) + (cond ((y-or-n-p "The old value of ~S is ~S.~%Do you want to supply a new value? " + name value) + (fresh-line *query-io*) + (format *query-io* "Type a form to be evaluated:~%") + (flet ((read-it () (eval (read *query-io*)))) + (if (symbolp name) ;help user debug lexical variables + (progv (list name) (list value) (read-it)) + (read-it)))) + (t value))) Added: branches/save-image/src/org/armedbear/lisp/assoc.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/assoc.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,122 @@ +;;; assoc.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: assoc.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From CMUCL. + +(in-package "SYSTEM") + +(defmacro assoc-guts (test-guy) + `(do ((alist alist (cdr alist))) + ((endp alist)) + (if (car alist) + (if ,test-guy (return (car alist)))))) + +(defun assoc (item alist &key key test test-not) + (cond (test + (if key + (assoc-guts (funcall test item (funcall key (caar alist)))) + (assoc-guts (funcall test item (caar alist))))) + (test-not + (if key + (assoc-guts (not (funcall test-not item + (funcall key (caar alist))))) + (assoc-guts (not (funcall test-not item (caar alist)))))) + (t + (if key + (assoc-guts (eql item (funcall key (caar alist)))) + (assoc-guts (eql item (caar alist))))))) + +(defun assoc-if (predicate alist &key key) + (if key + (assoc-guts (funcall predicate (funcall key (caar alist)))) + (assoc-guts (funcall predicate (caar alist))))) + +(defun assoc-if-not (predicate alist &key key) + (if key + (assoc-guts (not (funcall predicate (funcall key (caar alist))))) + (assoc-guts (not (funcall predicate (caar alist)))))) + +(defun rassoc (item alist &key key test test-not) + (cond (test + (if key + (assoc-guts (funcall test item (funcall key (cdar alist)))) + (assoc-guts (funcall test item (cdar alist))))) + (test-not + (if key + (assoc-guts (not (funcall test-not item + (funcall key (cdar alist))))) + (assoc-guts (not (funcall test-not item (cdar alist)))))) + (t + (if key + (assoc-guts (eql item (funcall key (cdar alist)))) + (assoc-guts (eql item (cdar alist))))))) + +(defun rassoc-if (predicate alist &key key) + (if key + (assoc-guts (funcall predicate (funcall key (cdar alist)))) + (assoc-guts (funcall predicate (cdar alist))))) + +(defun rassoc-if-not (predicate alist &key key) + (if key + (assoc-guts (not (funcall predicate (funcall key (cdar alist))))) + (assoc-guts (not (funcall predicate (cdar alist)))))) + +(defun acons (key datum alist) + (cons (cons key datum) alist)) + +(defun pairlis (keys data &optional (alist '())) + (do ((x keys (cdr x)) + (y data (cdr y))) + ((and (endp x) (endp y)) alist) + (if (or (endp x) (endp y)) + (error "the lists of keys and data are of unequal length")) + (setq alist (acons (car x) (car y) alist)))) + +;;; From SBCL. +(defun copy-alist (alist) + "Return a new association list which is EQUAL to ALIST." + (if (endp alist) + alist + (let ((result + (cons (if (atom (car alist)) + (car alist) + (cons (caar alist) (cdar alist))) + nil))) + (do ((x (cdr alist) (cdr x)) + (splice result + (cdr (rplacd splice + (cons + (if (atom (car x)) + (car x) + (cons (caar x) (cdar x))) + nil))))) + ((endp x))) + result))) Added: branches/save-image/src/org/armedbear/lisp/assq.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/assq.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +/* + * assq.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: assq.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### assq item alist => entry +public final class assq extends Primitive +{ + private assq() + { + super("assq", PACKAGE_EXT, true); + } + + @Override + public LispObject execute(LispObject item, LispObject alist) + throws ConditionThrowable + { + return assq(item, alist); + } + + private static final Primitive ASSQ = new assq(); +} Added: branches/save-image/src/org/armedbear/lisp/assql.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/assql.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +/* + * assql.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: assql.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### assql item alist => entry +public final class assql extends Primitive +{ + private assql() + { + super("assql", PACKAGE_EXT); + } + + @Override + public LispObject execute(LispObject item, LispObject alist) + throws ConditionThrowable + { + while (alist != NIL) { + LispObject cons = alist.car(); + if (cons instanceof Cons) { + if (cons.car().eql(item)) + return cons; + } else if (cons != NIL) + return type_error(cons, Symbol.LIST); + alist = alist.cdr(); + } + return NIL; + } + + private static final Primitive ASSQL = new assql(); +} Added: branches/save-image/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/autoloads.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,312 @@ +;;; autoloads.lisp +;;; +;;; Copyright (C) 2003-2008 Peter Graves +;;; $Id: autoloads.lisp 11590 2009-01-25 23:34:24Z astalla $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(autoload '(char/= char> char>= char-not-equal) + "chars") +(autoload '(string-upcase string-downcase string-capitalize + nstring-upcase nstring-downcase nstring-capitalize + string= string/= string-equal string-not-equal + string< string> + string<= string>= + string-lessp string-greaterp + string-not-lessp string-not-greaterp + string-left-trim string-right-trim string-trim) + "strings") +(autoload 'copy-symbol) +(autoload '(open parse-integer)) +(autoload '(sort stable-sort merge) "sort") +(autoload 'tree-equal) +(autoload 'make-hash-table) +(autoload 'list-length) +(autoload 'revappend) +(autoload '(butlast nbutlast) "butlast") +(autoload 'ldiff) +(autoload '(subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not) + "subst") +(autoload '(sublis nsublis) "sublis") +(autoload '(member-if member-if-not) "member-if") +(autoload 'tailp) +(autoload 'adjoin) +(autoload '(union nunion + intersection nintersection + set-difference nset-difference + set-exclusive-or nset-exclusive-or + subsetp) + "sets") +(autoload '(assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not + acons pairlis copy-alist) + "assoc") +(autoload '(mapcan mapl maplist mapcon) "map1") +(autoload 'make-sequence) +(autoload '(copy-seq fill replace)) +(autoload '(map map-into)) +(autoload 'reduce) +(autoload '(delete delete-if delete-if-not) "delete") +(autoload '(remove remove-if remove-if-not) "remove") +(autoload '(remove-duplicates delete-duplicates)) +(autoload '(substitute substitute-if substitute-if-not) "substitute") +(autoload '(nsubstitute nsubstitute-if nsubstitute-if-not) "nsubstitute") +(autoload '(position position-if position-if-not find find-if find-if-not + list-find* vector-find*) + "find") +(autoload '(count count-if count-if-not) "count") +(autoload '(mismatch search)) +(autoload 'make-string) +(autoload 'directory "directory") +(autoload '(signum round ffloor fceiling fround rationalize gcd isqrt + float-precision decode-float conjugate phase) + "numbers") +(autoload 'boole) +(export '%ldb '#:system) +(autoload '(byte byte-size byte-position %ldb ldb ldb-test dpb) "ldb") +(autoload 'lcm) +(autoload '(apropos apropos-list) "apropos") +(autoload '(y-or-n-p yes-or-no-p) "query") +(autoload '(decode-universal-time get-decoded-time encode-universal-time) + "time") +(autoload 'gentemp) +(autoload '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 + bit-andc2 bit-orc1 bit-orc2 bit-not) + "bit-array-ops") +(autoload 'deposit-field) +(autoload 'mask-field) +(autoload '(ensure-class ensure-generic-function make-condition + mop::ensure-method + define-method-combination + %defgeneric + canonicalize-direct-superclasses) + "clos") +(export '(ensure-class subclassp %defgeneric canonicalize-direct-superclasses) + '#:system) +(autoload '(inspect istep) "inspect") +(autoload 'enough-namestring) +(autoload 'upgraded-complex-part-type) + +(autoload '(tpl::top-level-loop) "top-level") + +(autoload 'hash-table-iterator-function "with-hash-table-iterator") +(autoload-macro 'with-hash-table-iterator) + +(autoload 'package-iterator-function "with-package-iterator") +(autoload-macro 'with-package-iterator) + +(autoload-macro 'remf) +(autoload-macro 'check-type) +(autoload-macro 'deftype) +(autoload 'expand-deftype "deftype") +(autoload-macro '(defclass defgeneric defmethod define-condition) "clos") +(autoload-macro 'with-standard-io-syntax) +(autoload 'sys::%with-standard-io-syntax "with-standard-io-syntax") +(autoload-macro 'psetf) +(autoload-macro 'rotatef) +(autoload-macro 'shiftf) + +(autoload-macro 'do-all-symbols) +(autoload-macro '(trace untrace) "trace") +(autoload '(sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all) "trace") +(autoload 'sys::%define-symbol-macro "define-symbol-macro") +(autoload-macro 'define-symbol-macro) +(autoload-macro 'with-slots) +(autoload-macro 'with-accessors) +(autoload-macro '(sys::%print-unreadable-object print-unreadable-object) + "print-unreadable-object") +(autoload 'print-object) +(autoload-macro '(prog prog*) "prog") +(export 'concatenate-to-string '#:system) +(autoload '(concatenate-to-string concatenate) "concatenate") +(autoload 'parse-lambda-list) +(autoload-macro 'assert) +(autoload '(sys::assert-error sys::assert-prompt) "assert") +(autoload-macro 'with-input-from-string) +(autoload-macro 'with-output-to-string) +(autoload 'ensure-directories-exist) +(autoload 'coerce) +(autoload 'read-from-string) +(autoload 'read-sequence) +(autoload 'write-sequence) +(autoload 'make-load-form-saving-slots) +(autoload 'compile-file) +(autoload 'compile-file-pathname) + +(autoload 'format "format") +(autoload-macro 'formatter "format") + +(autoload '(write-byte read-byte) "byte-io") +(autoload-macro 'with-open-file) +(autoload '(pathname-host pathname-device pathname-directory pathname-name + pathname-type wild-pathname-p pathname-match-p translate-pathname + logical-pathname-translations translate-logical-pathname + load-logical-pathname-translations logical-pathname + parse-namestring) + "pathnames") +(autoload 'make-string-output-stream) +(autoload 'find-all-symbols) +(autoload 'dribble) +(autoload-macro 'step) +(autoload 'load) +(autoload 'compile "jvm") +(autoload-macro 'with-compilation-unit "jvm") + +(autoload-macro '(case ccase ecase typecase ctypecase etypecase) "case") +(autoload-macro '(and cond dolist dotimes + do-symbols do-external-symbols + multiple-value-bind multiple-value-list multiple-value-setq + nth-value + or)) +(autoload-macro '(do do*) "do") + +(autoload 'ed) +(autoload 'describe) +(autoload 'disassemble) + +(in-package "MOP") +(export 'class-precedence-list) +(autoload 'class-precedence-list "clos") + +;; Java interface. +(in-package "JAVA") +(export 'jregister-handler "JAVA") +(autoload 'jregister-handler "java") +(export 'jinterface-implementation "JAVA") +(autoload 'jinterface-implementation "java") +(export 'jmake-invocation-handler "JAVA") +(autoload 'jmake-invocation-handler "java") +(export 'jmake-proxy "JAVA") +(autoload 'jmake-proxy "java") +(export 'jproperty-value "JAVA") +(autoload 'jproperty-value "java") +(export 'jobject-class "JAVA") +(autoload 'jobject-class "java") +(export 'jclass-superclass "JAVA") +(autoload 'jclass-superclass "java") +(export 'jclass-interfaces "JAVA") +(autoload 'jclass-interfaces "java") +(export 'jclass-interface-p "JAVA") +(autoload 'jclass-interface-p "java") +(export 'jclass-superclass-p "JAVA") +(autoload 'jclass-superclass-p "java") +(export 'jclass-array-p "JAVA") +(autoload 'jclass-array-p "java") +(export 'jarray-component-type "JAVA") +(autoload 'jarray-component-type "java") +(export 'jarray-length "JAVA") +(autoload 'jarray-length "java") +(export 'jnew-array-from-array "JAVA") +(autoload 'jnew-array-from-array "java") +(export 'jclass-constructors "JAVA") +(autoload 'jclass-constructors "java") +(export 'jconstructor-params "JAVA") +(autoload 'jconstructor-params "java") +(export 'jclass-field "JAVA") +(autoload 'jclass-field "java") +(export 'jclass-fields "JAVA") +(autoload 'jclass-fields "java") +(export 'jfield-type "JAVA") +(autoload 'jfield-type "java") +(export 'jfield-name "JAVA") +(autoload 'jfield-name "java") +(export 'jclass-methods "JAVA") +(autoload 'jclass-methods "java") +(export 'jmethod-params "JAVA") +(autoload 'jmethod-params "java") +(export 'jmethod-name "JAVA") +(autoload 'jmethod-name "java") +(export 'jinstance-of-p "JAVA") +(autoload 'jinstance-of-p "java") +(export 'jmember-static-p "JAVA") +(autoload 'jmember-static-p "java") +(export 'jmember-public-p "JAVA") +(autoload 'jmember-public-p "java") +(export 'jmember-protected-p "JAVA") +(autoload 'jmember-protected-p "java") +(export 'jnew-runtime-class "JAVA") +(autoload 'jnew-runtime-class "runtime-class") +(export 'jredefine-method "JAVA") +(autoload 'jredefine-method "runtime-class") +(export 'jruntime-class-exists-p "JAVA") +(autoload 'jruntime-class-exists-p "runtime-class") + +;; Profiler. +(in-package "PROFILER") +(export '(*granularity* show-call-counts with-profiling)) +(autoload 'show-call-counts "profiler") +(autoload-macro 'with-profiling "profiler") + +;; Extensions. +(in-package "EXTENSIONS") +(export 'simple-search) +(autoload 'simple-search "search") +(export 'run-shell-command) +(autoload 'run-shell-command) + +(export 'make-socket) +(autoload 'make-socket "socket") +(export 'make-server-socket) +(autoload 'make-server-socket "socket") +(export 'server-socket-close) +(autoload 'server-socket-close "socket") +(export 'socket-accept) +(autoload 'socket-accept "socket") +(export 'socket-close) +(autoload 'socket-close "socket") +(export 'get-socket-stream) +(autoload 'get-socket-stream "socket") +(export 'socket-peer-port) +(autoload 'socket-peer-port "socket") +(export 'socket-local-port) +(autoload 'socket-local-port "socket") +(export 'socket-local-address) +(autoload 'socket-local-address "socket") +(export 'socket-peer-address) +(autoload 'socket-peer-address "socket") + +(export '(grovel-java-definitions compile-system)) +(autoload '(grovel-java-definitions compile-system) "compile-system") +(export 'with-thread-lock) +(autoload-macro 'with-thread-lock) +(export 'aver) +(autoload-macro 'aver) +(autoload 'sys::%failed-aver "aver") +(export 'collect) +(autoload-macro 'collect) +(export 'with-mutex) +(autoload-macro 'with-mutex) +(export 'compile-file-if-needed) +(autoload 'compile-file-if-needed "compile-file") +(export 'describe-compiler-policy) +(autoload 'describe-compiler-policy) + +;; JVM compiler. +(in-package "JVM") +(export '(jvm-compile jvm-compile-package)) +(autoload '%with-compilation-unit "jvm") Added: branches/save-image/src/org/armedbear/lisp/aver.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/aver.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,43 @@ +;;; aver.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: aver.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package "SYSTEM") + +(defun %failed-aver (expr-as-string) + (error 'simple-error + :format-control "Failed AVER: ~S" + :format-arguments (list expr-as-string))) + +(defmacro aver (expr) + `(unless ,expr + (%failed-aver ,(format nil "~A" expr)))) Added: branches/save-image/src/org/armedbear/lisp/backquote.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/backquote.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,240 @@ +;;; backquote.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: backquote.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +;;;; the backquote reader macro + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package #:system) + +;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: +;;; +;;; |`,|: [a] => a +;;; NIL: [a] => a ;the NIL flag is used only when a is NIL +;;; T: [a] => a ;the T flag is used when a is self-evaluating +;;; QUOTE: [a] => (QUOTE a) +;;; APPEND: [a] => (APPEND . a) +;;; NCONC: [a] => (NCONC . a) +;;; LIST: [a] => (LIST . a) +;;; LIST*: [a] => (LIST* . a) +;;; +;;; The flags are combined according to the following set of rules: +;;; ([a] means that a should be converted according to the previous table) +;;; +;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| +;;;cdr \ || | T or NIL | | +;;;================================================================================ +;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) +;;; NIL || LIST ([a]) | QUOTE (a) | a | a +;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d]) +;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d]) +;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d) +;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d]) +;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d]) +;;; +;;; involves starting over again pretending you had read ".,a)" instead +;;; of ", at a)" + +;; (%defvar '*backquote-count* 0) +(%defvar '*bq-comma-flag* '(|,|)) +(%defvar '*bq-at-flag* '(|,@|)) +(%defvar '*bq-dot-flag* '(|,.|)) +;; (%defvar '*bq-vector-flag* '(|bqv|)) + +;;; the actual character macro +(defun backquote-macro (stream ignore) + (declare (ignore ignore)) + (let ((*backquote-count* (1+ *backquote-count*))) + (multiple-value-bind (flag thing) + (backquotify stream (read stream t nil t)) + (when (eq flag *bq-at-flag*) + (%reader-error stream ",@ after backquote in ~S" thing)) + (when (eq flag *bq-dot-flag*) + (%reader-error stream ",. after backquote in ~S" thing)) + (backquotify-1 flag thing)))) + +(defun comma-macro (stream ignore) + (declare (ignore ignore)) + (unless (> *backquote-count* 0) + (when *read-suppress* + (return-from comma-macro nil)) + (%reader-error stream "Comma not inside a backquote.")) + (let ((c (read-char stream)) + (*backquote-count* (1- *backquote-count*))) + (cond ((char= c #\@) + (cons *bq-at-flag* (read stream t nil t))) + ((char= c #\.) + (cons *bq-dot-flag* (read stream t nil t))) + (t (unread-char c stream) + (cons *bq-comma-flag* (read stream t nil t)))))) + +;;; +(defun expandable-backq-expression-p (object) + (and (consp object) + (let ((flag (%car object))) + (or (eq flag *bq-at-flag*) + (eq flag *bq-dot-flag*))))) + +;;; This does the expansion from table 2. +(defun backquotify (stream code) + (cond ((atom code) + (cond ((null code) (values nil nil)) + ((or (consp code) + (symbolp code)) + ;; Keywords are self-evaluating. Install after packages. + (values 'quote code)) + (t (values t code)))) + ((or (eq (car code) *bq-at-flag*) + (eq (car code) *bq-dot-flag*)) + (values (car code) (cdr code))) + ((eq (car code) *bq-comma-flag*) + (comma (cdr code))) + ((eq (car code) *bq-vector-flag*) + (multiple-value-bind (dflag d) (backquotify stream (cdr code)) + (values 'vector (backquotify-1 dflag d)))) + (t (multiple-value-bind (aflag a) (backquotify stream (car code)) + (multiple-value-bind (dflag d) (backquotify stream (cdr code)) + (when (eq dflag *bq-at-flag*) + ;; Get the errors later. + (%reader-error stream ",@ after dot in ~S" code)) + (when (eq dflag *bq-dot-flag*) + (%reader-error stream ",. after dot in ~S" code)) + (cond + ((eq aflag *bq-at-flag*) + (if (null dflag) + (if (expandable-backq-expression-p a) + (values 'append (list a)) + (comma a)) + (values 'append + (cond ((eq dflag 'append) + (cons a d )) + (t (list a (backquotify-1 dflag d))))))) + ((eq aflag *bq-dot-flag*) + (if (null dflag) + (if (expandable-backq-expression-p a) + (values 'nconc (list a)) + (comma a)) + (values 'nconc + (cond ((eq dflag 'nconc) + (cons a d)) + (t (list a (backquotify-1 dflag d))))))) + ((null dflag) + (if (memq aflag '(quote t nil)) + (values 'quote (list a)) + (values 'list (list (backquotify-1 aflag a))))) + ((memq dflag '(quote t)) + (if (memq aflag '(quote t nil)) + (values 'quote (cons a d )) + (values 'list* (list (backquotify-1 aflag a) + (backquotify-1 dflag d))))) + (t (setq a (backquotify-1 aflag a)) + (if (memq dflag '(list list*)) + (values dflag (cons a d)) + (values 'list* + (list a (backquotify-1 dflag d))))))))))) + +;;; This handles the cases. +(defun comma (code) + (cond ((atom code) + (cond ((null code) + (values nil nil)) + ((or (numberp code) (eq code t)) + (values t code)) + (t (values *bq-comma-flag* code)))) + ((and (eq (car code) 'quote) + (not (expandable-backq-expression-p (cadr code)))) + (values (car code) (cadr code))) + ((memq (car code) '(append list list* nconc)) + (values (car code) (cdr code))) + ((eq (car code) 'cons) + (values 'list* (cdr code))) + (t (values *bq-comma-flag* code)))) + +;;; This handles table 1. +(defun backquotify-1 (flag thing) + (cond ((or (eq flag *bq-comma-flag*) + (memq flag '(t nil))) + thing) + ((eq flag 'quote) + (list 'quote thing)) + ((eq flag 'list*) + (cond ((and (null (cddr thing)) + (not (expandable-backq-expression-p (cadr thing)))) + (cons 'backq-cons thing)) + ((expandable-backq-expression-p (car (last thing))) + (list 'backq-append + (cons 'backq-list (butlast thing)) + ;; Can it be optimized further? -- APD, 2001-12-21 + (car (last thing)))) + (t + (cons 'backq-list* thing)))) + ((eq flag 'vector) + (list 'backq-vector thing)) + (t (cons (ecase flag + ((list) 'backq-list) + ((append) 'backq-append) + ((nconc) 'backq-nconc)) + thing)))) + +;;;; magic BACKQ- versions of builtin functions + +;;; Define synonyms for the lisp functions we use, so that by using +;;; them, the backquoted material will be recognizable to the +;;; pretty-printer. +(defun backq-list (&rest args) (apply #'list args)) +(defun backq-list* (&rest args) (apply #'list* args)) +(defun backq-append (&rest args) (apply #'append args)) +(defun backq-nconc (&rest args) (apply #'nconc args)) +(defun backq-cons (&rest args) (apply #'cons args)) + +(defun backq-vector (list) + (declare (list list)) + (coerce list 'simple-vector)) + +;;; The pretty-printer needs to know about our special tokens +(%defvar '*backq-tokens* + '(backq-comma backq-comma-at backq-comma-dot backq-list + backq-list* backq-append backq-nconc backq-cons backq-vector)) + +(defun %reader-error (stream control &rest args) + (error 'reader-error + :stream stream + :format-control control + :format-arguments args)) Added: branches/save-image/src/org/armedbear/lisp/bit-array-ops.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/bit-array-ops.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,195 @@ +;;; bit-array-ops.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: bit-array-ops.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package #:system) + +(defun bit-array-same-dimensions-p (array1 array2) + (declare (type (array bit) array1 array2)) + (and (= (array-rank array1) + (array-rank array2)) + (dotimes (index (array-rank array1) t) + (when (/= (array-dimension array1 index) + (array-dimension array2 index)) + (return nil))))) + +(defun require-same-dimensions (array1 array2) + (unless (bit-array-same-dimensions-p array1 array2) + (error 'program-error + "~S and ~S do not have the same dimensions." + array1 array2))) + +(defun pick-result-array (result-bit-array bit-array-1) + (case result-bit-array + ((t) bit-array-1) + ((nil) (make-array (array-dimensions bit-array-1) + :element-type 'bit + :initial-element 0)) + (t + (require-same-dimensions bit-array-1 result-bit-array) + result-bit-array))) + +(defun bit-and (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-and bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i))))))) + +(defun bit-ior (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-ior bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logior (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i))))))) + +(defun bit-xor (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-xor bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logxor (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i))))))) + +(defun bit-eqv (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-eqv bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (logeqv (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-nand (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-nand bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (lognand (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-nor (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-nor bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (lognor (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-andc1 (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-andc1 bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (logandc1 (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-andc2 (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-andc2 bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (logandc2 (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-orc1 (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-orc1 bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (logorc1 (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-orc2 (bit-array-1 bit-array-2 &optional result-bit-array) + (require-same-dimensions bit-array-1 bit-array-2) + (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) + (if (and (simple-bit-vector-p bit-array-1) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-orc2 bit-array-1 bit-array-2 result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logand (logorc2 (row-major-aref bit-array-1 i) + (row-major-aref bit-array-2 i)) + 1)))))) + +(defun bit-not (bit-array &optional result-bit-array) + (let ((result-bit-array (pick-result-array result-bit-array bit-array))) + (if (and (simple-bit-vector-p bit-array) + (simple-bit-vector-p result-bit-array)) + (%simple-bit-vector-bit-not bit-array result-bit-array) + (dotimes (i (array-total-size result-bit-array) result-bit-array) + (setf (row-major-aref result-bit-array i) + (logxor (row-major-aref bit-array i) 1)))))) Added: branches/save-image/src/org/armedbear/lisp/boole.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/boole.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,57 @@ +;;; boole.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: boole.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(defun boole (op n1 n2) + (unless (and (integerp n1) (integerp n2)) + (error 'type-error + :datum (if (integerp n1) n2 n1) + :expected-type 'integer)) + (case op + (#.boole-clr 0) + (#.boole-set -1) + (#.boole-1 n1) + (#.boole-2 n2) + (#.boole-c1 (lognot n1)) + (#.boole-c2 (lognot n2)) + (#.boole-and (logand n1 n2)) + (#.boole-ior (logior n1 n2)) + (#.boole-xor (logxor n1 n2)) + (#.boole-eqv (logeqv n1 n2)) + (#.boole-nand (lognand n1 n2)) + (#.boole-nor (lognor n1 n2)) + (#.boole-andc1 (logandc1 n1 n2)) + (#.boole-andc2 (logandc2 n1 n2)) + (#.boole-orc1 (logorc1 n1 n2)) + (#.boole-orc2 (logorc2 n1 n2)) + (t + (error 'type-error + :datum op + :expected-type (list 'integer #.boole-clr #.boole-orc2))))) Added: branches/save-image/src/org/armedbear/lisp/boot.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/boot.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,321 @@ +;;; boot.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: boot.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(sys:%in-package "SYSTEM") + +(setq *load-verbose* nil) +(setq *autoload-verbose* nil) + +;; Redefined in macros.lisp. +(defmacro in-package (name) + (list '%in-package (string name))) + +(defmacro lambda (lambda-list &rest body) + (list 'function (list* 'lambda lambda-list body))) + +(defmacro named-lambda (name lambda-list &rest body) + (list 'function (list* 'named-lambda name lambda-list body))) + +;; Redefined in macros.lisp. +(defmacro return (&optional result) + (list 'return-from nil result)) + +;; Redefined in precompiler.lisp. +(defmacro defun (name lambda-list &rest body) + (let ((block-name (fdefinition-block-name name))) + (list '%defun + (list 'quote name) + (list 'lambda lambda-list (list* 'block block-name body))))) + +;; Redefined in macros.lisp. +(defmacro defconstant (name initial-value &optional docstring) + (list '%defconstant (list 'quote name) initial-value docstring)) + +;; Redefined in macros.lisp. +(defmacro defparameter (name initial-value &optional docstring) + (list '%defparameter (list 'quote name) initial-value docstring)) + +(defmacro declare (&rest ignored) nil) + +(in-package #:extensions) + +(export '(%car %cdr %cadr %caddr)) + +(defmacro %car (x) + (list 'car (list 'truly-the 'cons x))) + +(defmacro %cdr (x) + (list 'cdr (list 'truly-the 'cons x))) + +(defmacro %cadr (x) + (list '%car (list '%cdr x))) + +(defmacro %caddr (x) + (list '%car (list '%cdr (list '%cdr x)))) + +(in-package #:system) + +;; Redefined in precompiler.lisp. +(defun eval (form) + (%eval form)) + +;; Redefined in pprint.lisp. +(defun terpri (&optional output-stream) + (%terpri output-stream)) + +;; Redefined in pprint.lisp. +(defun fresh-line (&optional output-stream) + (%fresh-line output-stream)) + +;; Redefined in pprint.lisp. +(defun write-char (character &optional output-stream) + (%write-char character output-stream)) + +(in-package #:extensions) + +;; Redefined in pprint.lisp. +(defun charpos (stream) + (sys::stream-charpos stream)) + +;; Redefined in pprint.lisp. +(defun (setf charpos) (new-value stream) + (sys::stream-%set-charpos stream new-value)) + +(export 'charpos '#:extensions) + +;; Redefined in precompiler.lisp. +(defun precompile (name &optional definition) + (declare (ignore name definition)) + nil) + +(export 'precompile '#:extensions) + +(in-package #:system) + +(defun simple-format (destination control-string &rest args) + (apply *simple-format-function* destination control-string args)) + +(export 'simple-format '#:system) + +;; INVOKE-DEBUGGER is redefined in debug.lisp. +(defun invoke-debugger (condition) + (sys::%format t "~A~%" condition) + (ext:quit)) + +(load-system-file "autoloads") +(load-system-file "early-defuns") +(load-system-file "backquote") +(load-system-file "destructuring-bind") +(load-system-file "defmacro") +(load-system-file "setf") +(load-system-file "fdefinition") +(load-system-file "featurep") +(load-system-file "read-conditional") +(load-system-file "macros") + +;; Redefined in package.lisp +(defun make-package (package-name &key nicknames use) + (%make-package package-name nicknames use)) + +;;; Reading circular data: the #= and ## reader macros (from SBCL) + +;;; Objects already seen by CIRCLE-SUBST. +(defvar *sharp-equal-circle-table*) + +;; This function is kind of like NSUBLIS, but checks for circularities and +;; substitutes in arrays and structures as well as lists. The first arg is an +;; alist of the things to be replaced assoc'd with the things to replace them. +(defun circle-subst (old-new-alist tree) + (cond ((not (typep tree + '(or cons (array t) structure-object standard-object))) + (let ((entry (find tree old-new-alist :key #'second))) + (if entry (third entry) tree))) + ((null (gethash tree *sharp-equal-circle-table*)) + (setf (gethash tree *sharp-equal-circle-table*) t) + (cond + ((typep tree 'structure-object) + (do ((i 0 (1+ i)) + (end (structure-length tree))) + ((= i end)) + (let* ((old (structure-ref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (structure-set tree i new))))) +;; ((typep tree 'standard-object) +;; (do ((i 1 (1+ i)) +;; (end (%instance-length tree))) +;; ((= i end)) +;; (let* ((old (%instance-ref tree i)) +;; (new (circle-subst old-new-alist old))) +;; (unless (eq old new) +;; (setf (%instance-ref tree i) new))))) + ((arrayp tree) + (do ((i 0 (1+ i)) + (end (array-total-size tree))) + ((>= i end)) + (let* ((old (row-major-aref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (row-major-aref tree i) new))))) + (t + (let ((a (circle-subst old-new-alist (car tree))) + (d (circle-subst old-new-alist (cdr tree)))) + (unless (eq a (car tree)) + (rplaca tree a)) + (unless (eq d (cdr tree)) + (rplacd tree d))))) + tree) + (t tree))) + +;;; Sharp-equal works as follows. When a label is assigned (i.e. when +;;; #= is called) we GENSYM a symbol is which is used as an +;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this +;;; gensym. +;;; +;;; When SHARP-SHARP encounters a reference to a label, it returns the +;;; symbol assoc'd with the label. Resolution of the reference is +;;; deferred until the read done by #= finishes. Any already resolved +;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned. +;;; +;;; After reading of the #= form is completed, we add an entry to +;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved +;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current +;;; object is searched and any uses of the gensysm token are replaced +;;; with the actual value. + +(defvar *sharp-sharp-alist* ()) + +(defun sharp-equal (stream ignore label) + (declare (ignore ignore)) + (when *read-suppress* (return-from sharp-equal (values))) + (unless label + (error 'reader-error + :stream stream + :format-control "Missing label for #=")) + (when (or (assoc label *sharp-sharp-alist*) + (assoc label *sharp-equal-alist*)) + (error 'reader-error + :stream stream + :format-control "Multiply defined label: #~D=" + :format-arguments (list label))) + (let* ((tag (gensym)) + (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*)) + (obj (read stream t nil t))) + (when (eq obj tag) + (error 'reader-error + :stream stream + :format-control "Must tag something more than just #~D#" + :format-arguments (list label))) + (push (list label tag obj) *sharp-equal-alist*) + (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20))) + (circle-subst *sharp-equal-alist* obj)))) + +(defun sharp-sharp (stream ignore label) + (declare (ignore ignore)) + (when *read-suppress* (return-from sharp-sharp nil)) + (unless label + (error 'reader-error :stream stream :format-control "Missing label for ##")) + (let ((entry (assoc label *sharp-equal-alist*))) + (if entry + (third entry) + (let ((pair (assoc label *sharp-sharp-alist*))) + (unless pair + (error 'reader-error + :stream stream + :format-control "Object is not labelled #~S#" + :format-arguments (list label))) + (cdr pair))))) + +(set-dispatch-macro-character #\# #\= #'sharp-equal +standard-readtable+) +(set-dispatch-macro-character #\# #\# #'sharp-sharp +standard-readtable+) + +(copy-readtable +standard-readtable+ *readtable*) + +;; SYS::%COMPILE is redefined in precompiler.lisp. +(defun sys::%compile (name definition) + (values (if name name definition) nil nil)) + +(load-system-file "inline") +(load-system-file "proclaim") +(load-system-file "arrays") +(load-system-file "compiler-macro") +(load-system-file "subtypep") +(load-system-file "typep") +(load-system-file "compiler-error") +(load-system-file "source-transform") +(load-system-file "precompiler") + +(precompile-package "PRECOMPILER") +(precompile-package "EXTENSIONS") +(precompile-package "SYSTEM") +(precompile-package "COMMON-LISP") + +(load-system-file "signal") +(load-system-file "list") +(load-system-file "sequences") +(load-system-file "error") +(load-system-file "defpackage") +(load-system-file "define-modify-macro") + +;;; Package definitions. +(defpackage "FORMAT" (:use "CL" "EXT")) + +(defpackage "XP" + (:use "CL") + (:export + #:output-pretty-object)) + +(defconstant lambda-list-keywords + '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)) + +(load-system-file "require") +(load-system-file "defstruct") +(load-system-file "restart") +(load-system-file "late-setf") +(load-system-file "debug") +(load-system-file "print") +(load-system-file "pprint-dispatch") +(load-system-file "pprint") +(load-system-file "defsetf") +(load-system-file "package") + + +(defun preload-package (pkg) + (%format t "Preloading ~S~%" (find-package pkg)) + (dolist (sym (package-symbols pkg)) + (when (autoloadp sym) + (resolve sym)))) + +(unless (featurep :j) + (load-system-file "top-level") + (unless *noinform* + (%format t "Startup completed in ~A seconds.~%" + (float (/ (ext:uptime) 1000))))) Added: branches/save-image/src/org/armedbear/lisp/butlast.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/butlast.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +;;; butlast.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: butlast.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "COMMON-LISP") + +(export '(butlast nbutlast)) + +(defun butlast (list &optional (n 1)) + (unless (and (listp list) (typep n '(integer 0))) + (error 'type-error)) + (unless (null list) + (let ((length (do ((list list (cdr list)) + (i 0 (1+ i))) + ((atom list) (1- i))))) + (unless (< length n) + (do* ((top (cdr list) (cdr top)) + (result (list (car list))) + (splice result) + (count length (1- count))) + ((= count n) result) + (setq splice (cdr (rplacd splice (list (car top)))))))))) + +(defun nbutlast (list &optional (n 1)) + (unless (and (listp list) (typep n '(integer 0))) + (error 'type-error)) + (unless (null list) + (let ((length (do ((list list (cdr list)) + (i 0 (1+ i))) + ((atom list) (1- i))))) + (unless (< length n) + (do ((1st (cdr list) (cdr 1st)) + (2nd list 1st) + (count length (1- count))) + ((= count n) + (rplacd 2nd ()) + list)))))) Added: branches/save-image/src/org/armedbear/lisp/byte-io.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/byte-io.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,73 @@ +;;; byte-io.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: byte-io.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun write-byte (byte stream) + (declare (type stream stream)) + (let ((element-type (stream-element-type stream))) + (require-type byte element-type) + (let ((width (cadr element-type))) + (if (= width 8) + (write-8-bits (the (unsigned-byte 8) byte) stream) + (let ((bytes ())) + (dotimes (i (/ width 8)) + (push (logand byte #xff) bytes) + (setf byte (ash byte -8))) + (dolist (b bytes) + (write-8-bits (the (unsigned-byte 8) b) stream))))) + byte)) + +(defun read-byte (stream &optional (eof-error-p t) eof-value) + (declare (type stream stream)) + (let* ((element-type (stream-element-type stream))) + (unless element-type + (if eof-error-p + (error 'end-of-file :stream stream) + (return-from read-byte eof-value))) + (unless (consp element-type) + (error 'simple-type-error + :format-control "READ-BYTE: unsupported element type ~S." + :format-arguments (list element-type))) + (let ((width (cadr element-type))) + (if (= width 8) + (read-8-bits stream eof-error-p eof-value) + (let ((result 0)) + (dotimes (i (/ width 8)) + (let ((byte (read-8-bits stream eof-error-p eof-value))) + (when (eq byte eof-value) + (return-from read-byte eof-value)) + (setf result (ash result 8)) + (setf result (+ result byte)))) + (if (and (eq (car element-type) 'signed-byte) + (not (zerop (logand result (expt 2 (1- width)))))) + (- result (expt 2 width)) + result)))))) Added: branches/save-image/src/org/armedbear/lisp/case.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/case.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,182 @@ +;;; case.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: case.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +;;; Is X a (possibly-improper) list of at least N elements? +(defun list-of-length-at-least-p (x n) + (or (zerop n) ; since anything can be considered an improper list of length 0 + (and (consp x) + (list-of-length-at-least-p (cdr x) (1- n))))) + +(defun case-body-error (name keyform keyform-value expected-type keys) + (declare (ignore name keys)) + (restart-case + (error 'type-error + :datum keyform-value + :expected-type expected-type) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value for ~S." keyform)) + :interactive read-evaluated-form + value))) + +;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled +;;; all the cases. Note: it is not necessary that the resulting code +;;; signal case-failure conditions, but that's what KMP's prototype +;;; code did. We call CASE-BODY-ERROR, because of how closures are +;;; compiled. RESTART-CASE has forms with closures that the compiler +;;; causes to be generated at the top of any function using the case +;;; macros, regardless of whether they are needed. +;;; +;;; The CASE-BODY-ERROR function is defined later, when the +;;; RESTART-CASE macro has been defined. +(defun case-body-aux (name keyform keyform-value clauses keys + errorp proceedp expected-type) + (if proceedp + (let ((block (gensym)) + (again (gensym))) + `(let ((,keyform-value ,keyform)) + (block ,block + (tagbody + ,again + (return-from + ,block + (cond ,@(nreverse clauses) + (t + (setf ,keyform-value + (setf ,keyform + (case-body-error + ',name ',keyform ,keyform-value + ',expected-type ',keys))) + (go ,again)))))))) + `(let ((,keyform-value ,keyform)) + (cond + ,@(nreverse clauses) + ,@(if errorp +;; `((t (error 'case-failure +;; :name ',name +;; :datum ,keyform-value +;; :expected-type ',expected-type +;; :possibilities ',keys)))))))) + `((t (error 'type-error + :datum ,keyform-value + :expected-type ',expected-type)))))))) + +;;; CASE-BODY returns code for all the standard "case" macros. NAME is +;;; the macro name, and KEYFORM is the thing to case on. MULTI-P +;;; indicates whether a branch may fire off a list of keys; otherwise, +;;; a key that is a list is interpreted in some way as a single key. +;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key +;;; for a given branch; otherwise, TEST is applied to the value of +;;; KEYFORM and the entire first element, instead of each part, of the +;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted, +;;; and an ERROR form is generated. When PROCEEDP, it is an error to +;;; omit ERRORP, and the ERROR form generated is executed within a +;;; RESTART-CASE allowing KEYFORM to be set and retested. +(defun case-body (name keyform cases multi-p test errorp proceedp needcasesp) + (unless (or cases (not needcasesp)) + (warn "no clauses in ~S" name)) + (let ((keyform-value (gensym)) + (clauses ()) + (keys ())) + (do* ((cases cases (cdr cases)) + (case (car cases) (car cases))) + ((null cases) nil) + (unless (list-of-length-at-least-p case 1) + (error "~S -- bad clause in ~S" case name)) + (destructuring-bind (keyoid &rest forms) case + (cond ((and (memq keyoid '(t otherwise)) + (null (cdr cases))) + (if errorp + (progn + (style-warn "~@" + keyoid name) + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) nil , at forms) + clauses)) + (push `(t nil , at forms) clauses))) + ((and multi-p (listp keyoid)) + (setf keys (append keyoid keys)) + (push `((or ,@(mapcar (lambda (key) + `(,test ,keyform-value ',key)) + keyoid)) + nil + , at forms) + clauses)) + (t + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) + nil + , at forms) + clauses))))) + (case-body-aux name keyform keyform-value clauses keys errorp proceedp + `(,(if multi-p 'member 'or) , at keys)))) + +(defmacro case (keyform &body cases) + "CASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If a singleton key is T then the clause is a default clause." + (case-body 'case keyform cases t 'eql nil nil nil)) + +(defmacro ccase (keyform &body cases) + "CCASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then a correctable error is + signalled." + (case-body 'ccase keyform cases t 'eql t t t)) + +(defmacro ecase (keyform &body cases) + "ECASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then an error is signalled." + (case-body 'ecase keyform cases t 'eql t nil t)) + +(defmacro typecase (keyform &body cases) + "TYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true." + (case-body 'typecase keyform cases nil 'typep nil nil nil)) + +(defmacro ctypecase (keyform &body cases) + "CTYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then a correctable error is signalled." + (case-body 'ctypecase keyform cases nil 'typep t t t)) + +(defmacro etypecase (keyform &body cases) + "ETYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then an error is signalled." + (case-body 'etypecase keyform cases nil 'typep t nil t)) Added: branches/save-image/src/org/armedbear/lisp/ceiling.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ceiling.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,73 @@ +/* + * ceiling.java + * + * Copyright (C) 2004 Peter Graves + * $Id: ceiling.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### ceiling number &optional divisor +public final class ceiling extends Primitive +{ + private ceiling() + { + super("ceiling", "number &optional divisor"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return execute(arg, Fixnum.ONE); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + LispObject quotient = first.truncate(second); + final LispThread thread = LispThread.currentThread(); + LispObject remainder = thread._values[1]; + if (remainder.zerop()) + return quotient; + if (second.minusp()) { + if (first.plusp()) + return quotient; + } else { + if (first.minusp()) + return quotient; + } + quotient = quotient.incr(); + thread._values[0] = quotient; + thread._values[1] = remainder.subtract(second); + return quotient; + } + + private static final Primitive CEILING = new ceiling(); +} Added: branches/save-image/src/org/armedbear/lisp/cell_error_name.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/cell_error_name.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,58 @@ +/* + * cell_error_name.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: cell_error_name.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### cell-error-name +public final class cell_error_name extends Primitive +{ + private cell_error_name() + { + super(Symbol.CELL_ERROR_NAME, "condition"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final StandardObject obj; + try { + obj = (StandardObject) arg; + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STANDARD_OBJECT); + } + return obj.getInstanceSlotValue(Symbol.NAME); + } + + private static final Primitive CELL_ERROR_NAME = new cell_error_name(); +} Added: branches/save-image/src/org/armedbear/lisp/chars.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/chars.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,74 @@ +;;; chars.lisp +;;; +;;; Copyright (C) 2003-2004 Peter Graves +;;; $Id: chars.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; From CMUCL. + +(defun char/= (character &rest more-characters) + (do* ((head character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (do* ((l list (cdr l))) ;inner loop returns T + ((atom l) T) ; iff head /= rest. + (if (eql head (car l)) (return nil))) + (return nil)))) + +(defun char> (character &rest more-characters) + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (> (char-int c) + (char-int (car list))) + (return nil)))) + +(defun char>= (character &rest more-characters) + (do* ((c character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (>= (char-int c) + (char-int (car list))) + (return nil)))) + +(defmacro equal-char-code (character) + `(let ((ch (char-code ,character))) + (if (< 96 ch 123) (- ch 32) ch))) + +(defun char-not-equal (character &rest more-characters) + (do* ((head character (car list)) + (list more-characters (cdr list))) + ((atom list) T) + (unless (do* ((l list (cdr l))) + ((atom l) T) + (if (= (equal-char-code head) + (equal-char-code (car l))) + (return nil))) + (return nil)))) Added: branches/save-image/src/org/armedbear/lisp/check-type.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/check-type.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,65 @@ +;;; check-type.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: check-type.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package #:system) + +(defmacro check-type (place type &optional type-string) + (let ((place-value (gensym))) + `(loop + (let ((,place-value ,place)) + (when (typep ,place-value ',type) + (return nil)) + (setf ,place + (check-type-error ',place ,place-value ',type ,type-string)))))) + +(defun check-type-error (place place-value type type-string) + (let ((cond (if type-string + (make-condition 'simple-type-error + :datum place-value :expected-type type + :format-control + "The value of ~S is ~S, which is not ~A." + :format-arguments + (list place place-value type-string)) + (make-condition 'simple-type-error + :datum place-value :expected-type type + :format-control + "The value of ~S is ~S, which is not of type ~S." + :format-arguments + (list place place-value type))))) + (restart-case (error cond) + (store-value (value) + :report (lambda (stream) + (format stream "Supply a new value for ~S." + place)) + :interactive read-evaluated-form + value)))) Added: branches/save-image/src/org/armedbear/lisp/clos.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/clos.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,2310 @@ +;;; clos.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: clos.lisp 11590 2009-01-25 23:34:24Z astalla $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Originally based on Closette. + +;;; Closette Version 1.0 (February 10, 1991) +;;; +;;; Copyright (c) 1990, 1991 Xerox Corporation. +;;; All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted. Any distribution of this +;;; software or derivative works must comply with all applicable United +;;; States export control laws. +;;; +;;; This software is made available AS IS, and Xerox Corporation makes no +;;; warranty about the software, its performance or its conformity to any +;;; specification. +;;; +;;; Closette is an implementation of a subset of CLOS with a metaobject +;;; protocol as described in "The Art of The Metaobject Protocol", +;;; MIT Press, 1991. + +(in-package #:mop) + +(export '(class-precedence-list)) + +(defmacro push-on-end (value location) + `(setf ,location (nconc ,location (list ,value)))) + +;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list, +;;; which must be non-nil. + +(defun (setf getf*) (new-value plist key) + (block body + (do ((x plist (cddr x))) + ((null x)) + (when (eq (car x) key) + (setf (car (cdr x)) new-value) + (return-from body new-value))) + (push-on-end key plist) + (push-on-end new-value plist) + new-value)) + +(defun mapappend (fun &rest args) + (if (some #'null args) + () + (append (apply fun (mapcar #'car args)) + (apply #'mapappend fun (mapcar #'cdr args))))) + +(defun mapplist (fun x) + (if (null x) + () + (cons (funcall fun (car x) (cadr x)) + (mapplist fun (cddr x))))) + +(defsetf class-layout %set-class-layout) +(defsetf class-direct-superclasses %set-class-direct-superclasses) +(defsetf class-direct-subclasses %set-class-direct-subclasses) +(defsetf class-direct-methods %set-class-direct-methods) +(defsetf class-direct-slots %set-class-direct-slots) +;; (defsetf class-slots %set-class-slots) +(defsetf class-direct-default-initargs %set-class-direct-default-initargs) +(defsetf class-default-initargs %set-class-default-initargs) +(defsetf class-finalized-p %set-class-finalized-p) +(defsetf std-instance-layout %set-std-instance-layout) +(defsetf standard-instance-access %set-standard-instance-access) + +(defun (setf find-class) (new-value symbol &optional errorp environment) + (declare (ignore errorp environment)) + (%set-find-class symbol new-value)) + +(defun canonicalize-direct-slots (direct-slots) + `(list ,@(mapcar #'canonicalize-direct-slot direct-slots))) + +(defun canonicalize-direct-slot (spec) + (if (symbolp spec) + `(list :name ',spec) + (let ((name (car spec)) + (initfunction nil) + (initform nil) + (initargs ()) + (type nil) + (allocation nil) + (documentation nil) + (readers ()) + (writers ()) + (other-options ())) + (do ((olist (cdr spec) (cddr olist))) + ((null olist)) + (case (car olist) + (:initform + (when initform + (error 'program-error + "duplicate slot option :INITFORM for slot named ~S" + name)) + (setq initfunction + `(function (lambda () ,(cadr olist)))) + (setq initform `',(cadr olist))) + (:initarg + (push-on-end (cadr olist) initargs)) + (:allocation + (when allocation + (error 'program-error + "duplicate slot option :ALLOCATION for slot named ~S" + name)) + (setf allocation (cadr olist)) + (push-on-end (car olist) other-options) + (push-on-end (cadr olist) other-options)) + (:type + (when type + (error 'program-error + "duplicate slot option :TYPE for slot named ~S" + name)) + (setf type (cadr olist))) ;; FIXME type is ignored + (:documentation + (when documentation + (error 'program-error + "duplicate slot option :DOCUMENTATION for slot named ~S" + name)) + (setf documentation (cadr olist))) ;; FIXME documentation is ignored + (:reader + (maybe-note-name-defined (cadr olist)) + (push-on-end (cadr olist) readers)) + (:writer + (maybe-note-name-defined (cadr olist)) + (push-on-end (cadr olist) writers)) + (:accessor + (maybe-note-name-defined (cadr olist)) + (push-on-end (cadr olist) readers) + (push-on-end `(setf ,(cadr olist)) writers)) + (t + (error 'program-error + "invalid initialization argument ~S for slot named ~S" + (car olist) name)))) + `(list + :name ',name + ,@(when initfunction + `(:initform ,initform + :initfunction ,initfunction)) + ,@(when initargs `(:initargs ',initargs)) + ,@(when readers `(:readers ',readers)) + ,@(when writers `(:writers ',writers)) + , at other-options)))) + +(defun maybe-note-name-defined (name) + (when (fboundp 'note-name-defined) + (note-name-defined name))) + +(defun canonicalize-direct-superclasses (direct-superclasses) + (let ((classes '())) + (dolist (class-specifier direct-superclasses) + (if (classp class-specifier) + (push class-specifier classes) + (let ((class (find-class class-specifier nil))) + (unless class + (setf class (make-forward-referenced-class class-specifier))) + (push class classes)))) + (nreverse classes))) + +(defun canonicalize-defclass-options (options) + (mapappend #'canonicalize-defclass-option options)) + +(defun canonicalize-defclass-option (option) + (case (car option) + (:metaclass + (list ':metaclass + `(find-class ',(cadr option)))) + (:default-initargs + (list + ':direct-default-initargs + `(list ,@(mapappend + #'(lambda (x) x) + (mapplist + #'(lambda (key value) + `(',key ,(make-initfunction value))) + (cdr option)))))) + ((:documentation :report) + (list (car option) `',(cadr option))) + (t + (error 'program-error + :format-control "invalid DEFCLASS option ~S" + :format-arguments (list (car option)))))) + +(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)) + +;;; finalize-inheritance + +(defun std-finalize-inheritance (class) + (set-class-precedence-list + class + (funcall (if (eq (class-of class) (find-class 'standard-class)) + #'std-compute-class-precedence-list + #'compute-class-precedence-list) + class)) + (dolist (class (%class-precedence-list class)) + (when (typep class 'forward-referenced-class) + (return-from std-finalize-inheritance))) + (set-class-slots class + (funcall (if (eq (class-of class) (find-class 'standard-class)) + #'std-compute-slots + #'compute-slots) + class)) + (let ((old-layout (class-layout class)) + (length 0) + (instance-slots '()) + (shared-slots '())) + (dolist (slot (%class-slots class)) + (case (%slot-definition-allocation slot) + (:instance + (set-slot-definition-location slot length) + (incf length) + (push (%slot-definition-name slot) instance-slots)) + (:class + (unless (%slot-definition-location slot) + (let ((allocation-class (%slot-definition-allocation-class slot))) + (set-slot-definition-location slot + (if (eq allocation-class class) + (cons (%slot-definition-name slot) +slot-unbound+) + (slot-location allocation-class (%slot-definition-name slot)))))) + (push (%slot-definition-location slot) shared-slots)))) + (when old-layout + ;; Redefined class: initialize added shared slots. + (dolist (location shared-slots) + (let* ((slot-name (car location)) + (old-location (layout-slot-location old-layout slot-name))) + (unless old-location + (let* ((slot-definition (find slot-name (%class-slots class) :key #'%slot-definition-name)) + (initfunction (%slot-definition-initfunction slot-definition))) + (when initfunction + (setf (cdr location) (funcall initfunction)))))))) + (setf (class-layout class) + (make-layout class (nreverse instance-slots) (nreverse shared-slots)))) + (setf (class-default-initargs class) (compute-class-default-initargs class)) + (setf (class-finalized-p class) t)) + +;;; Class precedence lists + +(defun std-compute-class-precedence-list (class) + (let ((classes-to-order (collect-superclasses* class))) + (topological-sort classes-to-order + (remove-duplicates + (mapappend #'local-precedence-ordering + classes-to-order)) + #'std-tie-breaker-rule))) + +;;; topological-sort implements the standard algorithm for topologically +;;; sorting an arbitrary set of elements while honoring the precedence +;;; constraints given by a set of (X,Y) pairs that indicate that element +;;; X must precede element Y. The tie-breaker procedure is called when it +;;; is necessary to choose from multiple minimal elements; both a list of +;;; candidates and the ordering so far are provided as arguments. + +(defun topological-sort (elements constraints tie-breaker) + (let ((remaining-constraints constraints) + (remaining-elements elements) + (result ())) + (loop + (let ((minimal-elements + (remove-if + #'(lambda (class) + (member class remaining-constraints + :key #'cadr)) + remaining-elements))) + (when (null minimal-elements) + (if (null remaining-elements) + (return-from topological-sort result) + (error "Inconsistent precedence graph."))) + (let ((choice (if (null (cdr minimal-elements)) + (car minimal-elements) + (funcall tie-breaker + minimal-elements + result)))) + (setq result (append result (list choice))) + (setq remaining-elements + (remove choice remaining-elements)) + (setq remaining-constraints + (remove choice + remaining-constraints + :test #'member))))))) + +;;; In the event of a tie while topologically sorting class precedence lists, +;;; the CLOS Specification says to "select the one that has a direct subclass +;;; rightmost in the class precedence list computed so far." The same result +;;; is obtained by inspecting the partially constructed class precedence list +;;; from right to left, looking for the first minimal element to show up among +;;; the direct superclasses of the class precedence list constituent. +;;; (There's a lemma that shows that this rule yields a unique result.) + +(defun std-tie-breaker-rule (minimal-elements cpl-so-far) + (dolist (cpl-constituent (reverse cpl-so-far)) + (let* ((supers (class-direct-superclasses cpl-constituent)) + (common (intersection minimal-elements supers))) + (when (not (null common)) + (return-from std-tie-breaker-rule (car common)))))) + +;;; This version of collect-superclasses* isn't bothered by cycles in the class +;;; hierarchy, which sometimes happen by accident. + +(defun collect-superclasses* (class) + (labels ((all-superclasses-loop (seen superclasses) + (let ((to-be-processed + (set-difference superclasses seen))) + (if (null to-be-processed) + superclasses + (let ((class-to-process + (car to-be-processed))) + (all-superclasses-loop + (cons class-to-process seen) + (union (class-direct-superclasses + class-to-process) + superclasses))))))) + (all-superclasses-loop () (list class)))) + +;;; The local precedence ordering of a class C with direct superclasses C_1, +;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)). + +(defun local-precedence-ordering (class) + (mapcar #'list + (cons class + (butlast (class-direct-superclasses class))) + (class-direct-superclasses class))) + +;;; Slot inheritance + +(defun std-compute-slots (class) + (let* ((all-slots (mapappend #'class-direct-slots + (%class-precedence-list class))) + (all-names (remove-duplicates + (mapcar #'%slot-definition-name all-slots)))) + (mapcar #'(lambda (name) + (funcall + (if (eq (class-of class) (find-class 'standard-class)) + #'std-compute-effective-slot-definition + #'compute-effective-slot-definition) + class + (remove name all-slots + :key #'%slot-definition-name + :test-not #'eq))) + 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 + :name (%slot-definition-name (car direct-slots)) + :initform (if initer + (%slot-definition-initform initer) + nil) + :initfunction (if initer + (%slot-definition-initfunction initer) + nil) + :initargs (remove-duplicates + (mapappend #'%slot-definition-initargs + direct-slots)) + :allocation (%slot-definition-allocation (car direct-slots)) + :allocation-class (%slot-definition-allocation-class (car direct-slots))))) + +;;; Standard instance slot access + +;;; N.B. The location of the effective-slots slots in the class metaobject for +;;; standard-class must be determined without making any further slot +;;; references. + +(defun find-slot-definition (class slot-name) + (dolist (slot (%class-slots class) nil) + (when (eq slot-name (%slot-definition-name slot)) + (return slot)))) + +(defun slot-location (class slot-name) + (let ((slot (find-slot-definition class slot-name))) + (if slot + (%slot-definition-location slot) + nil))) + +(defun instance-slot-location (instance slot-name) + (let ((layout (std-instance-layout instance))) + (and layout (layout-slot-location layout slot-name)))) + +(defun slot-value (object slot-name) + (if (eq (class-of (class-of object)) (find-class 'standard-class)) + (std-slot-value object slot-name) + (slot-value-using-class (class-of object) object slot-name))) + +(defsetf std-slot-value set-std-slot-value) + +(defun %set-slot-value (object slot-name new-value) + (if (eq (class-of (class-of object)) (find-class 'standard-class)) + (setf (std-slot-value object slot-name) new-value) + (set-slot-value-using-class new-value (class-of object) + object slot-name))) + +(defsetf slot-value %set-slot-value) + +(defun slot-boundp (object slot-name) + (if (eq (class-of (class-of object)) (find-class 'standard-class)) + (std-slot-boundp object slot-name) + (slot-boundp-using-class (class-of object) object slot-name))) + +(defun std-slot-makunbound (instance slot-name) + (let ((location (instance-slot-location instance slot-name))) + (cond ((fixnump location) + (setf (standard-instance-access instance location) +slot-unbound+)) + ((consp location) + (setf (cdr location) +slot-unbound+)) + (t + (slot-missing (class-of instance) instance slot-name 'slot-makunbound)))) + instance) + +(defun slot-makunbound (object slot-name) + (if (eq (class-of (class-of object)) (find-class 'standard-class)) + (std-slot-makunbound object slot-name) + (slot-makunbound-using-class (class-of object) object slot-name))) + +(defun std-slot-exists-p (instance slot-name) + (not (null (find slot-name (%class-slots (class-of instance)) + :key #'%slot-definition-name)))) + +(defun slot-exists-p (object slot-name) + (if (eq (class-of (class-of object)) (find-class 'standard-class)) + (std-slot-exists-p object slot-name) + (slot-exists-p-using-class (class-of object) object slot-name))) + +(defun instance-slot-p (slot) + (eq (%slot-definition-allocation slot) :instance)) + +(defun make-instance-standard-class (metaclass + &key name direct-superclasses direct-slots + direct-default-initargs + documentation + &allow-other-keys) + (declare (ignore metaclass)) + (let ((class (std-allocate-instance (find-class 'standard-class)))) + (%set-class-name class name) + (setf (class-direct-subclasses class) ()) + (setf (class-direct-methods class) ()) + (%set-class-documentation class documentation) + (std-after-initialization-for-classes class + :direct-superclasses direct-superclasses + :direct-slots direct-slots + :direct-default-initargs direct-default-initargs) + class)) + +(defun std-after-initialization-for-classes (class + &key direct-superclasses direct-slots + direct-default-initargs + &allow-other-keys) + (let ((supers (or direct-superclasses + (list (find-class 'standard-object))))) + (setf (class-direct-superclasses class) supers) + (dolist (superclass supers) + (push class (class-direct-subclasses superclass)))) + (let ((slots (mapcar #'(lambda (slot-properties) + (apply #'make-direct-slot-definition class slot-properties)) + direct-slots))) + (setf (class-direct-slots class) slots) + (dolist (direct-slot slots) + (dolist (reader (%slot-definition-readers direct-slot)) + (add-reader-method class reader (%slot-definition-name direct-slot))) + (dolist (writer (%slot-definition-writers direct-slot)) + (add-writer-method class writer (%slot-definition-name direct-slot))))) + (setf (class-direct-default-initargs class) direct-default-initargs) + (funcall (if (eq (class-of class) (find-class 'standard-class)) + #'std-finalize-inheritance + #'finalize-inheritance) + class) + (values)) + +(defun canonical-slot-name (canonical-slot) + (getf canonical-slot :name)) + +(defun ensure-class (name &rest all-keys &allow-other-keys) + ;; Check for duplicate slots. + (let ((slots (getf all-keys :direct-slots))) + (dolist (s1 slots) + (let ((name1 (canonical-slot-name s1))) + (dolist (s2 (cdr (memq s1 slots))) + (when (eq name1 (canonical-slot-name s2)) + (error 'program-error "Duplicate slot ~S" name1)))))) + ;; Check for duplicate argument names in :DEFAULT-INITARGS. + (let ((names ())) + (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs)) + (name (car initargs) (car initargs))) + ((null initargs)) + (push name names)) + (do* ((names names (cdr names)) + (name (car names) (car names))) + ((null names)) + (when (memq name (cdr names)) + (error 'program-error + :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." + :format-arguments (list name))))) + (let ((direct-superclasses (getf all-keys :direct-superclasses))) + (dolist (class direct-superclasses) + (when (typep class 'built-in-class) + (error "Attempt to define a subclass of a built-in-class: ~S" class)))) + (let ((old-class (find-class name nil))) + (cond ((and old-class (eq name (%class-name old-class))) + (cond ((typep old-class 'built-in-class) + (error "The symbol ~S names a built-in class." name)) + ((typep old-class 'forward-referenced-class) + (let ((new-class (apply #'make-instance-standard-class + (find-class 'standard-class) + :name name all-keys))) + (%set-find-class name new-class) + (dolist (subclass (class-direct-subclasses old-class)) + (setf (class-direct-superclasses subclass) + (substitute new-class old-class + (class-direct-superclasses subclass)))) + new-class)) + (t + ;; We're redefining the class. + (%make-instances-obsolete old-class) + (apply #'std-after-initialization-for-classes old-class all-keys) + old-class))) + (t + (let ((class (apply #'make-instance-standard-class + (find-class 'standard-class) + :name name all-keys))) + (%set-find-class name class) + class))))) + +(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) + (unless (>= (length form) 3) + (error 'program-error "Wrong number of arguments for DEFCLASS.")) + (check-declaration-type name) + `(ensure-class ',name + :direct-superclasses + (canonicalize-direct-superclasses ',direct-superclasses) + :direct-slots + ,(canonicalize-direct-slots direct-slots) + ,@(canonicalize-defclass-options options))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct method-combination + name + operator + identity-with-one-argument + documentation) + + (defun expand-short-defcombin (whole) + (let* ((name (cadr whole)) + (documentation + (getf (cddr whole) :documentation "")) + (identity-with-one-arg + (getf (cddr whole) :identity-with-one-argument nil)) + (operator + (getf (cddr whole) :operator name))) + `(progn + (setf (get ',name 'method-combination-object) + (make-method-combination :name ',name + :operator ',operator + :identity-with-one-argument ',identity-with-one-arg + :documentation ',documentation)) + ',name))) + + (defun expand-long-defcombin (whole) + (declare (ignore whole)) + (error "The long form of DEFINE-METHOD-COMBINATION is not implemented."))) + +(defmacro define-method-combination (&whole form &rest args) + (declare (ignore args)) + (if (and (cddr form) + (listp (caddr form))) + (expand-long-defcombin form) + (expand-short-defcombin form))) + +(define-method-combination + :identity-with-one-argument t) +(define-method-combination and :identity-with-one-argument t) +(define-method-combination append :identity-with-one-argument nil) +(define-method-combination list :identity-with-one-argument nil) +(define-method-combination max :identity-with-one-argument t) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) +(define-method-combination progn :identity-with-one-argument t) + +(defstruct eql-specializer + object) + +(defparameter *eql-specializer-table* (make-hash-table :test 'eql)) + +(defun intern-eql-specializer (object) + (or (gethash object *eql-specializer-table*) + (setf (gethash object *eql-specializer-table*) + (make-eql-specializer :object object)))) + +;; MOP (p. 216) specifies the following reader generic functions: +;; generic-function-argument-precedence-order +;; generic-function-declarations +;; generic-function-lambda-list +;; generic-function-method-class +;; generic-function-method-combination +;; generic-function-methods +;; generic-function-name + +(defun generic-function-lambda-list (gf) + (%generic-function-lambda-list gf)) +(defsetf generic-function-lambda-list %set-generic-function-lambda-list) + +(defun (setf generic-function-documentation) (new-value gf) + (set-generic-function-documentation gf new-value)) + +(defun (setf generic-function-initial-methods) (new-value gf) + (set-generic-function-initial-methods gf new-value)) + +(defun (setf generic-function-methods) (new-value gf) + (set-generic-function-methods gf new-value)) + +(defun (setf generic-function-method-class) (new-value gf) + (set-generic-function-method-class gf new-value)) + +(defun (setf generic-function-method-combination) (new-value gf) + (set-generic-function-method-combination gf new-value)) + +(defun (setf generic-function-argument-precedence-order) (new-value gf) + (set-generic-function-argument-precedence-order gf new-value)) + +(declaim (ftype (function * t) classes-to-emf-table)) +(defun classes-to-emf-table (gf) + (generic-function-classes-to-emf-table gf)) + +(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)) + +(defun (setf method-qualifiers) (new-value method) + (set-method-qualifiers method new-value)) + +(defun (setf method-documentation) (new-value method) + (set-method-documentation method new-value)) + +;;; defgeneric + +(defmacro defgeneric (function-name lambda-list + &rest options-and-method-descriptions) + (let ((options ()) + (methods ()) + (documentation nil)) + (dolist (item options-and-method-descriptions) + (case (car item) + (declare) ; FIXME + (:documentation + (when documentation + (error 'program-error + :format-control "Documentation option was specified twice for generic function ~S." + :format-arguments (list function-name))) + (setf documentation t) + (push item options)) + (:method + (push + `(push (defmethod ,function-name ,@(cdr item)) + (generic-function-initial-methods (fdefinition ',function-name))) + methods)) + (t + (push item options)))) + (setf options (nreverse options) + methods (nreverse methods)) + `(prog1 + (%defgeneric + ',function-name + :lambda-list ',lambda-list + ,@(canonicalize-defgeneric-options options)) + , at methods))) + +(defun canonicalize-defgeneric-options (options) + (mapappend #'canonicalize-defgeneric-option options)) + +(defun canonicalize-defgeneric-option (option) + (case (car option) + (:generic-function-class + (list :generic-function-class `(find-class ',(cadr option)))) + (:method-class + (list :method-class `(find-class ',(cadr option)))) + (:method-combination + (list :method-combination `',(cdr option))) + (:argument-precedence-order + (list :argument-precedence-order `',(cdr option))) + (t + (list `',(car option) `',(cadr option))))) + +;; From OpenMCL. +(defun canonicalize-argument-precedence-order (apo req) + (cond ((equal apo req) nil) + ((not (eql (length apo) (length req))) + (error 'program-error + :format-control "Specified argument precedence order ~S does not match lambda list." + :format-arguments (list apo))) + (t (let ((res nil)) + (dolist (arg apo (nreverse res)) + (let ((index (position arg req))) + (if (or (null index) (memq index res)) + (error 'program-error + :format-control "Specified argument precedence order ~S does not match lambda list." + :format-arguments (list apo))) + (push index res))))))) + +(defun find-generic-function (name &optional (errorp t)) + (let ((function (and (fboundp name) (fdefinition name)))) + (when function + (when (typep function 'generic-function) + (return-from find-generic-function function)) + (when (and *traced-names* (find name *traced-names* :test #'equal)) + (setf function (untraced-function name)) + (when (typep function 'generic-function) + (return-from find-generic-function function))))) + (if errorp + (error "There is no generic function named ~S." name) + nil)) + +(defun lambda-lists-congruent-p (lambda-list1 lambda-list2) + (let* ((plist1 (analyze-lambda-list lambda-list1)) + (args1 (getf plist1 :required-args)) + (plist2 (analyze-lambda-list lambda-list2)) + (args2 (getf plist2 :required-args))) + (= (length args1) (length args2)))) + +(defun %defgeneric (function-name &rest all-keys) + (when (fboundp function-name) + (let ((gf (fdefinition function-name))) + (when (typep gf 'generic-function) + ;; Remove methods defined by previous DEFGENERIC forms. + (dolist (method (generic-function-initial-methods gf)) + (%remove-method gf method)) + (setf (generic-function-initial-methods gf) '())))) + (apply 'ensure-generic-function function-name all-keys)) + +(defun ensure-generic-function (function-name + &rest all-keys + &key + lambda-list + (generic-function-class (find-class 'standard-generic-function)) + (method-class the-class-standard-method) + (method-combination 'standard) + (argument-precedence-order nil apo-p) + documentation + &allow-other-keys) + (when (autoloadp function-name) + (resolve function-name)) + (let ((gf (find-generic-function function-name nil))) + (if gf + (progn + (unless (or (null (generic-function-methods gf)) + (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf))) + (error 'simple-error + :format-control "The lambda list ~S is incompatible with the existing methods of ~S." + :format-arguments (list lambda-list gf))) + (setf (generic-function-lambda-list gf) lambda-list) + (setf (generic-function-documentation gf) documentation) + (let* ((plist (analyze-lambda-list lambda-list)) + (required-args (getf plist ':required-args))) + (%set-gf-required-args gf required-args) + (when apo-p + (setf (generic-function-argument-precedence-order gf) + (if argument-precedence-order + (canonicalize-argument-precedence-order argument-precedence-order + required-args) + nil))) + (finalize-generic-function gf)) + gf) + (progn + (when (fboundp function-name) + (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)) + #'make-instance-standard-generic-function + #'make-instance) + generic-function-class + :name function-name + :method-class method-class + :method-combination method-combination + all-keys)) + gf)))) + +(defun initial-discriminating-function (gf args) + (set-funcallable-instance-function + gf + (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + #'std-compute-discriminating-function + #'compute-discriminating-function) + gf)) + (apply gf args)) + +(defun finalize-generic-function (gf) + (%finalize-generic-function gf) + (setf (classes-to-emf-table gf) (make-hash-table :test #'equal)) + (set-funcallable-instance-function + gf + (make-closure `(lambda (&rest args) + (initial-discriminating-function ,gf args)) + nil)) + ;; FIXME Do we need to warn on redefinition somewhere else? + (let ((*warn-on-redefinition* nil)) + (setf (fdefinition (%generic-function-name gf)) gf)) + (values)) + +(defun make-instance-standard-generic-function (generic-function-class + &key name lambda-list + method-class + method-combination + argument-precedence-order + documentation) + (declare (ignore generic-function-class)) + (let ((gf (std-allocate-instance (find-class 'standard-generic-function)))) + (%set-generic-function-name gf name) + (setf (generic-function-lambda-list gf) lambda-list) + (setf (generic-function-initial-methods gf) ()) + (setf (generic-function-methods gf) ()) + (setf (generic-function-method-class gf) method-class) + (setf (generic-function-method-combination gf) method-combination) + (setf (generic-function-documentation gf) documentation) + (setf (classes-to-emf-table gf) nil) + (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) + (required-args (getf plist ':required-args))) + (%set-gf-required-args gf required-args) + (setf (generic-function-argument-precedence-order gf) + (if argument-precedence-order + (canonicalize-argument-precedence-order argument-precedence-order + required-args) + nil))) + (finalize-generic-function gf) + gf)) + +(defun canonicalize-specializers (specializers) + (mapcar #'canonicalize-specializer specializers)) + +(defun canonicalize-specializer (specializer) + (cond ((classp specializer) + specializer) + ((eql-specializer-p specializer) + specializer) + ((symbolp specializer) + (find-class specializer)) + ((and (consp specializer) + (eq (car specializer) 'eql)) + (let ((object (cadr specializer))) + (when (and (consp object) + (eq (car object) 'quote)) + (setf object (cadr object))) + (intern-eql-specializer object))) + ((and (consp specializer) + (eq (car specializer) 'java:jclass)) + (let ((class-name (cadr specializer))) + (when (and (consp class-name) + (eq (car class-name) 'quote)) + (setf class-name (cadr class-name))) + (java::%find-java-class class-name))) + (t + (error "Unknown specializer: ~S" specializer)))) + +(defun parse-defmethod (args) + (let ((function-name (car args)) + (qualifiers ()) + (specialized-lambda-list ()) + (body ()) + (parse-state :qualifiers)) + (dolist (arg (cdr args)) + (ecase parse-state + (:qualifiers + (if (and (atom arg) (not (null arg))) + (push arg qualifiers) + (progn + (setf specialized-lambda-list arg) + (setf parse-state :body)))) + (:body (push arg body)))) + (setf qualifiers (nreverse qualifiers) + body (nreverse body)) + (multiple-value-bind (real-body declarations documentation) + (parse-body body) + (values function-name + qualifiers + (extract-lambda-list specialized-lambda-list) + (extract-specializers specialized-lambda-list) + documentation + declarations + (list* 'block + (fdefinition-block-name function-name) + real-body))))) + +(defun required-portion (gf args) + (let ((number-required (length (gf-required-args gf)))) + (when (< (length args) number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf)))) + (subseq args 0 number-required))) + +(defun extract-lambda-list (specialized-lambda-list) + (let* ((plist (analyze-lambda-list specialized-lambda-list)) + (requireds (getf plist :required-names)) + (rv (getf plist :rest-var)) + (ks (getf plist :key-args)) + (keysp (getf plist :keysp)) + (aok (getf plist :allow-other-keys)) + (opts (getf plist :optional-args)) + (auxs (getf plist :auxiliary-args))) + `(, at requireds + ,@(if rv `(&rest ,rv) ()) + ,@(if (or ks keysp aok) `(&key , at ks) ()) + ,@(if aok '(&allow-other-keys) ()) + ,@(if opts `(&optional , at opts) ()) + ,@(if auxs `(&aux , at auxs) ())))) + +(defun extract-specializers (specialized-lambda-list) + (let ((plist (analyze-lambda-list specialized-lambda-list))) + (getf plist ':specializers))) + +(defun get-keyword-from-arg (arg) + (if (listp arg) + (if (listp (car arg)) + (caar arg) + (make-keyword (car arg))) + (make-keyword arg))) + +(defun analyze-lambda-list (lambda-list) + (let ((keys ()) ; Just the keywords + (key-args ()) ; Keywords argument specs + (keysp nil) ; + (required-names ()) ; Just the variable names + (required-args ()) ; Variable names & specializers + (specializers ()) ; Just the specializers + (rest-var nil) + (optionals ()) + (auxs ()) + (allow-other-keys nil) + (state :parsing-required)) + (dolist (arg lambda-list) + (if (member arg lambda-list-keywords) + (ecase arg + (&optional + (setq state :parsing-optional)) + (&rest + (setq state :parsing-rest)) + (&key + (setq keysp t) + (setq state :parsing-key)) + (&allow-other-keys + (setq allow-other-keys 't)) + (&aux + (setq state :parsing-aux))) + (case state + (:parsing-required + (push-on-end arg required-args) + (if (listp arg) + (progn (push-on-end (car arg) required-names) + (push-on-end (cadr arg) specializers)) + (progn (push-on-end arg required-names) + (push-on-end 't specializers)))) + (:parsing-optional (push-on-end arg optionals)) + (:parsing-rest (setq rest-var arg)) + (:parsing-key + (push-on-end (get-keyword-from-arg arg) keys) + (push-on-end arg key-args)) + (:parsing-aux (push-on-end arg auxs))))) + (list :required-names required-names + :required-args required-args + :specializers specializers + :rest-var rest-var + :keywords keys + :key-args key-args + :keysp keysp + :auxiliary-args auxs + :optional-args optionals + :allow-other-keys allow-other-keys))) + +#+nil +(defun check-method-arg-info (gf arg-info method) + (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (flet ((lose (string &rest args) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list method gf string args))) + (comparison-description (x y) + (if (> x y) "more" "fewer"))) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info)) + (gf-keywords (arg-info-keys arg-info))) + (unless (= nreq gf-nreq) + (lose + "the method has ~A required arguments than the generic function." + (comparison-description nreq gf-nreq))) + (unless (= nopt gf-nopt) + (lose + "the method has ~A optional arguments than the generic function." + (comparison-description nopt gf-nopt))) + (unless (eq (or keysp restp) gf-key/rest-p) + (lose + "the method and generic function differ in whether they accept~_~ + &REST or &KEY arguments.")) + (when (consp gf-keywords) + (unless (or (and restp (not keysp)) + allow-other-keys-p + (every (lambda (k) (memq k keywords)) gf-keywords)) + (lose "the method does not accept each of the &KEY arguments~2I~_~ + ~S." + gf-keywords))))))) + +(defun check-method-lambda-list (method-lambda-list gf-lambda-list) + (let* ((gf-restp (not (null (memq '&rest gf-lambda-list)))) + (gf-plist (analyze-lambda-list gf-lambda-list)) + (gf-keysp (getf gf-plist :keysp)) + (gf-keywords (getf gf-plist :keywords)) + (method-plist (analyze-lambda-list method-lambda-list)) + (method-restp (not (null (memq '&rest method-lambda-list)))) + (method-keysp (getf method-plist :keysp)) + (method-keywords (getf method-plist :keywords)) + (method-allow-other-keys-p (getf method-plist :allow-other-keys))) + (unless (= (length (getf gf-plist :required-args)) + (length (getf method-plist :required-args))) + (error "The method has the wrong number of required arguments for the generic function.")) + (unless (= (length (getf gf-plist :optional-args)) + (length (getf method-plist :optional-args))) + (error "The method has the wrong number of optional arguments for the generic function.")) + (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp)) + (error "The method and the generic function differ in whether they accept &REST or &KEY arguments.")) + (when (consp gf-keywords) + (unless (or (and method-restp (not method-keysp)) + method-allow-other-keys-p + (every (lambda (k) (memq k method-keywords)) gf-keywords)) + (error "The method does not accept all of the keyword arguments defined for the generic function."))))) + +(declaim (ftype (function * method) ensure-method)) +(defun ensure-method (name &rest all-keys) + (let ((method-lambda-list (getf all-keys :lambda-list)) + (gf (find-generic-function name nil))) + (if gf + (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) + (apply #'make-instance-standard-method gf all-keys) + (apply #'make-instance (generic-function-method-class gf) all-keys)))) + (%add-method gf method) + method))) + +(defun make-instance-standard-method (gf + &key + lambda-list + qualifiers + specializers + documentation + function + fast-function) + (declare (ignore gf)) + (let ((method (std-allocate-instance the-class-standard-method))) + (setf (method-lambda-list method) lambda-list) + (setf (method-qualifiers method) qualifiers) + (%set-method-specializers method (canonicalize-specializers specializers)) + (setf (method-documentation method) documentation) + (%set-method-generic-function method nil) + (%set-method-function method function) + (%set-method-fast-function method fast-function) + method)) + +(defun %add-method (gf method) + (when (%method-generic-function method) + (error 'simple-error + :format-control "ADD-METHOD: ~S is a method of ~S." + :format-arguments (list method (%method-generic-function method)))) + ;; Remove existing method with same qualifiers and specializers (if any). + (let ((old-method (%find-method gf (method-qualifiers method) + (%method-specializers method) nil))) + (when old-method + (%remove-method gf old-method))) + (%set-method-generic-function method gf) + (push method (generic-function-methods gf)) + (dolist (specializer (%method-specializers method)) + (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? + (pushnew method (class-direct-methods specializer)))) + (finalize-generic-function gf) + gf) + +(defun %remove-method (gf method) + (setf (generic-function-methods gf) + (remove method (generic-function-methods gf))) + (%set-method-generic-function method nil) + (dolist (specializer (%method-specializers method)) + (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? + (setf (class-direct-methods specializer) + (remove method (class-direct-methods specializer))))) + (finalize-generic-function gf) + gf) + +(defun %find-method (gf qualifiers specializers &optional (errorp t)) + ;; "If the specializers argument does not correspond in length to the number + ;; of required arguments of the generic-function, an an error of type ERROR + ;; is signaled." + (unless (= (length specializers) (length (gf-required-args gf))) + (error "The specializers argument has length ~S, but ~S has ~S required parameters." + (length specializers) + gf + (length (gf-required-args gf)))) + (let* ((canonical-specializers (canonicalize-specializers specializers)) + (method + (find-if #'(lambda (method) + (and (equal qualifiers + (method-qualifiers method)) + (equal canonical-specializers + (%method-specializers method)))) + (generic-function-methods gf)))) + (if (and (null method) errorp) + (error "No such method for ~S." (%generic-function-name gf)) + method))) + +(defun methods-contain-eql-specializer-p (methods) + (dolist (method methods nil) + (when (dolist (spec (%method-specializers method) nil) + (when (eql-specializer-p spec) (return t))) + (return t)))) + +(defun fast-callable-p (gf) + (and (eq (generic-function-method-combination gf) 'standard) + (null (intersection (%generic-function-lambda-list gf) + '(&rest &optional &key &allow-other-keys &aux))))) + +(declaim (ftype (function * t) slow-method-lookup-1)) + +(declaim (ftype (function (t t t) t) slow-reader-lookup)) +(defun slow-reader-lookup (gf layout slot-name) + (let ((location (layout-slot-location layout slot-name))) + (cache-slot-location gf layout location) + location)) + +(defun std-compute-discriminating-function (gf) + (let ((code + (cond ((methods-contain-eql-specializer-p (generic-function-methods gf)) + (make-closure `(lambda (&rest args) + (slow-method-lookup ,gf args)) + nil)) + ((and (= (length (generic-function-methods gf)) 1) + (typep (car (generic-function-methods gf)) 'standard-reader-method)) +;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) + (make-closure + (let* ((method (%car (generic-function-methods gf))) + (class (car (%method-specializers method))) + (slot-name (reader-method-slot-name method))) + `(lambda (arg) + (declare (optimize speed)) + (let* ((layout (std-instance-layout arg)) + (location (get-cached-slot-location ,gf layout))) + (unless location + (unless (simple-typep arg ,class) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type ,class)) + (setf location (slow-reader-lookup ,gf layout ',slot-name))) + (if (consp location) + ;; Shared slot. + (cdr location) + (standard-instance-access arg location))))) + nil)) + (t + (let* ((emf-table (classes-to-emf-table gf)) + (number-required (length (gf-required-args gf))) + (lambda-list (%generic-function-lambda-list gf)) + (exact (null (intersection lambda-list + '(&rest &optional &key + &allow-other-keys &aux))))) + (make-closure + (cond ((= number-required 1) + (if exact + (cond ((and (eq (generic-function-method-combination gf) 'standard) + (= (length (generic-function-methods gf)) 1)) + (let* ((method (%car (generic-function-methods gf))) + (class (car (%method-specializers method))) + (function (or (%method-fast-function method) + (%method-function method)))) + `(lambda (arg) + (declare (optimize speed)) + (unless (simple-typep arg ,class) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type ,class)) + (funcall ,function arg)))) + (t + `(lambda (arg) + (declare (optimize speed)) + (let* ((class (class-of arg)) + (emfun (or (gethash1 class ,emf-table) + (slow-method-lookup-1 ,gf class)))) + (if emfun + (funcall emfun (list arg)) + (apply #'no-applicable-method ,gf (list arg))))) + )) + `(lambda (&rest args) + (declare (optimize speed)) + (unless (>= (length args) 1) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name ,gf)))) + (let ((emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))))) + ((= number-required 2) + (if exact + `(lambda (arg1 arg2) + (declare (optimize speed)) + (let* ((args (list arg1 arg2)) + (emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))) + `(lambda (&rest args) + (declare (optimize speed)) + (unless (>= (length args) 2) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name ,gf)))) + (let ((emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))))) + ((= number-required 3) + (if exact + `(lambda (arg1 arg2 arg3) + (declare (optimize speed)) + (let* ((args (list arg1 arg2 arg3)) + (emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))) + `(lambda (&rest args) + (declare (optimize speed)) + (unless (>= (length args) 3) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name ,gf)))) + (let ((emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))))) + (t + `(lambda (&rest args) + (declare (optimize speed)) + (unless (,(if exact '= '>=) (length args) ,number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name ,gf)))) + (let ((emfun (get-cached-emf ,gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup ,gf args)))))) + nil)))))) + + (when (and (fboundp 'compile) + (not (autoloadp 'compile))) + (setf code (or (compile nil code) code))) + + code)) + +(defun method-applicable-p (method args) + (do* ((specializers (%method-specializers method) (cdr specializers)) + (args args (cdr args))) + ((null specializers) t) + (let ((specializer (car specializers))) + (if (typep specializer 'eql-specializer) + (unless (eql (car args) (eql-specializer-object specializer)) + (return nil)) + (unless (subclassp (class-of (car args)) specializer) + (return nil)))))) + +(defun %compute-applicable-methods (gf args) + (let ((required-classes (mapcar #'class-of (required-portion gf args))) + (methods '())) + (dolist (method (generic-function-methods gf)) + (when (method-applicable-p method args) + (push method methods))) + (if (or (null methods) (null (%cdr methods))) + methods + (sort methods + (if (eq (class-of gf) (find-class 'standard-generic-function)) + #'(lambda (m1 m2) + (std-method-more-specific-p m1 m2 required-classes + (generic-function-argument-precedence-order gf))) + #'(lambda (m1 m2) + (method-more-specific-p gf m1 m2 required-classes))))))) + +(defun method-applicable-p-using-classes (method classes) + (do* ((specializers (%method-specializers method) (cdr specializers)) + (classes classes (cdr classes))) + ((null specializers) t) + (let ((specializer (car specializers))) + (unless (subclassp (car classes) specializer) + (return nil))))) + +(defun %compute-applicable-methods-using-classes (gf required-classes) + (let ((methods '())) + (dolist (method (generic-function-methods gf)) + (when (method-applicable-p-using-classes method required-classes) + (push method methods))) + (if (or (null methods) (null (%cdr methods))) + methods + (sort methods + (if (eq (class-of gf) (find-class 'standard-generic-function)) + #'(lambda (m1 m2) + (std-method-more-specific-p m1 m2 required-classes + (generic-function-argument-precedence-order gf))) + #'(lambda (m1 m2) + (method-more-specific-p gf m1 m2 required-classes))))))) + +(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)) + #'std-compute-effective-method-function + #'compute-effective-method-function) + gf applicable-methods))) + (cache-emf gf args emfun) + (funcall emfun args)) + (apply #'no-applicable-method gf args)))) + +(defun slow-method-lookup-1 (gf class) + (let ((applicable-methods (%compute-applicable-methods-using-classes gf (list class)))) + (if applicable-methods + (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + #'std-compute-effective-method-function + #'compute-effective-method-function) + gf applicable-methods))) + (when emfun + (setf (gethash class (classes-to-emf-table gf)) emfun)) + emfun)))) + +(defun sub-specializer-p (c1 c2 c-arg) + (find c2 (cdr (memq c1 (%class-precedence-list c-arg))))) + +(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order) + (if argument-precedence-order + (let ((specializers-1 (%method-specializers method1)) + (specializers-2 (%method-specializers method2))) + (dolist (index argument-precedence-order) + (let ((spec1 (nth index specializers-1)) + (spec2 (nth index specializers-2))) + (unless (eq spec1 spec2) + (cond ((eql-specializer-p spec1) + (return t)) + ((eql-specializer-p spec2) + (return nil)) + (t + (return (sub-specializer-p spec1 spec2 + (nth index required-classes))))))))) + (do ((specializers-1 (%method-specializers method1) (cdr specializers-1)) + (specializers-2 (%method-specializers method2) (cdr specializers-2)) + (classes required-classes (cdr classes))) + ((null specializers-1) nil) + (let ((spec1 (car specializers-1)) + (spec2 (car specializers-2))) + (unless (eq spec1 spec2) + (cond ((eql-specializer-p spec1) + (return t)) + ((eql-specializer-p spec2) + (return nil)) + (t + (return (sub-specializer-p spec1 spec2 (car classes)))))))))) + +(defun primary-method-p (method) + (null (intersection '(:before :after :around) (method-qualifiers method)))) + +(defun before-method-p (method) + (equal '(:before) (method-qualifiers method))) + +(defun after-method-p (method) + (equal '(:after) (method-qualifiers method))) + +(defun around-method-p (method) + (equal '(:around) (method-qualifiers method))) + +(defun std-compute-effective-method-function (gf methods) + (let* ((mc (generic-function-method-combination gf)) + (mc-name (if (atom mc) mc (%car mc))) + (options (if (atom mc) '() (%cdr mc))) + (order (car options)) + (primaries '()) + (arounds '()) + around + emf-form) + (dolist (m methods) + (let ((qualifiers (method-qualifiers m))) + (cond ((null qualifiers) + (if (eq mc-name 'standard) + (push m primaries) + (error "Method combination type mismatch."))) + ((cdr qualifiers) + (error "Invalid method qualifiers.")) + ((eq (car qualifiers) :around) + (push m arounds)) + ((eq (car qualifiers) mc-name) + (push m primaries)) + ((memq (car qualifiers) '(:before :after))) + (t + (error "Invalid method qualifiers."))))) + (unless (eq order :most-specific-last) + (setf primaries (nreverse primaries))) + (setf arounds (nreverse arounds)) + (setf around (car arounds)) + (when (null primaries) + (error "No primary methods for the generic function ~S." gf)) + (cond (around + (let ((next-emfun + (funcall + (if (eq (class-of gf) (find-class 'standard-generic-function)) + #'std-compute-effective-method-function + #'compute-effective-method-function) + gf (remove around methods)))) + (setf emf-form +;; `(lambda (args) +;; (funcall ,(%method-function around) args ,next-emfun)) + (generate-emf-lambda (%method-function around) next-emfun) + ))) + ((eq mc-name 'standard) + (let* ((next-emfun (compute-primary-emfun (cdr primaries))) + (befores (remove-if-not #'before-method-p methods)) + (reverse-afters + (reverse (remove-if-not #'after-method-p methods)))) + (setf emf-form + (cond ((and (null befores) (null reverse-afters)) + (if (%method-fast-function (car primaries)) + (ecase (length (gf-required-args gf)) + (1 + `(lambda (args) + (declare (optimize speed)) + (funcall ,(%method-fast-function (car primaries)) (car args)))) + (2 + `(lambda (args) + (declare (optimize speed)) + (funcall ,(%method-fast-function (car primaries)) + (car args) + (cadr args))))) +;; `(lambda (args) +;; (declare (optimize speed)) +;; (funcall ,(%method-function (car primaries)) args ,next-emfun)) + (generate-emf-lambda (%method-function (car primaries)) + next-emfun) + )) + (t + `(lambda (args) + (declare (optimize speed)) + (dolist (before ',befores) + (funcall (%method-function before) args nil)) + (multiple-value-prog1 + (funcall (%method-function ,(car primaries)) args ,next-emfun) + (dolist (after ',reverse-afters) + (funcall (%method-function after) args nil))))))))) + (t + (let ((mc-obj (get mc-name 'method-combination-object))) + (unless mc-obj + (error "Unsupported method combination type ~A." mc-name)) + (let* ((operator (method-combination-operator mc-obj)) + (ioa (method-combination-identity-with-one-argument mc-obj))) + (setf emf-form + (if (and (null (cdr primaries)) + (not (null ioa))) +;; `(lambda (args) +;; (funcall ,(%method-function (car primaries)) args nil)) + (generate-emf-lambda (%method-function (car primaries)) nil) + `(lambda (args) + (,operator ,@(mapcar + (lambda (primary) + `(funcall ,(%method-function primary) args nil)) + primaries))))))))) + (or (ignore-errors (compile nil emf-form)) + (coerce-to-function emf-form)))) + +(defun generate-emf-lambda (method-function next-emfun) + `(lambda (args) + (declare (optimize speed)) + (funcall ,method-function args ,next-emfun))) + +;;; compute an effective method function from a list of primary methods: + +(defun compute-primary-emfun (methods) + (if (null methods) + nil + (let ((next-emfun (compute-primary-emfun (cdr methods)))) + #'(lambda (args) + (funcall (%method-function (car methods)) args next-emfun))))) + +(defvar *call-next-method-p*) +(defvar *next-method-p-p*) + +(defun walk-form (form) + (cond ((atom form) + (cond ((eq form 'call-next-method) + (setf *call-next-method-p* t)) + ((eq form 'next-method-p) + (setf *next-method-p-p* t)))) + (t + (walk-form (%car form)) + (walk-form (%cdr form))))) + +(defun compute-method-function (lambda-expression) + (let ((lambda-list (allow-other-keys (cadr lambda-expression))) + (body (cddr lambda-expression)) + (*call-next-method-p* nil) + (*next-method-p-p* nil)) + (multiple-value-bind (body declarations) (parse-body body) + (let ((ignorable-vars '())) + (dolist (var lambda-list) + (if (memq var lambda-list-keywords) + (return) + (push var ignorable-vars))) + (push `(declare (ignorable , at ignorable-vars)) declarations)) + (walk-form body) + (cond ((or *call-next-method-p* *next-method-p-p*) + `(lambda (args next-emfun) + (flet ((call-next-method (&rest cnm-args) + (if (null next-emfun) + (error "No next method for generic function.") + (funcall next-emfun (or cnm-args args)))) + (next-method-p () + (not (null next-emfun)))) + (declare (ignorable call-next-method next-method-p)) + (apply #'(lambda ,lambda-list , at declarations , at body) args)))) + ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))) + ;; Required parameters only. + (case (length lambda-list) + (1 + `(lambda (args next-emfun) + (declare (ignore next-emfun)) + (let ((,(%car lambda-list) (%car args))) + (declare (ignorable ,(%car lambda-list))) + , at declarations , at body))) + (2 + `(lambda (args next-emfun) + (declare (ignore next-emfun)) + (let ((,(%car lambda-list) (%car args)) + (,(%cadr lambda-list) (%cadr args))) + (declare (ignorable ,(%car lambda-list) + ,(%cadr lambda-list))) + , at declarations , at body))) + (3 + `(lambda (args next-emfun) + (declare (ignore next-emfun)) + (let ((,(%car lambda-list) (%car args)) + (,(%cadr lambda-list) (%cadr args)) + (,(%caddr lambda-list) (%caddr args))) + (declare (ignorable ,(%car lambda-list) + ,(%cadr lambda-list) + ,(%caddr lambda-list))) + , at declarations , at body))) + (t + `(lambda (args next-emfun) + (declare (ignore next-emfun)) + (apply #'(lambda ,lambda-list , at declarations , at body) args))))) + (t + `(lambda (args next-emfun) + (declare (ignore next-emfun)) + (apply #'(lambda ,lambda-list , at declarations , at body) args))))))) + +(defun compute-method-fast-function (lambda-expression) + (let ((lambda-list (allow-other-keys (cadr lambda-expression)))) + (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)) + (return-from compute-method-fast-function nil)) + ;; Only required args. + (let ((body (cddr lambda-expression)) + (*call-next-method-p* nil) + (*next-method-p-p* nil)) + (multiple-value-bind (body declarations) (parse-body body) + (walk-form body) + (when (or *call-next-method-p* *next-method-p-p*) + (return-from compute-method-fast-function nil)) + (let ((decls `(declare (ignorable , at lambda-list)))) + (setf lambda-expression + (list* (car lambda-expression) + (cadr lambda-expression) + decls + (cddr lambda-expression)))) + (case (length lambda-list) + (1 +;; `(lambda (args next-emfun) +;; (let ((,(%car lambda-list) (%car args))) +;; (declare (ignorable ,(%car lambda-list))) +;; , at declarations , at body))) + lambda-expression) + (2 +;; `(lambda (args next-emfun) +;; (let ((,(%car lambda-list) (%car args)) +;; (,(%cadr lambda-list) (%cadr args))) +;; (declare (ignorable ,(%car lambda-list) +;; ,(%cadr lambda-list))) +;; , at declarations , at body))) + lambda-expression) +;; (3 +;; `(lambda (args next-emfun) +;; (let ((,(%car lambda-list) (%car args)) +;; (,(%cadr lambda-list) (%cadr args)) +;; (,(%caddr lambda-list) (%caddr args))) +;; (declare (ignorable ,(%car lambda-list) +;; ,(%cadr lambda-list) +;; ,(%caddr lambda-list))) +;; , at declarations , at body))) + (t + nil)))))) + +;; From CLHS section 7.6.5: +;; "When a generic function or any of its methods mentions &key in a lambda +;; list, the specific set of keyword arguments accepted by the generic function +;; varies according to the applicable methods. The set of keyword arguments +;; accepted by the generic function for a particular call is the union of the +;; keyword arguments accepted by all applicable methods and the keyword +;; arguments mentioned after &key in the generic function definition, if any." +;; Adapted from Sacla. +(defun allow-other-keys (lambda-list) + (if (and (member '&key lambda-list) + (not (member '&allow-other-keys lambda-list))) + (let* ((key-end (or (position '&aux lambda-list) (length lambda-list))) + (aux-part (subseq lambda-list key-end))) + `(,@(subseq lambda-list 0 key-end) &allow-other-keys , at aux-part)) + lambda-list)) + +(defmacro defmethod (&rest args) + (multiple-value-bind + (function-name qualifiers lambda-list specializers documentation declarations body) + (parse-defmethod args) + (let* ((specializers-form '()) + (lambda-expression `(lambda ,lambda-list , at declarations ,body)) + (method-function (compute-method-function lambda-expression)) + (fast-function (compute-method-fast-function lambda-expression)) + ) + (dolist (specializer specializers) + (cond ((and (consp specializer) (eq (car specializer) 'eql)) + (push `(list 'eql ,(cadr specializer)) specializers-form)) + (t + (push `',specializer specializers-form)))) + (setf specializers-form `(list ,@(nreverse specializers-form))) + `(progn + (ensure-method ',function-name + :lambda-list ',lambda-list + :qualifiers ',qualifiers + :specializers ,specializers-form + ,@(if documentation `(:documentation ,documentation)) + :function (function ,method-function) + ,@(if fast-function `(:fast-function (function ,fast-function))) + ))))) + +;;; Reader and writer methods + +(defun make-instance-standard-reader-method (gf + &key + lambda-list + qualifiers + specializers + documentation + function + fast-function + slot-name) + (declare (ignore gf)) + (let ((method (std-allocate-instance (find-class 'standard-reader-method)))) + (setf (method-lambda-list method) lambda-list) + (setf (method-qualifiers method) qualifiers) + (%set-method-specializers method (canonicalize-specializers specializers)) + (setf (method-documentation method) documentation) + (%set-method-generic-function method nil) + (%set-method-function method function) + (%set-method-fast-function method fast-function) + (set-reader-method-slot-name method slot-name) + method)) + +(defun add-reader-method (class function-name slot-name) + (let* ((lambda-expression + (if (eq (class-of class) (find-class 'standard-class)) + `(lambda (object) (std-slot-value object ',slot-name))) + `(lambda (object) (slot-value object ',slot-name))) + (method-function (compute-method-function lambda-expression)) + (fast-function (compute-method-fast-function lambda-expression))) + (let ((method-lambda-list '(object)) + (gf (find-generic-function function-name nil))) + (if gf + (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) + (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list))) + (let ((method + (make-instance-standard-reader-method gf + :lambda-list '(object) + :qualifiers () + :specializers (list class) + :function (if (autoloadp 'compile) + method-function + (compile nil method-function)) + :fast-function (if (autoloadp 'compile) + fast-function + (compile nil fast-function)) + :slot-name slot-name))) + (%add-method gf method) + method)))) + +(defun add-writer-method (class function-name slot-name) + (let* ((lambda-expression + (if (eq (class-of class) (find-class 'standard-class)) + `(lambda (new-value object) + (setf (std-slot-value object ',slot-name) new-value)) + `(lambda (new-value object) + (setf (slot-value object ',slot-name) new-value)))) + (method-function (compute-method-function lambda-expression)) + (fast-function (compute-method-fast-function lambda-expression)) + ) + (ensure-method function-name + :lambda-list '(new-value object) + :qualifiers () + :specializers (list (find-class 't) class) +;; :function `(function ,method-function) + :function (if (autoloadp 'compile) + method-function + (compile nil method-function)) + :fast-function (if (autoloadp 'compile) + fast-function + (compile nil fast-function)) + ))) + +(fmakunbound 'class-name) + +(defgeneric class-name (class)) + +(defmethod class-name ((class class)) + (%class-name class)) + +(defgeneric (setf class-name) (new-value class)) + +(defmethod (setf class-name) (new-value (class class)) + (%set-class-name class new-value)) + +(when (autoloadp 'class-precedence-list) + (fmakunbound 'class-precedence-list)) + +(defgeneric class-precedence-list (class)) + +(defmethod class-precedence-list ((class class)) + (%class-precedence-list class)) + +(defgeneric documentation (x doc-type)) + +(defgeneric (setf documentation) (new-value x doc-type)) + +(defmethod documentation ((x symbol) doc-type) + (%documentation x doc-type)) + +(defmethod (setf documentation) (new-value (x symbol) doc-type) + (%set-documentation x doc-type new-value)) + +(defmethod documentation ((x function) doc-type) + (%documentation x doc-type)) + +(defmethod (setf documentation) (new-value (x function) doc-type) + (%set-documentation x doc-type new-value)) + +;; FIXME This should be a weak hashtable! +(defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) + +(defmethod documentation ((x list) (doc-type (eql 'function))) + (let ((alist (gethash x *list-documentation-hashtable*))) + (and alist (cdr (assoc doc-type alist))))) + +(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) + (let ((alist (gethash x *list-documentation-hashtable*))) + (and alist (cdr (assoc doc-type alist))))) + +(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) + (let* ((alist (gethash x *list-documentation-hashtable*)) + (entry (and alist (assoc doc-type alist)))) + (cond (entry + (setf (cdr entry) new-value)) + (t + (setf (gethash x *list-documentation-hashtable*) + (push (cons doc-type new-value) alist))))) + new-value) + +(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro))) + (let* ((alist (gethash x *list-documentation-hashtable*)) + (entry (and alist (assoc doc-type alist)))) + (cond (entry + (setf (cdr entry) new-value)) + (t + (setf (gethash x *list-documentation-hashtable*) + (push (cons doc-type new-value) alist))))) + new-value) + +(defmethod documentation ((x standard-class) (doc-type (eql 't))) + (class-documentation x)) + +(defmethod documentation ((x standard-class) (doc-type (eql 'type))) + (class-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't))) + (%set-class-documentation x new-value)) + +(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type))) + (%set-class-documentation x new-value)) + +(defmethod documentation ((x structure-class) (doc-type (eql 't))) + (%documentation x doc-type)) + +(defmethod documentation ((x structure-class) (doc-type (eql 'type))) + (%documentation x doc-type)) + +(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) + (%set-documentation x doc-type new-value)) + +(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) + (%set-documentation x doc-type new-value)) + +(defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) + (generic-function-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't))) + (setf (generic-function-documentation x) new-value)) + +(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function))) + (generic-function-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function))) + (setf (generic-function-documentation x) new-value)) + +(defmethod documentation ((x standard-method) (doc-type (eql 't))) + (method-documentation x)) + +(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't))) + (setf (method-documentation x) new-value)) + +(defmethod documentation ((x package) (doc-type (eql 't))) + (%documentation x doc-type)) + +(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) + (%set-documentation x doc-type new-value)) + +;;; Slot access + +(defun set-slot-value-using-class (new-value class instance slot-name) + (declare (ignore class)) ; FIXME + (setf (std-slot-value instance slot-name) new-value)) + +(defgeneric slot-value-using-class (class instance slot-name)) + +(defmethod slot-value-using-class ((class standard-class) instance slot-name) + (std-slot-value instance slot-name)) + +(defgeneric (setf slot-value-using-class) (new-value class instance slot-name)) +(defmethod (setf slot-value-using-class) (new-value + (class standard-class) + instance + slot-name) + (setf (std-slot-value instance slot-name) new-value)) + +(defgeneric slot-exists-p-using-class (class instance slot-name)) + +(defmethod slot-exists-p-using-class (class instance slot-name) + nil) + +(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name) + (std-slot-exists-p instance slot-name)) + +(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name) + (dolist (dsd (%class-slots class)) + (when (eq (sys::dsd-name dsd) slot-name) + (return-from slot-exists-p-using-class t))) + nil) + +(defgeneric slot-boundp-using-class (class instance slot-name)) +(defmethod slot-boundp-using-class ((class standard-class) instance slot-name) + (std-slot-boundp instance slot-name)) + +(defgeneric slot-makunbound-using-class (class instance slot-name)) +(defmethod slot-makunbound-using-class ((class standard-class) + instance + slot-name) + (std-slot-makunbound instance slot-name)) + +(defgeneric slot-missing (class instance slot-name operation &optional new-value)) + +(defmethod slot-missing ((class t) instance slot-name operation &optional new-value) + (declare (ignore new-value)) + (error "The slot ~S is missing from the class ~S." slot-name class)) + +(defgeneric slot-unbound (class instance slot-name)) + +(defmethod slot-unbound ((class t) instance slot-name) + (error 'unbound-slot :instance instance :name slot-name)) + +;;; Instance creation and initialization + +(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) + +(defmethod allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + (std-allocate-instance class)) + +(defmethod allocate-instance ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (%make-structure (%class-name class) + (make-list (length (%class-slots class)) + :initial-element +slot-unbound+))) + +;; "The set of valid initialization arguments for a class is the set of valid +;; initialization arguments that either fill slots or supply arguments to +;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." +;; 7.1.2 +#+nil +(defun check-initargs (class initargs) + (when (oddp (length initargs)) + (error 'program-error + :format-control "Odd number of keyword arguments.")) + (unless (getf initargs :allow-other-keys) + (let ((slots (%class-slots class))) + (do* ((tail initargs (cddr tail)) + (initarg (car tail) (car tail))) + ((null tail)) + (unless (or (valid-initarg-p initarg slots) + (eq initarg :allow-other-keys)) + (error 'program-error + :format-control "Invalid initarg ~S." + :format-arguments (list initarg))))))) + +;; FIXME +(defun check-initargs (class initargs) + (declare (ignore class initargs))) + +(defun valid-initarg-p (initarg slots) + (dolist (slot slots nil) + (let ((valid-initargs (%slot-definition-initargs slot))) + (when (memq initarg valid-initargs) + (return t))))) + +(defgeneric make-instance (class &rest initargs &key &allow-other-keys)) + +(defmethod make-instance ((class standard-class) &rest initargs) + (when (oddp (length initargs)) + (error 'program-error :format-control "Odd number of keyword arguments.")) + (unless (class-finalized-p class) + (std-finalize-inheritance class)) + (let ((class-default-initargs (class-default-initargs class))) + (when class-default-initargs + (let ((default-initargs '())) + (do* ((list class-default-initargs (cddr list)) + (key (car list) (car list)) + (fn (cadr list) (cadr list))) + ((null list)) + (when (eq (getf initargs key 'not-found) 'not-found) + (setf default-initargs (append default-initargs (list key (funcall fn)))))) + (setf initargs (append initargs default-initargs))))) + (check-initargs class initargs) + (let ((instance (std-allocate-instance class))) + (apply #'initialize-instance instance initargs) + instance)) + +(defmethod make-instance ((class symbol) &rest initargs) + (apply #'make-instance (find-class class) initargs)) + +(defgeneric initialize-instance (instance &key)) + +(defmethod initialize-instance ((instance standard-object) &rest initargs) + (apply #'shared-initialize instance t initargs)) + +(defgeneric reinitialize-instance (instance &key)) + +;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the +;; validity of initargs and signals an error if an initarg is supplied that is +;; not declared as valid. The method then calls the generic function SHARED- +;; INITIALIZE with the following arguments: the instance, nil (which means no +;; slots should be initialized according to their initforms), and the initargs +;; it received." +(defmethod reinitialize-instance ((instance standard-object) &rest initargs) + (apply #'shared-initialize instance () initargs)) + +(defun std-shared-initialize (instance slot-names all-keys) + (when (oddp (length all-keys)) + (error 'program-error :format-control "Odd number of keyword arguments.")) + (dolist (slot (%class-slots (class-of instance))) + (let ((slot-name (%slot-definition-name slot))) + (multiple-value-bind (init-key init-value foundp) + (get-properties all-keys (%slot-definition-initargs slot)) + (if foundp + (setf (std-slot-value instance slot-name) init-value) + (unless (std-slot-boundp instance slot-name) + (let ((initfunction (%slot-definition-initfunction slot))) + (when (and initfunction (or (eq slot-names t) + (memq slot-name slot-names))) + (setf (std-slot-value instance slot-name) + (funcall initfunction))))))))) + instance) + +(defgeneric shared-initialize (instance slot-names &key)) + +(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) + (std-shared-initialize instance slot-names initargs)) + +;;; change-class + +(defgeneric change-class (instance new-class &key)) + +(defmethod change-class ((old-instance standard-object) (new-class standard-class) + &rest initargs) + (let ((old-slots (%class-slots (class-of old-instance))) + (new-slots (%class-slots new-class)) + (new-instance (allocate-instance new-class))) + ;; "The values of local slots specified by both the class CTO and the class + ;; CFROM are retained. If such a local slot was unbound, it remains + ;; unbound." + (dolist (new-slot new-slots) + (when (instance-slot-p new-slot) + (let* ((slot-name (%slot-definition-name new-slot)) + (old-slot (find slot-name old-slots :key #'%slot-definition-name))) + ;; "The values of slots specified as shared in the class CFROM and as + ;; local in the class CTO are retained." + (when (and old-slot (slot-boundp old-instance slot-name)) + (setf (slot-value new-instance slot-name) + (slot-value old-instance slot-name)))))) + (swap-slots old-instance new-instance) + (rotatef (std-instance-layout new-instance) + (std-instance-layout old-instance)) + (apply #'update-instance-for-different-class + new-instance old-instance initargs) + old-instance)) + +(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs) + (apply #'change-class instance (find-class new-class) initargs)) + +(defgeneric update-instance-for-different-class (old new &key)) + +(defmethod update-instance-for-different-class + ((old standard-object) (new standard-object) &rest initargs) + (let ((added-slots + (remove-if #'(lambda (slot-name) + (slot-exists-p old slot-name)) + (mapcar #'%slot-definition-name + (%class-slots (class-of new)))))) + (check-initargs (class-of new) initargs) + (apply #'shared-initialize new added-slots initargs))) + +;;; make-instances-obsolete + +(defgeneric make-instances-obsolete (class)) + +(defmethod make-instances-obsolete ((class standard-class)) + (%make-instances-obsolete class)) + +(defmethod make-instances-obsolete ((class symbol)) + (make-instances-obsolete (find-class class)) + class) + +;;; update-instance-for-redefined-class + +(defgeneric update-instance-for-redefined-class (instance + added-slots + discarded-slots + property-list + &rest initargs + &key + &allow-other-keys)) + +(defmethod update-instance-for-redefined-class ((instance standard-object) + added-slots + discarded-slots + property-list + &rest initargs) + (check-initargs (class-of instance) initargs) + (apply #'shared-initialize instance added-slots initargs)) + +;;; Methods having to do with class metaobjects. + +(defmethod initialize-instance :after ((class standard-class) &rest args) + (apply #'std-after-initialization-for-classes class args)) + +;;; Finalize inheritance + +(defgeneric finalize-inheritance (class)) + +(defmethod finalize-inheritance ((class standard-class)) + (std-finalize-inheritance class)) + +;;; Class precedence lists + +(defgeneric compute-class-precedence-list (class)) +(defmethod compute-class-precedence-list ((class standard-class)) + (std-compute-class-precedence-list class)) + +;;; Slot inheritance + +(defgeneric compute-slots (class)) +(defmethod compute-slots ((class standard-class)) + (std-compute-slots class)) + +(defgeneric compute-effective-slot-definition (class direct-slots)) +(defmethod compute-effective-slot-definition + ((class standard-class) direct-slots) + (std-compute-effective-slot-definition class direct-slots)) + +;;; Methods having to do with generic function metaobjects. + +(defmethod initialize-instance :after ((gf standard-generic-function) &key) + (finalize-generic-function gf)) + +;;; Methods having to do with generic function invocation. + +(defgeneric compute-discriminating-function (gf)) +(defmethod compute-discriminating-function ((gf standard-generic-function)) + (std-compute-discriminating-function gf)) + +(defgeneric method-more-specific-p (gf method1 method2 required-classes)) + +(defmethod method-more-specific-p ((gf standard-generic-function) + method1 method2 required-classes) + (std-method-more-specific-p method1 method2 required-classes + (generic-function-argument-precedence-order gf))) + +(defgeneric compute-effective-method-function (gf methods)) +(defmethod compute-effective-method-function ((gf standard-generic-function) methods) + (std-compute-effective-method-function gf methods)) + +(defgeneric compute-applicable-methods (gf args)) +(defmethod compute-applicable-methods ((gf standard-generic-function) args) + (%compute-applicable-methods gf args)) + +;;; Conditions. + +(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) + (let ((parent-types (or parent-types '(condition))) + (report nil)) + (dolist (option options) + (when (eq (car option) :report) + (setf report (cadr option)) + (return))) + (typecase report + (null + `(progn + (defclass ,name ,parent-types ,slot-specs , at options) + ',name)) + (string + `(progn + (defclass ,name ,parent-types ,slot-specs , at options) + (defmethod print-object ((condition ,name) stream) + (if *print-escape* + (call-next-method) + (progn (write-string ,report stream) condition))) + ',name)) + (t + `(progn + (defclass ,name ,parent-types ,slot-specs , at options) + (defmethod print-object ((condition ,name) stream) + (if *print-escape* + (call-next-method) + (funcall #',report condition stream))) + ',name))))) + +(defun make-condition (type &rest initargs) + (or (%make-condition type initargs) + (let ((class (if (symbolp type) (find-class type) type))) + (apply #'make-instance class initargs)))) + +;; Adapted from SBCL. +;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION. +(defun coerce-to-condition (datum arguments default-type fun-name) + (cond ((typep datum 'condition) + (when arguments + (error 'simple-type-error + :datum arguments + :expected-type 'null + :format-control "You may not supply additional arguments when giving ~S to ~S." + :format-arguments (list datum fun-name))) + datum) + ((symbolp datum) + (apply #'make-condition datum arguments)) + ((or (stringp datum) (functionp datum)) + (make-condition default-type + :format-control datum + :format-arguments arguments)) + (t + (error 'simple-type-error + :datum datum + :expected-type '(or symbol string) + :format-control "Bad argument to ~S: ~S." + :format-arguments (list fun-name datum))))) + +(defgeneric make-load-form (object &optional environment)) + +(defmethod make-load-form ((object t) &optional environment) + (declare (ignore environment)) + (apply #'no-applicable-method #'make-load-form (list object))) + +(defmethod make-load-form ((class class) &optional environment) + (declare (ignore environment)) + (let ((name (%class-name class))) + (unless (and name (eq (find-class name nil) class)) + (error 'simple-type-error + :format-control "Can't use anonymous or undefined class as a constant: ~S." + :format-arguments (list class))) + `(find-class ',name))) + +(defun invalid-method-error (method format-control &rest args) + (let ((message (apply #'format nil format-control args))) + (error "Invalid method error for ~S:~% ~A" method message))) + +(defun method-combination-error (format-control &rest args) + (let ((message (apply #'format nil format-control args))) + (error "Method combination error in CLOS dispatch:~% ~A" message))) + +(defgeneric no-applicable-method (generic-function &rest args)) + +(defmethod no-applicable-method (generic-function &rest args) + (error "There is no applicable method for the generic function ~S when called with arguments ~S." + generic-function + args)) + +(defgeneric find-method (generic-function + qualifiers + specializers + &optional errorp)) + +(defmethod find-method ((generic-function standard-generic-function) + qualifiers specializers &optional (errorp t)) + (%find-method generic-function qualifiers specializers errorp)) + +(defgeneric add-method (generic-function method)) + +(defmethod add-method ((generic-function standard-generic-function) (method method)) + (let ((method-lambda-list (method-lambda-list method)) + (gf-lambda-list (generic-function-lambda-list generic-function))) + (check-method-lambda-list method-lambda-list gf-lambda-list)) + (%add-method generic-function method)) + +(defgeneric remove-method (generic-function method)) + +(defmethod remove-method ((generic-function standard-generic-function) method) + (%remove-method generic-function method)) + +;; See describe.lisp. +(defgeneric describe-object (object stream)) + +;; FIXME +(defgeneric no-next-method (generic-function method &rest args)) + +;; FIXME +(defgeneric function-keywords (method)) + +(provide 'clos) Added: branches/save-image/src/org/armedbear/lisp/coerce.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/coerce.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,122 @@ +;;; coerce.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: coerce.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(declaim (ftype (function (t) t) coerce-list-to-vector)) +(defun coerce-list-to-vector (list) + (let* ((length (length list)) + (result (make-array length))) + (dotimes (i length) + (declare (type index i)) + (setf (aref result i) (pop list))) + result)) + +(declaim (ftype (function (string) simple-string) copy-string)) +(defun copy-string (string) + (declare (optimize speed (safety 0))) + (declare (type string string)) + (let* ((length (length string)) + (copy (make-string length))) + (dotimes (i length copy) + (declare (type fixnum i)) + (setf (schar copy i) (char string i))))) + +(defun coerce-error (object result-type) + (error 'simple-type-error + :datum object + :format-control "~S cannot be converted to type ~S." + :format-arguments (list object result-type))) + +;; FIXME This is a special case for LOOP code, which does things like +;; (AND SINGLE-FLOAT REAL) and (AND SINGLE-FLOAT (REAL (0))). +(declaim (ftype (function (t t) t) coerce-object-to-and-type)) +(defun coerce-object-to-and-type (object result-type) + (when (and (consp result-type) + (eq (%car result-type) 'AND) + (= (length result-type) 3)) + (let* ((type1 (%cadr result-type)) + (type2 (%caddr result-type)) + (result (coerce object type1))) + (when (typep object type2) + (return-from coerce-object-to-and-type result)))) + (coerce-error object result-type)) + +(defun coerce (object result-type) + (cond ((eq result-type t) + object) + ((typep object result-type) + object) + ((and (listp object) + (eq result-type 'vector)) + (coerce-list-to-vector object)) + ((and (stringp object) ; a string, but not a simple-string + (eq result-type 'simple-string)) + (copy-string object)) + ((eq result-type 'character) + (cond ((and (stringp object) + (= (length object) 1)) + (char object 0)) + ((and (symbolp object) + (= (length (symbol-name object)) 1)) + (char (symbol-name object) 0)) + (t + (coerce-error object result-type)))) + ((memq result-type '(float single-float short-float)) + (coerce-to-single-float object)) + ((memq result-type '(double-float long-float)) + (coerce-to-double-float object)) + ((eq result-type 'complex) + (cond ((floatp object) + (complex object 0.0)) + ((numberp object) + object) + (t + (coerce-error object result-type)))) + ((eq result-type 'function) + (coerce-to-function object)) + ((and (consp result-type) + (eq (%car result-type) 'complex)) + (if (memq (%cadr result-type) + '(float single-float double-float short-float long-float)) + (complex object 0.0) + object)) + ((and (consp result-type) + (eq (%car result-type) 'AND)) + (coerce-object-to-and-type object result-type)) + ((and (simple-typep object 'sequence) + (%subtypep result-type 'sequence)) + (concatenate result-type object)) + (t + (let ((expanded-type (expand-deftype result-type))) + (unless (eq expanded-type result-type) + (return-from coerce (coerce object expanded-type)))) + (coerce-error object result-type)))) Added: branches/save-image/src/org/armedbear/lisp/collect.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/collect.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,118 @@ +;;; collect.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: collect.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "EXT") + +(export '(collect)) + +;;; From CMUCL. + +;;;; The Collect macro: + +;;; Collect-Normal-Expander -- Internal +;;; +;;; This function does the real work of macroexpansion for normal collection +;;; macros. N-Value is the name of the variable which holds the current +;;; value. Fun is the function which does collection. Forms is the list of +;;; forms whose values we are supposed to collect. +;;; +(defun collect-normal-expander (n-value fun forms) + `(progn + ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) + ,n-value)) + +;;; Collect-List-Expander -- Internal +;;; +;;; This function deals with the list collection case. N-Tail is the pointer +;;; to the current tail of the list, which is NIL if the list is empty. +;;; +(defun collect-list-expander (n-value n-tail forms) + (let ((n-res (gensym))) + `(progn + ,@(mapcar #'(lambda (form) + `(let ((,n-res (cons ,form nil))) + (cond (,n-tail + (setf (cdr ,n-tail) ,n-res) + (setq ,n-tail ,n-res)) + (t + (setq ,n-tail ,n-res ,n-value ,n-res))))) + forms) + ,n-value))) + + +;;; Collect -- Public +;;; +;;; The ultimate collection macro... +;;; +(defmacro collect (collections &body body) + "Collect ({(Name [Initial-Value] [Function])}*) {Form}* + Collect some values somehow. Each of the collections specifies a bunch of + things which collected during the evaluation of the body of the form. The + name of the collection is used to define a local macro, a la MACROLET. + Within the body, this macro will evaluate each of its arguments and collect + the result, returning the current value after the collection is done. The + body is evaluated as a PROGN; to get the final values when you are done, just + call the collection macro with no arguments. + + Initial-Value is the value that the collection starts out with, which + defaults to NIL. Function is the function which does the collection. It is + a function which will accept two arguments: the value to be collected and the + current collection. The result of the function is made the new value for the + collection. As a totally magical special-case, the Function may be Collect, + which tells us to build a list in forward order; this is the default. If an + Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the + end. Note that Function may be anything that can appear in the functional + position, including macros and lambdas." + + (let ((macros ()) + (binds ())) + (dolist (spec collections) + (unless (<= 1 (length spec) 3) + (error "Malformed collection specifier: ~S." spec)) + (let ((n-value (gensym)) + (name (first spec)) + (default (second spec)) + (kind (or (third spec) 'collect))) + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym))) + (if default + (push `(,n-tail (last ,n-value)) binds) + (push n-tail binds)) + (push `(,name (&rest args) + (collect-list-expander ',n-value ',n-tail args)) + macros)) + (push `(,name (&rest args) + (collect-normal-expander ',n-value ',kind args)) + macros)))) + `(macrolet ,macros (let* ,(nreverse binds) , at body)))) + +(provide 'collect) Added: branches/save-image/src/org/armedbear/lisp/compile-file-pathname.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compile-file-pathname.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,45 @@ +;;; compile-file-pathname.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: compile-file-pathname.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;; Adapted from SBCL. +(defun cfp-output-file-default (input-file) + (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*)) + (retyped (make-pathname :type *compile-file-type* :defaults defaults))) + retyped)) + +(defun compile-file-pathname (input-file + &key + (output-file (cfp-output-file-default + input-file)) + &allow-other-keys) + (merge-pathnames output-file (merge-pathnames input-file) nil)) Added: branches/save-image/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compile-file.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,498 @@ +;;; compile-file.lisp +;;; +;;; Copyright (C) 2004-2006 Peter Graves +;;; $Id: compile-file.lisp 11675 2009-02-21 09:33:53Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(require '#:jvm) + +(defvar *fbound-names*) + +(defvar *class-number*) + +(defvar *output-file-pathname*) + +(declaim (ftype (function () t) next-classfile-name)) +(defun next-classfile-name () + (let ((name (%format nil "~A-~D" + (substitute #\_ #\. (pathname-name *output-file-pathname*)) + (incf *class-number*)))) + (namestring (merge-pathnames (make-pathname :name name :type "cls") + *output-file-pathname*)))) + +(defmacro report-error (&rest forms) + `(handler-case (progn , at forms) + (compiler-unsupported-feature-error (condition) + (fresh-line) + (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition) + (values nil condition)))) + +;; Dummy function. Should never be called. +(defun dummy (&rest ignored) + (declare (ignore ignored)) + (assert nil)) + +(declaim (ftype (function (t) t) verify-load)) +(defun verify-load (classfile) + (and classfile + (let ((*load-truename* *output-file-pathname*)) + (report-error + (load-compiled-function classfile))))) + +(declaim (ftype (function (t stream) t) process-defconstant)) +(defun process-defconstant (form stream) + ;; "If a DEFCONSTANT form appears as a top level form, the compiler + ;; must recognize that [the] name names a constant variable. An + ;; implementation may choose to evaluate the value-form at compile + ;; time, load time, or both. Therefore, users must ensure that the + ;; initial-value can be evaluated at compile time (regardless of + ;; whether or not references to name appear in the file) and that + ;; it always evaluates to the same value." + (eval form) + (cond ((structure-object-p (third form)) + (multiple-value-bind (creation-form initialization-form) + (make-load-form (third form)) + (dump-form (list 'DEFCONSTANT (second form) creation-form) stream))) + (t + (dump-form form stream))) + (%stream-terpri stream)) + +(declaim (ftype (function (t) t) note-toplevel-form)) +(defun note-toplevel-form (form) + (when *compile-print* + (fresh-line) + (princ "; ") + (let ((*print-length* 2) + (*print-level* 2) + (*print-pretty* nil)) + (prin1 form)) + (terpri))) + +(declaim (ftype (function (t stream t) t) process-toplevel-form)) +(defun process-toplevel-form (form stream compile-time-too) + (cond ((atom form) + (when compile-time-too + (eval form))) + (t + (let ((operator (%car form))) + (case operator + (MACROLET + (process-toplevel-macrolet form stream compile-time-too) + (return-from process-toplevel-form)) + ((IN-PACKAGE DEFPACKAGE) + (note-toplevel-form form) + (setf form (precompile-form form nil)) + (eval form) + ;; Force package prefix to be used when dumping form. + (let ((*package* +keyword-package+)) + (dump-form form stream)) + (%stream-terpri stream) + (return-from process-toplevel-form)) + ((DEFVAR DEFPARAMETER) + (note-toplevel-form form) + (if compile-time-too + (eval form) + ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, + ;; the compiler must recognize that the name has been proclaimed + ;; special. However, it must neither evaluate the initial-value + ;; form nor assign the dynamic variable named NAME at compile + ;; time." + (let ((name (second form))) + (%defvar name)))) + (DEFCONSTANT + (note-toplevel-form form) + (process-defconstant form stream) + (return-from process-toplevel-form)) + (DEFUN + (note-toplevel-form form) + (let* ((name (second form)) + (block-name (fdefinition-block-name name)) + (lambda-list (third form)) + (body (nthcdr 3 form)) + (*speed* *speed*) + (*space* *space*) + (*safety* *safety*) + (*debug* *debug*)) + (multiple-value-bind (body decls doc) + (parse-body body) + (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) + (classfile-name (next-classfile-name)) + (classfile (report-error + (jvm:compile-defun name expr nil classfile-name))) + (compiled-function (verify-load classfile))) + (cond (compiled-function + (setf form + `(fset ',name + (load-compiled-function ,(file-namestring classfile)) + ,*source-position* + ',lambda-list + ,doc)) + (when compile-time-too + (fset name compiled-function))) + (t + ;; FIXME This should be a warning or error of some sort... + (format *error-output* "; Unable to compile function ~A~%" name) + (let ((precompiled-function (precompile-form expr nil))) + (setf form + `(fset ',name + ,precompiled-function + ,*source-position* + ',lambda-list + ,doc))) + (when compile-time-too + (eval form))))) + (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) + ;; FIXME Need to support SETF functions too! + (setf (inline-expansion name) + (jvm::generate-inline-expansion block-name lambda-list body)) + (dump-form `(setf (inline-expansion ',name) ',(inline-expansion name)) + stream) + (%stream-terpri stream))) + (push name jvm::*functions-defined-in-current-file*) + (note-name-defined name) + ;; If NAME is not fbound, provide a dummy definition so that + ;; getSymbolFunctionOrDie() will succeed when we try to verify that + ;; functions defined later in the same file can be loaded correctly. + (unless (fboundp name) + (setf (fdefinition name) #'dummy) + (push name *fbound-names*)))) + ((DEFGENERIC DEFMETHOD) + (note-toplevel-form form) + (note-name-defined (second form)) + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + (return-from process-toplevel-form)) + (DEFMACRO + (note-toplevel-form form) + (let ((name (second form))) + (eval form) + (let* ((expr (function-lambda-expression (macro-function name))) + (classfile-name (next-classfile-name)) + (classfile + (ignore-errors + (jvm:compile-defun nil expr nil classfile-name)))) + (if (verify-load classfile) + (progn + (setf form + (if (special-operator-p name) + `(put ',name 'macroexpand-macro + (make-macro ',name + (load-compiled-function + ,(file-namestring classfile)))) + `(fset ',name + (make-macro ',name + (load-compiled-function + ,(file-namestring classfile))) + ,*source-position* + ',(third form))))) + ;; FIXME error or warning + (format *error-output* "; Unable to compile macro ~A~%" name))))) + (DEFTYPE + (note-toplevel-form form) + (eval form)) + (EVAL-WHEN + (multiple-value-bind (ct lt e) + (parse-eval-when-situations (cadr form)) + (let ((new-compile-time-too (or ct + (and compile-time-too e))) + (body (cddr form))) + (cond (lt + (process-toplevel-progn body stream new-compile-time-too)) + (new-compile-time-too + (eval `(progn , at body))))) + (return-from process-toplevel-form))) + (LOCALLY + ;; FIXME Need to handle special declarations too! + (let ((*speed* *speed*) + (*safety* *safety*) + (*debug* *debug*) + (*space* *space*) + (*inline-declarations* *inline-declarations*)) + (multiple-value-bind (forms decls) + (parse-body (cdr form) nil) + (process-optimization-declarations decls) + (process-toplevel-progn forms stream compile-time-too) + (return-from process-toplevel-form)))) + (PROGN + (process-toplevel-progn (cdr form) stream compile-time-too) + (return-from process-toplevel-form)) + (DECLARE + (compiler-style-warn "Misplaced declaration: ~S" form)) + (t + (when (and (symbolp operator) + (macro-function operator *compile-file-environment*)) + (note-toplevel-form form) + ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in + ;; case the form being expanded expands into something that needs + ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). + (let ((*compile-print* nil)) + (process-toplevel-form (macroexpand-1 form *compile-file-environment*) + stream compile-time-too)) + (return-from process-toplevel-form)) + + (when compile-time-too + (eval form)) + + (cond ((eq operator 'QUOTE) +;; (setf form (precompile-form form nil)) + (return-from process-toplevel-form) + ) + ((eq operator 'PUT) + (setf form (precompile-form form nil))) + ((eq operator 'COMPILER-DEFSTRUCT) + (setf form (precompile-form form nil))) + ((eq operator 'PROCLAIM) + (setf form (precompile-form form nil))) + ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) + (or (keywordp (second form)) + (and (listp (second form)) + (eq (first (second form)) 'QUOTE)))) + (setf form (precompile-form form nil))) + ((eq operator 'IMPORT) + (setf form (precompile-form form nil)) + ;; Make sure package prefix is printed when symbols are imported. + (let ((*package* +keyword-package+)) + (dump-form form stream)) + (%stream-terpri stream) + (return-from process-toplevel-form)) + ((and (eq operator '%SET-FDEFINITION) + (eq (car (second form)) 'QUOTE) + (consp (third form)) + (eq (%car (third form)) 'FUNCTION) + (symbolp (cadr (third form)))) + (setf form (precompile-form form nil))) +;; ((memq operator '(LET LET*)) +;; (let ((body (cddr form))) +;; (if (dolist (subform body nil) +;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) +;; (return t))) +;; (setf form (convert-toplevel-form form)) +;; (setf form (precompile-form form nil))))) + ((eq operator 'mop::ensure-method) + (setf form (convert-ensure-method form))) + ((and (symbolp operator) + (not (special-operator-p operator)) + (null (cdr form))) + (setf form (precompile-form form nil))) + (t +;; (setf form (precompile-form form nil)) + (note-toplevel-form form) + (setf form (convert-toplevel-form form)) + ))))))) + (when (consp form) + (dump-form form stream) + (%stream-terpri stream))) + +(declaim (ftype (function (t) t) convert-ensure-method)) +(defun convert-ensure-method (form) + (c-e-m-1 form :function) + (c-e-m-1 form :fast-function) + (precompile-form form nil)) + +(declaim (ftype (function (t t) t) c-e-m-1)) +(defun c-e-m-1 (form key) + (let* ((tail (cddr form)) + (function-form (getf tail key))) + (when (and function-form (consp function-form) + (eq (%car function-form) 'FUNCTION)) + (let ((lambda-expression (cadr function-form))) + (let* ((*speed* *speed*) + (*space* *space*) + (*safety* *safety*) + (*debug* *debug*)) + (let* ((classfile-name (next-classfile-name)) + (classfile (report-error + (jvm:compile-defun nil lambda-expression nil classfile-name))) + (compiled-function (verify-load classfile))) + (cond (compiled-function + (setf (getf tail key) + `(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~%"))))))))) + +(declaim (ftype (function (t) t) convert-toplevel-form)) +(defun convert-toplevel-form (form) + (let* ((expr `(lambda () ,form)) + (classfile-name (next-classfile-name)) + (classfile (report-error (jvm:compile-defun nil expr nil classfile-name))) + (compiled-function (verify-load classfile))) + (setf form + (if compiled-function + `(funcall (load-compiled-function ,(file-namestring classfile))) + (precompile-form form nil))))) + + +(defun process-toplevel-macrolet (form stream compile-time-too) + (let ((*compile-file-environment* (make-environment *compile-file-environment*))) + (dolist (definition (cadr form)) + (environment-add-macro-definition *compile-file-environment* + (car definition) + (make-macro (car definition) + (make-expander-for-macrolet definition)))) + (dolist (body-form (cddr form)) + (process-toplevel-form body-form stream compile-time-too)))) + +(declaim (ftype (function (t stream t) t) process-toplevel-progn)) +(defun process-toplevel-progn (forms stream compile-time-too) + (dolist (form forms) + (process-toplevel-form form stream compile-time-too))) + +;;; Adapted from SBCL. +;;; Parse an EVAL-WHEN situations list, returning three flags, +;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating +;;; the types of situations present in the list. +(defun parse-eval-when-situations (situations) + (when (or (not (listp situations)) + (set-difference situations + '(:compile-toplevel + compile + :load-toplevel + load + :execute + eval))) + (error "Bad EVAL-WHEN situation list: ~S." situations)) + (values (intersection '(:compile-toplevel compile) situations) + (intersection '(:load-toplevel load) situations) + (intersection '(:execute eval) situations))) + +(defun compile-file (input-file + &key + output-file + ((:verbose *compile-verbose*) *compile-verbose*) + ((:print *compile-print*) *compile-print*) + external-format) + (declare (ignore external-format)) ; FIXME + (unless (or (and (probe-file input-file) (not (file-directory-p input-file))) + (pathname-type input-file)) + (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file))) + (when (probe-file pathname) + (setf input-file pathname)))) + (setf output-file (if output-file + (merge-pathnames output-file *default-pathname-defaults*) + (compile-file-pathname input-file))) + (let* ((*output-file-pathname* output-file) + (type (pathname-type output-file)) + (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp")) + output-file)) + (warnings-p t) + (failure-p t)) + (with-open-file (in input-file :direction :input) + (let* ((*compile-file-pathname* (pathname in)) + (*compile-file-truename* (truename in)) + (*source* *compile-file-truename*) + (*class-number* 0) + (namestring (namestring *compile-file-truename*)) + (start (get-internal-real-time)) + elapsed) + (when *compile-verbose* + (format t "; Compiling ~A ...~%" namestring)) + (with-compilation-unit () + (with-open-file (out temp-file :direction :output :if-exists :supersede) + (let ((*readtable* *readtable*) + (*read-default-float-format* *read-default-float-format*) + (*read-base* *read-base*) + (*package* *package*) + (*speed* *speed*) + (*space* *space*) + (*safety* *safety*) + (*debug* *debug*) + (*explain* *explain*) + (jvm::*functions-defined-in-current-file* '()) + (*fbound-names* '())) + (write "; -*- Mode: Lisp -*-" :escape nil :stream out) + (%stream-terpri out) + (let ((*package* (find-package '#:cl))) + (write (list 'init-fasl :version *fasl-version*) :stream out) + (%stream-terpri out) + (write (list 'setq '*source* *compile-file-truename*) :stream out) + (%stream-terpri out)) + (loop + (let* ((*source-position* (file-position in)) + (jvm::*source-line-number* (stream-line-number in)) + (form (read in nil in)) + (*compiler-error-context* form)) + (when (eq form in) + (return)) + (process-toplevel-form form out nil))) + (dolist (name *fbound-names*) + (fmakunbound name)))) + (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*)) + (setf warnings-p nil failure-p nil)) + ((zerop (+ jvm::*errors* jvm::*warnings*)) + (setf failure-p nil)))) + (rename-file temp-file output-file) + + (when *compile-file-zip* + (let ((zipfile (concatenate 'string (namestring output-file) ".zip")) + (pathnames ())) + (dotimes (i *class-number*) + (let* ((file-namestring (%format nil "~A-~D.cls" + (substitute #\_ #\. (pathname-name output-file)) + (1+ i))) + (pathname (merge-pathnames file-namestring output-file))) + (when (probe-file pathname) + (push pathname pathnames)))) + (setf pathnames (nreverse pathnames)) + (let ((load-file (merge-pathnames (make-pathname :type "_") + output-file))) + (rename-file output-file load-file) + (push load-file pathnames)) + (zip zipfile pathnames) + (dolist (pathname pathnames) + (let ((truename (probe-file pathname))) + (when truename + (delete-file truename)))) + (rename-file zipfile output-file))) + + (setf elapsed (/ (- (get-internal-real-time) start) 1000.0)) + (when *compile-verbose* + (format t "~&; Wrote ~A (~A seconds)~%" (namestring output-file) elapsed)))) + (values (truename output-file) warnings-p failure-p))) + +(defun compile-file-if-needed (input-file &rest allargs &key force-compile + &allow-other-keys) + (setf input-file (truename input-file)) + (cond (force-compile + (remf allargs :force-compile) + (apply 'compile-file input-file allargs)) + (t + (let* ((source-write-time (file-write-date input-file)) + (output-file (or (getf allargs :output-file) + (compile-file-pathname input-file))) + (target-write-time (and (probe-file output-file) + (file-write-date output-file)))) + (if (or (null target-write-time) + (<= target-write-time source-write-time)) + (apply 'compile-file input-file allargs) + output-file))))) + +(provide 'compile-file) Added: branches/save-image/src/org/armedbear/lisp/compile-system.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compile-system.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,278 @@ +;;; compile-system.lisp +;;; +;;; Copyright (C) 2004-2008 Peter Graves +;;; $Id: compile-system.lisp 11677 2009-02-21 21:53:38Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(require "LOOP") +(require "COLLECT") +(require "COMPILE-FILE") + +(defun check-lisp-home () + (loop + (cond ((and *lisp-home* + (probe-directory (pathname *lisp-home*))) + (return)) + (t + (cerror "Continue" + "*LISP-HOME* is NIL or invalid.~% Please set *LISP-HOME* to the full pathname of the directory containing the Lisp system files."))))) + +(defun grovel-java-definitions-in-file (file out) + (with-open-file (in file) + (declare (type stream in)) + (let ((system-package (find-package "SYSTEM")) + (line-number 1)) + (loop + (let ((text (read-line in nil))) + (when (null text) + (return)) + (let ((position (search "###" text))) + (when position + (let* ((name (string (read-from-string (subseq text (+ position 3))))) + (symbol (or (find-symbol name system-package) ; uses CL and EXT + (find-symbol name (find-package "MOP")) + (find-symbol name (find-package "JAVA"))))) + (when symbol + ;; Force the symbol's package prefix to be written out + ;; with "::" instead of ":" so there won't be a reader + ;; error if a symbol that's external now is no longer + ;; external when we read the tags file. + (%format out "~A::~A ~S ~S~%" + (package-name (symbol-package symbol)) + name + file line-number))))) + (incf line-number)))))) + +(defun grovel-java-definitions () + (check-lisp-home) + (time + (let ((files (directory (merge-pathnames "*.java" *lisp-home*)))) + (with-open-file (stream (merge-pathnames "tags" *lisp-home*) + :direction :output :if-exists :supersede) + (dolist (file files) + (grovel-java-definitions-in-file file stream)))))) + +(defun %compile-system (&key output-path) + (let ((*default-pathname-defaults* (pathname *lisp-home*)) + (*warn-on-redefinition* nil)) + (unless output-path + (setf output-path *default-pathname-defaults*)) + (flet ((do-compile (file) + (let ((out (make-pathname :type "abcl" + :defaults (merge-pathnames + file output-path)))) + (compile-file-if-needed file :output-file out)))) + (load (do-compile "coerce.lisp")) + (load (do-compile "open.lisp")) + (load (do-compile "dump-form.lisp")) + (load (do-compile "compiler-types.lisp")) + (load (do-compile "compile-file.lisp")) + (load (do-compile "precompiler.lisp")) + (load (do-compile "compiler-pass1.lisp")) + (load (do-compile "compiler-pass2.lisp")) + (load (do-compile "jvm.lisp")) + (load (do-compile "source-transform.lisp")) + (load (do-compile "compiler-macro.lisp")) + (load (do-compile "opcodes.lisp")) + (load (do-compile "setf.lisp")) + (load (do-compile "substitute.lisp")) + (load (do-compile "clos.lisp")) + ;; Order matters for these files. + (mapc #'do-compile '("collect.lisp" + "macros.lisp" + "loop.lisp")) + (load (do-compile "backquote.lisp")) + (load (do-compile "early-defuns.lisp")) + (load (do-compile "typep.lisp")) + (load (do-compile "subtypep.lisp")) + (load (do-compile "find.lisp")) + (load (do-compile "print.lisp")) + (load (do-compile "pprint-dispatch.lisp")) + (load (do-compile "pprint.lisp")) + (load (do-compile "format.lisp")) + (load (do-compile "delete.lisp")) + (load (do-compile "concatenate.lisp")) + (load (do-compile "ldb.lisp")) + (load (do-compile "destructuring-bind.lisp")) + ;; But not for these. + (mapc #'do-compile '("adjoin.lisp" + "and.lisp" + "apropos.lisp" + "arrays.lisp" + "asdf.lisp" + "assert.lisp" + "assoc.lisp" + "autoloads.lisp" + "aver.lisp" + "bit-array-ops.lisp" + "boole.lisp" + ;;"boot.lisp" + "butlast.lisp" + "byte-io.lisp" + "case.lisp" + "chars.lisp" + "check-type.lisp" + "compile-file-pathname.lisp" + "compile-system.lisp" + "compiler-error.lisp" + "cond.lisp" + "copy-seq.lisp" + "copy-symbol.lisp" + "count.lisp" + "debug.lisp" + "define-modify-macro.lisp" + "define-symbol-macro.lisp" + "defmacro.lisp" + "defpackage.lisp" + "defsetf.lisp" + "defstruct.lisp" + "deftype.lisp" + "delete-duplicates.lisp" + "deposit-field.lisp" + "describe.lisp" + "describe-compiler-policy.lisp" + "directory.lisp" + "disassemble.lisp" + "do-all-symbols.lisp" + "do-external-symbols.lisp" + "do-symbols.lisp" + "do.lisp" + "dolist.lisp" + "dotimes.lisp" + "dribble.lisp" + "dump-class.lisp" + "ed.lisp" + "enough-namestring.lisp" + "ensure-directories-exist.lisp" + "error.lisp" + "featurep.lisp" + "fdefinition.lisp" + "fill.lisp" + "find-all-symbols.lisp" + "gentemp.lisp" + "gray-streams.lisp" + "inline.lisp" + "inspect.lisp" + ;;"j.lisp" + "java.lisp" + "known-functions.lisp" + "known-symbols.lisp" + "late-setf.lisp" + "lcm.lisp" + "ldiff.lisp" + "list-length.lisp" + "list.lisp" + "load.lisp" + "make-hash-table.lisp" + "make-load-form-saving-slots.lisp" + "make-sequence.lisp" + "make-string-output-stream.lisp" + "make-string.lisp" + "map-into.lisp" + "map.lisp" + "map1.lisp" + "mask-field.lisp" + "member-if.lisp" + "mismatch.lisp" + "multiple-value-bind.lisp" + "multiple-value-list.lisp" + "multiple-value-setq.lisp" + "nsubstitute.lisp" + "nth-value.lisp" + "numbers.lisp" + "or.lisp" + "parse-integer.lisp" + "parse-lambda-list.lisp" + "pathnames.lisp" + "package.lisp" + "print-object.lisp" + "print-unreadable-object.lisp" + "proclaim.lisp" + "profiler.lisp" + "prog.lisp" + "psetf.lisp" + "query.lisp" + "read-conditional.lisp" + "read-from-string.lisp" + "read-sequence.lisp" + "reduce.lisp" + "remf.lisp" + "remove-duplicates.lisp" + "remove.lisp" + "replace.lisp" + "require.lisp" + "restart.lisp" + "revappend.lisp" + "rotatef.lisp" + "rt.lisp" + ;;"run-benchmarks.lisp" + "run-shell-command.lisp" + ;;"runtime-class.lisp" + "search.lisp" + "sequences.lisp" + "sets.lisp" + "shiftf.lisp" + "signal.lisp" + "socket.lisp" + "sort.lisp" + "step.lisp" + "strings.lisp" + "sublis.lisp" + "subst.lisp" + "tailp.lisp" + "time.lisp" + "top-level.lisp" + "trace.lisp" + "tree-equal.lisp" + "upgraded-complex-part-type.lisp" + "with-accessors.lisp" + "with-hash-table-iterator.lisp" + "with-input-from-string.lisp" + "with-mutex.lisp" + "with-open-file.lisp" + "with-output-to-string.lisp" + "with-package-iterator.lisp" + "with-slots.lisp" + "with-standard-io-syntax.lisp" + "with-thread-lock.lisp" + "write-sequence.lisp"))) + t)) + +(defun compile-system (&key quit (zip t) output-path) + (let ((status -1)) + (check-lisp-home) + (time + (with-compilation-unit () + (let ((*compile-file-zip* zip)) + (%compile-system :output-path output-path)) + (when (zerop (+ jvm::*errors* jvm::*warnings*)) + (setf status 0)))) + (when quit + (quit :status status)))) Added: branches/save-image/src/org/armedbear/lisp/compiler-error.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compiler-error.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +;;; compiler-error.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: compiler-error.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(export '(*compiler-error-context* + compiler-style-warn + compiler-warn + compiler-error + compiler-unsupported)) + +(defvar *compiler-error-context* nil) + +(defun compiler-style-warn (format-control &rest format-arguments) + (warn 'style-warning + :format-control format-control + :format-arguments format-arguments)) + +(defun compiler-warn (format-control &rest format-arguments) + (warn 'warning + :format-control format-control + :format-arguments format-arguments)) + +(defun compiler-error (format-control &rest format-arguments) + (error 'compiler-error + :format-control format-control + :format-arguments format-arguments)) + +(defun compiler-unsupported (format-control &rest format-arguments) + (error 'compiler-unsupported-feature-error + :format-control format-control + :format-arguments format-arguments)) Added: branches/save-image/src/org/armedbear/lisp/compiler-macro.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compiler-macro.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,80 @@ +;;; compiler-macro.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: compiler-macro.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export 'compiler-macroexpand) + +(defvar *compiler-macros* (make-hash-table :test #'equal)) + +(defun compiler-macro-function (name &optional environment) + (declare (ignore environment)) + (gethash1 name (the hash-table *compiler-macros*))) + +(defun (setf compiler-macro-function) (new-function name &optional environment) + (declare (ignore environment)) + (setf (gethash name (the hash-table *compiler-macros*)) new-function)) + +(defmacro define-compiler-macro (name lambda-list &rest body) + (let* ((form (gensym)) + (env (gensym))) + (multiple-value-bind (body decls) + (parse-defmacro lambda-list form body name 'defmacro :environment env) + (let ((expander `(lambda (,form ,env) + (declare (ignorable ,env)) + (block ,(fdefinition-block-name name) ,body)))) + `(progn + (setf (compiler-macro-function ',name) (function ,expander)) + ',name))))) + +;;; Adapted from OpenMCL. +(defun compiler-macroexpand-1 (form &optional env) + (let ((expander nil) + (new-form nil)) + (if (and (consp form) + (symbolp (%car form)) + (setq expander (compiler-macro-function (%car form) env))) + (values (setq new-form (funcall expander form env)) + (neq new-form form)) + (values form + nil)))) + +(defun compiler-macroexpand (form &optional env) + (let ((expanded-p nil)) + (loop + (multiple-value-bind (expansion exp-p) + (compiler-macroexpand-1 form env) + (if exp-p + (setf form expansion + expanded-p t) + (return)))) + (values form expanded-p))) + Added: branches/save-image/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compiler-pass1.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,948 @@ +;;; compiler-pass1.lisp +;;; +;;; Copyright (C) 2003-2008 Peter Graves +;;; $Id: compiler-pass1.lisp 11645 2009-02-08 14:34:10Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "JVM") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "LOOP") + (require "FORMAT") + (require "CLOS") + (require "PRINT-OBJECT") + (require "COMPILER-TYPES") + (require "KNOWN-FUNCTIONS") + (require "KNOWN-SYMBOLS") + (require "DUMP-FORM") + (require "OPCODES") + (require "JAVA")) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun generate-inline-expansion (block-name lambda-list body) + (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) :test 'eq) + nil) + (t + (setf body (copy-tree body)) + (list 'LAMBDA lambda-list (precompile-form (list* 'BLOCK block-name body) t))))) + ) ; EVAL-WHEN + +;;; Pass 1. + + +;; Returns a list of declared free specials, if any are found. +(declaim (ftype (function (list list) list) process-declarations-for-vars)) +(defun process-declarations-for-vars (body variables) + (let ((free-specials '())) + (dolist (subform body) + (unless (and (consp subform) (eq (%car subform) 'DECLARE)) + (return)) + (let ((decls (%cdr subform))) + (dolist (decl decls) + (case (car decl) + ((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE) + ;; Nothing to do here. + ) + ((IGNORE IGNORABLE) + (process-ignore/ignorable (%car decl) (%cdr decl) variables)) + (SPECIAL + (dolist (name (%cdr decl)) + (let ((variable (find-variable name variables))) + (cond ((and variable + ;; see comment below (and DO-ALL-SYMBOLS.11) + (eq (variable-compiland variable) *current-compiland*)) + (setf (variable-special-p variable) t)) + (t + (dformat t "adding free special ~S~%" name) + (push (make-variable :name name :special-p t) free-specials)))))) + (TYPE + (dolist (name (cddr decl)) + (let ((variable (find-variable name variables))) + (when (and variable + ;; Don't apply a declaration in a local function to + ;; a variable defined in its parent. For an example, + ;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre. + ;; FIXME suboptimal, since we ignore the declaration + (eq (variable-compiland variable) *current-compiland*)) + (setf (variable-declared-type variable) + (make-compiler-type (cadr decl))))))) + (t + (dolist (name (cdr decl)) + (let ((variable (find-variable name variables))) + (when variable + (setf (variable-declared-type variable) + (make-compiler-type (%car decl))))))))))) + free-specials)) + +(defun check-name (name) + ;; FIXME Currently this error is signalled by the precompiler. + (unless (symbolp name) + (compiler-error "The variable ~S is not a symbol." name)) + (when (constantp name) + (compiler-error "The name of the variable ~S is already in use to name a constant." name)) + name) + +(declaim (ftype (function (t) t) p1-body)) +(defun p1-body (body) + (declare (optimize speed)) + (let ((tail body)) + (loop + (when (endp tail) + (return)) + (setf (car tail) (p1 (%car tail))) + (setf tail (%cdr tail)))) + body) + +(defknown p1-default (t) t) +(declaim (inline p1-default)) +(defun p1-default (form) + (setf (cdr form) (p1-body (cdr form))) + form) + +(defknown p1-if (t) t) +(defun p1-if (form) + (let ((test (cadr form))) + (cond ((unsafe-p test) + (cond ((and (consp test) + (memq (%car test) '(GO RETURN-FROM THROW))) + (p1 test)) + (t + (let* ((var (gensym)) + (new-form + `(let ((,var ,test)) + (if ,var ,(third form) ,(fourth form))))) + (p1 new-form))))) + (t + (p1-default form))))) + + +(defmacro p1-let/let*-vars + (varlist variables-var var body1 body2) + (let ((varspec (gensym)) + (initform (gensym)) + (name (gensym))) + `(let ((,variables-var ())) + (dolist (,varspec ,varlist) + (cond ((consp ,varspec) + ;; FIXME Currently this error is signalled by the precompiler. + (unless (= (length ,varspec) 2) + (compiler-error "The LET/LET* binding specification ~S is invalid." + ,varspec)) + (let* ((,name (%car ,varspec)) + (,initform (p1 (%cadr ,varspec))) + (,var (make-variable :name (check-name ,name) :initform ,initform))) + (push ,var ,variables-var) + , at body1)) + (t + (let ((,var (make-variable :name (check-name ,varspec)))) + (push ,var ,variables-var) + , at body1)))) + , at body2))) + +(defknown p1-let-vars (t) t) +(defun p1-let-vars (varlist) + (p1-let/let*-vars + varlist vars var + () + ((setf vars (nreverse vars)) + (dolist (variable vars) + (push variable *visible-variables*) + (push variable *all-variables*)) + vars))) + +(defknown p1-let*-vars (t) t) +(defun p1-let*-vars (varlist) + (p1-let/let*-vars + varlist vars var + ((push var *visible-variables*) + (push var *all-variables*)) + ((nreverse vars)))) + +(defun p1-let/let* (form) + (declare (type cons form)) + (let* ((*visible-variables* *visible-variables*) + (block (make-block-node '(LET))) + (*blocks* (cons block *blocks*)) + (op (%car form)) + (varlist (cadr form)) + (body (cddr form))) + (aver (or (eq op 'LET) (eq op 'LET*))) + (when (eq op 'LET) + ;; Convert to LET* if possible. + (if (null (cdr varlist)) + (setf op 'LET*) + (dolist (varspec varlist (setf op 'LET*)) + (or (atom varspec) + (constantp (cadr varspec)) + (eq (car varspec) (cadr varspec)) + (return))))) + (let ((vars (if (eq op 'LET) + (p1-let-vars varlist) + (p1-let*-vars varlist)))) + ;; Check for globally declared specials. + (dolist (variable vars) + (when (special-variable-p (variable-name variable)) + (setf (variable-special-p variable) t))) + ;; For processing declarations, we want to walk the variable list from + ;; last to first, since declarations apply to the last-defined variable + ;; with the specified name. + (setf (block-free-specials block) (process-declarations-for-vars body (reverse vars))) + (setf (block-vars block) vars) + ;; Make free specials visible. + (dolist (variable (block-free-specials block)) + (push variable *visible-variables*))) + (setf body (p1-body body)) + (setf (block-form block) (list* op varlist body)) + block)) + +(defun p1-locally (form) + (let ((*visible-variables* *visible-variables*) + (specials (process-special-declarations (cdr form)))) + (dolist (name specials) +;; (format t "p1-locally ~S is special~%" name) + (push (make-variable :name name :special-p t) *visible-variables*)) + (setf (cdr form) (p1-body (cdr form))) + form)) + +(defknown p1-m-v-b (t) t) +(defun p1-m-v-b (form) + (when (= (length (cadr form)) 1) + (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form)))) + (return-from p1-m-v-b (p1-let/let* new-form)))) + (let* ((*visible-variables* *visible-variables*) + (block (make-block-node '(MULTIPLE-VALUE-BIND))) + (*blocks* (cons block *blocks*)) + (varlist (cadr form)) + (values-form (caddr form)) + (body (cdddr form))) + ;; Process the values-form first. ("The scopes of the name binding and + ;; declarations do not include the values-form.") + (setf values-form (p1 values-form)) + (let ((vars ())) + (dolist (symbol varlist) + (let ((var (make-variable :name symbol))) + (push var vars) + (push var *visible-variables*) + (push var *all-variables*))) + ;; Check for globally declared specials. + (dolist (variable vars) + (when (special-variable-p (variable-name variable)) + (setf (variable-special-p variable) t))) + (setf (block-free-specials block) (process-declarations-for-vars body vars)) + (setf (block-vars block) (nreverse vars))) + (setf body (p1-body body)) + (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body)) + block)) + +(defun p1-block (form) + (let* ((block (make-block-node (cadr form))) + (*blocks* (cons block *blocks*))) + (setf (cddr form) (p1-body (cddr form))) + (setf (block-form block) form) + block)) + +(defun p1-catch (form) + (let* ((tag (p1 (cadr form))) + (body (cddr form)) + (result '())) + (dolist (subform body) + (let ((op (and (consp subform) (%car subform)))) + (push (p1 subform) result) + (when (memq op '(GO RETURN-FROM THROW)) + (return)))) + (setf result (nreverse result)) + (when (and (null (cdr result)) + (consp (car result)) + (eq (caar result) 'GO)) + (return-from p1-catch (car result))) + (push tag result) + (push 'CATCH result) + (let ((block (make-block-node '(CATCH)))) + (setf (block-form block) result) + block))) + +(defun p1-unwind-protect (form) + (if (= (length form) 2) + (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...) + (let* ((block (make-block-node '(UNWIND-PROTECT))) + (*blocks* (cons block *blocks*))) + (setf (block-form block) (p1-default form)) + block))) + +(defknown p1-return-from (t) t) +(defun p1-return-from (form) + (let* ((name (second form)) + (block (find-block name))) + (when (null block) + (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible." + name name)) + (dformat t "p1-return-from block = ~S~%" (block-name block)) + (setf (block-return-p block) t) + (cond ((eq (block-compiland block) *current-compiland*) + ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT + ;; which is inside the block we're returning from, we'll do a non- + ;; local return anyway so that UNWIND-PROTECT can catch it and run + ;; its cleanup forms. + (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*)) + (let ((protected + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block block) + (return nil)) + (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) + (return t))))) + (dformat t "p1-return-from protected = ~S~%" protected) + (when protected + (setf (block-non-local-return-p block) t)))) + (t + (setf (block-non-local-return-p block) t))) + (when (block-non-local-return-p block) + (dformat t "non-local return from block ~S~%" (block-name block)))) + (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form)))) + +(defun p1-tagbody (form) + (let* ((block (make-block-node '(TAGBODY))) + (*blocks* (cons block *blocks*)) + (*visible-tags* *visible-tags*) + (body (cdr form))) + ;; Make all the tags visible before processing the body forms. + (dolist (subform body) + (when (or (symbolp subform) (integerp subform)) + (let* ((tag (make-tag :name subform :label (gensym) :block block))) + (push tag *visible-tags*)))) + (let ((new-body '()) + (live t)) + (dolist (subform body) + (cond ((or (symbolp subform) (integerp subform)) + (push subform new-body) + (setf live t)) + ((not live) + ;; Nothing to do. + ) + (t + (when (and (consp subform) + (memq (%car subform) '(GO RETURN-FROM THROW))) + ;; Subsequent subforms are unreachable until we see another + ;; tag. + (setf live nil)) + (push (p1 subform) new-body)))) + (setf (block-form block) (list* 'TAGBODY (nreverse new-body)))) + block)) + +(defknown p1-go (t) t) +(defun p1-go (form) + (let* ((name (cadr form)) + (tag (find-tag name))) + (unless tag + (error "p1-go: tag not found: ~S" name)) + (let ((tag-block (tag-block tag))) + (cond ((eq (tag-compiland tag) *current-compiland*) + ;; Does the GO leave an enclosing UNWIND-PROTECT? + (let ((protected + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block tag-block) + (return nil)) + (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) + (return t))))) + (when protected + (setf (block-non-local-go-p tag-block) t)))) + (t + (setf (block-non-local-go-p tag-block) t))))) + form) + +(defun validate-name-and-lambda-list (name lambda-list context) + (unless (or (symbolp name) (setf-function-name-p name)) + (compiler-error "~S is not a valid function name." name)) + (when (or (memq '&optional lambda-list) + (memq '&key lambda-list)) + (let ((state nil)) + (dolist (arg lambda-list) + (cond ((memq arg lambda-list-keywords) + (setf state arg)) + ((memq state '(&optional &key)) + (when (and (consp arg) (not (constantp (second arg)))) + (compiler-unsupported + "~A: can't handle ~A argument with non-constant initform." + context + (if (eq state '&optional) "optional" "keyword"))))))))) + +(defmacro with-local-functions-for-flet/labels + (form local-functions-var lambda-name lambda-list-var name-var body-var body1 body2) + `(progn (incf (compiland-children *current-compiland*) (length (cadr ,form))) + (let ((*visible-variables* *visible-variables*) + (*local-functions* *local-functions*) + (*current-compiland* *current-compiland*) + (,local-functions-var '())) + (dolist (definition (cadr ,form)) + (let ((,name-var (car definition)) + (,lambda-list-var (cadr definition))) + (validate-name-and-lambda-list ,name-var ,lambda-list-var ,lambda-name) + + (let* ((,body-var (cddr definition)) + (compiland (make-compiland :name ,name-var + :parent *current-compiland*))) + , at body1))) + (setf ,local-functions-var (nreverse ,local-functions-var)) + ;; Make the local functions visible. + (dolist (local-function ,local-functions-var) + (push local-function *local-functions*) + (let ((variable (local-function-variable local-function))) + (when variable + (push variable *visible-variables*)))) + , at body2))) + +(defun p1-flet (form) + (with-local-functions-for-flet/labels + form local-functions 'FLET lambda-list name body + ((let ((local-function (make-local-function :name name + :compiland compiland))) + (multiple-value-bind (body decls) (parse-body body) + (let* ((block-name (fdefinition-block-name name)) + (lambda-expression + `(lambda ,lambda-list , at decls (block ,block-name , at body))) + (*visible-variables* *visible-variables*) + (*local-functions* *local-functions*) + (*current-compiland* compiland)) + (setf (compiland-lambda-expression compiland) lambda-expression) + (setf (local-function-inline-expansion local-function) + (generate-inline-expansion block-name lambda-list body)) + (p1-compiland compiland))) + (when *closure-variables* + (let ((variable (make-variable :name (gensym)))) + (setf (local-function-variable local-function) variable) + (push variable *all-variables*))) + (push local-function local-functions))) + ((with-saved-compiler-policy + (process-optimization-declarations (cddr form)) + (list* (car form) local-functions (p1-body (cddr form))))))) + + +(defun p1-labels (form) + (with-local-functions-for-flet/labels + form local-functions 'LABELS lambda-list name body + ((let* ((variable (make-variable :name (gensym))) + (local-function (make-local-function :name name + :compiland compiland + :variable variable))) + (multiple-value-bind (body decls) (parse-body body) + (setf (compiland-lambda-expression compiland) + `(lambda ,lambda-list , at decls (block ,name , at body)))) + (push variable *all-variables*) + (push local-function local-functions))) + ((dolist (local-function local-functions) + (let ((*visible-variables* *visible-variables*) + (*current-compiland* (local-function-compiland local-function))) + (p1-compiland (local-function-compiland local-function)))) + (list* (car form) local-functions (p1-body (cddr form)))))) + +(defknown p1-funcall (t) t) +(defun p1-funcall (form) + (unless (> (length form) 1) + (compiler-warn "Wrong number of arguments for ~A." (car form)) + (return-from p1-funcall form)) + (let ((function-form (%cadr form))) + (when (and (consp function-form) + (eq (%car function-form) 'FUNCTION)) + (let ((name (%cadr function-form))) +;; (format t "p1-funcall name = ~S~%" name) + (let ((source-transform (source-transform name))) + (when source-transform +;; (format t "found source transform for ~S~%" name) +;; (format t "old form = ~S~%" form) +;; (let ((new-form (expand-source-transform form))) +;; (when (neq new-form form) +;; (format t "new form = ~S~%" new-form) +;; (return-from p1-funcall (p1 new-form)))) + (let ((new-form (expand-source-transform (list* name (cddr form))))) +;; (format t "new form = ~S~%" new-form) + (return-from p1-funcall (p1 new-form))) + ))))) + ;; Otherwise... + (p1-function-call form)) + +(defun p1-function (form) + (let ((form (copy-tree form)) + local-function) + (cond ((and (consp (cadr form)) + (or (eq (caadr form) 'LAMBDA) + (eq (caadr form) 'NAMED-LAMBDA))) + (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA)) + (named-lambda-form (when named-lambda-p + (cadr form))) + (name (when named-lambda-p + (cadr named-lambda-form))) + (lambda-form (if named-lambda-p + (cons 'LAMBDA (cddr named-lambda-form)) + (cadr form))) + (lambda-list (cadr lambda-form)) + (body (cddr lambda-form)) + (compiland (make-compiland :name (if named-lambda-p + name (gensym "ANONYMOUS-LAMBDA-")) + :lambda-expression lambda-form + :parent *current-compiland*))) + (when *current-compiland* + (incf (compiland-children *current-compiland*))) + (multiple-value-bind (body decls) + (parse-body body) + (setf (compiland-lambda-expression compiland) + (if named-lambda-p + `(lambda ,lambda-list , at decls (block nil , at body)) + `(lambda ,lambda-list , at decls , at body))) + (let ((*visible-variables* *visible-variables*) + (*current-compiland* compiland)) + (p1-compiland compiland))) + (list 'FUNCTION compiland))) + ((setf local-function (find-local-function (cadr form))) + (dformat t "p1-function local function ~S~%" (cadr form)) + (let ((variable (local-function-variable local-function))) + (when variable + (dformat t "p1-function ~S used non-locally~%" (variable-name variable)) + (setf (variable-used-non-locally-p variable) t))) + form) + (t + form)))) + +(defun p1-lambda (form) + (let* ((lambda-list (cadr form)) + (body (cddr form)) + (auxvars (memq '&AUX lambda-list))) + (when (or (memq '&optional lambda-list) + (memq '&key lambda-list)) + (let ((state nil)) + (dolist (arg lambda-list) + (cond ((memq arg lambda-list-keywords) + (setf state arg)) + ((memq state '(&optional &key)) + (when (and (consp arg) + (not (constantp (second arg)))) + (compiler-unsupported + "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) + (when auxvars + (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) + (setf body (list (append (list 'LET* (cdr auxvars)) body)))) + (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body))))) + +(defun p1-eval-when (form) + (list* (car form) (cadr form) (mapcar #'p1 (cddr form)))) + +(defknown p1-progv (t) t) +(defun p1-progv (form) + ;; We've already checked argument count in PRECOMPILE-PROGV. + (let ((new-form (rewrite-progv form))) + (when (neq new-form form) + (return-from p1-progv (p1 new-form)))) + (let ((symbols-form (cadr form)) + (values-form (caddr form)) + (body (cdddr form))) + `(progv ,(p1 symbols-form) ,(p1 values-form) ,@(p1-body body)))) + +(defknown rewrite-progv (t) t) +(defun rewrite-progv (form) + (let ((symbols-form (cadr form)) + (values-form (caddr form)) + (body (cdddr form))) + (cond ((or (unsafe-p symbols-form) (unsafe-p values-form)) + (let ((g1 (gensym)) + (g2 (gensym))) + `(let ((,g1 ,symbols-form) + (,g2 ,values-form)) + (progv ,g1 ,g2 , at body)))) + (t + form)))) + +(defun p1-quote (form) + (unless (= (length form) 2) + (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)." + 'QUOTE + (1- (length form)))) + (let ((arg (%cadr form))) + (if (or (numberp arg) (characterp arg)) + arg + form))) + +(defun p1-setq (form) + (unless (= (length form) 3) + (error "Too many arguments for SETQ.")) + (let ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (let ((variable (find-visible-variable arg1))) + (if variable + (progn + (when (variable-ignore-p variable) + (compiler-style-warn + "Variable ~S is assigned even though it was declared to be ignored." + (variable-name variable))) + (incf (variable-writes variable)) + (cond ((eq (variable-compiland variable) *current-compiland*) + (dformat t "p1-setq: write ~S~%" arg1)) + (t + (dformat t "p1-setq: non-local write ~S~%" arg1) + (setf (variable-used-non-locally-p variable) t)))) + (dformat t "p1-setq: unknown variable ~S~%" arg1))) + (list 'SETQ arg1 (p1 arg2)))) + +(defun p1-the (form) + (unless (= (length form) 3) + (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)." + 'THE + (1- (length form)))) + (let ((type (%cadr form)) + (expr (%caddr form))) + (cond ((and (listp type) (eq (car type) 'VALUES)) + ;; FIXME + (p1 expr)) + ((= *safety* 3) + (let* ((sym (gensym)) + (new-expr `(let ((,sym ,expr)) + (require-type ,sym ',type) + ,sym))) + (p1 new-expr))) + (t + (list 'THE type (p1 expr)))))) + +(defun p1-truly-the (form) + (unless (= (length form) 3) + (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)." + 'TRULY-THE + (1- (length form)))) + (list 'TRULY-THE (%cadr form) (p1 (%caddr form)))) + +(defknown unsafe-p (t) t) +(defun unsafe-p (args) + (cond ((node-p args) + (unsafe-p (node-form args))) + ((atom args) + nil) + (t + (case (%car args) + (QUOTE + nil) + (LAMBDA + nil) + ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK) + t) + (t + (dolist (arg args) + (when (unsafe-p arg) + (return t)))))))) + +(defknown rewrite-throw (t) t) +(defun rewrite-throw (form) + (let ((args (cdr form))) + (if (unsafe-p args) + (let ((syms ()) + (lets ())) + ;; Tag. + (let ((arg (first args))) + (if (constantp arg) + (push arg syms) + (let ((sym (gensym))) + (push sym syms) + (push (list sym arg) lets)))) + ;; Result. "If the result-form produces multiple values, then all the + ;; values are saved." + (let ((arg (second args))) + (if (constantp arg) + (push arg syms) + (let ((sym (gensym))) + (cond ((single-valued-p arg) + (push sym syms) + (push (list sym arg) lets)) + (t + (push (list 'VALUES-LIST sym) syms) + (push (list sym (list 'MULTIPLE-VALUE-LIST arg)) lets)))))) + (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms)))) + form))) + +(defknown p1-throw (t) t) +(defun p1-throw (form) + (let ((new-form (rewrite-throw form))) + (when (neq new-form form) + (return-from p1-throw (p1 new-form)))) + (list* 'THROW (mapcar #'p1 (cdr form)))) + +(defknown rewrite-function-call (t) t) +(defun rewrite-function-call (form) + (let ((args (cdr form))) + (if (unsafe-p args) + (let ((arg1 (car args))) + (cond ((and (consp arg1) (eq (car arg1) 'GO)) + arg1) + (t + (let ((syms ()) + (lets ())) + ;; Preserve the order of evaluation of the arguments! + (dolist (arg args) + (cond ((constantp arg) + (push arg syms)) + ((and (consp arg) (eq (car arg) 'GO)) + (return-from rewrite-function-call + (list 'LET* (nreverse lets) arg))) + (t + (let ((sym (gensym))) + (push sym syms) + (push (list sym arg) lets))))) + (list 'LET* (nreverse lets) (list* (car form) (nreverse syms))))))) + form))) + +(defknown p1-function-call (t) t) +(defun p1-function-call (form) + (let ((new-form (rewrite-function-call form))) + (when (neq new-form form) +;; (let ((*print-structure* nil)) +;; (format t "old form = ~S~%" form) +;; (format t "new form = ~S~%" new-form)) + (return-from p1-function-call (p1 new-form)))) + (let* ((op (car form)) + (local-function (find-local-function op))) + (cond (local-function +;; (format t "p1 local call to ~S~%" op) +;; (format t "inline-p = ~S~%" (inline-p op)) + + (when (and *enable-inline-expansion* (inline-p op)) + (let ((expansion (local-function-inline-expansion local-function))) + (when expansion + (let ((explain *explain*)) + (when (and explain (memq :calls explain)) + (format t "; inlining call to local function ~S~%" op))) + (return-from p1-function-call (p1 (expand-inline form expansion)))))) + + ;; FIXME + (dformat t "local function assumed not single-valued~%") + (setf (compiland-%single-valued-p *current-compiland*) nil) + + (let ((variable (local-function-variable local-function))) + (when variable + (dformat t "p1 ~S used non-locally~%" (variable-name variable)) + (setf (variable-used-non-locally-p variable) t)))) + (t + ;; Not a local function call. + (dformat t "p1 non-local call to ~S~%" op) + (unless (single-valued-p form) +;; (format t "not single-valued op = ~S~%" op) + (setf (compiland-%single-valued-p *current-compiland*) nil))))) + (p1-default form)) + +(defknown p1 (t) t) +(defun p1 (form) + (cond ((symbolp form) + (let (value) + (cond ((null form) + form) + ((eq form t) + form) + ((keywordp form) + form) + ((and (constantp form) + (progn + (setf value (symbol-value form)) + (or (numberp value) + (stringp value) + (pathnamep value)))) + (setf form value)) + (t + (let ((variable (find-visible-variable form))) + (when (null variable) + (unless (or (special-variable-p form) + (memq form *undefined-variables*)) + (compiler-style-warn "Undefined variable: ~S" form) + (push form *undefined-variables*)) + (setf variable (make-variable :name form :special-p t)) + (push variable *visible-variables*)) + (let ((ref (make-var-ref variable))) + (unless (variable-special-p variable) + (when (variable-ignore-p variable) + (compiler-style-warn + "Variable ~S is read even though it was declared to be ignored." + (variable-name variable))) + (push ref (variable-references variable)) + (incf (variable-reads variable)) + (cond ((eq (variable-compiland variable) *current-compiland*) + (dformat t "p1: read ~S~%" form)) + (t + (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" + form + (compiland-name (variable-compiland variable)) + (compiland-name *current-compiland*)) + (setf (variable-used-non-locally-p variable) t)))) + (setf form ref))) + form)))) + ((atom form) + form) + (t + (let ((op (%car form)) + handler) + (cond ((symbolp op) + (when (compiler-macro-function op) + (unless (notinline-p op) + (multiple-value-bind (expansion expanded-p) + (compiler-macroexpand form) + ;; Fall through if no change... + (when expanded-p + (return-from p1 (p1 expansion)))))) + (cond ((setf handler (get op 'p1-handler)) + (funcall handler form)) + ((macro-function op *compile-file-environment*) + (p1 (macroexpand form *compile-file-environment*))) + ((special-operator-p op) + (compiler-unsupported "P1: unsupported special operator ~S" op)) + (t + (p1-function-call form)))) + ((and (consp op) (eq (%car op) 'LAMBDA)) + (p1 (list* 'FUNCALL form))) + (t + form)))))) + +(defun install-p1-handler (symbol handler) + (setf (get symbol 'p1-handler) handler)) + +(defun initialize-p1-handlers () + (dolist (pair '((AND p1-default) + (BLOCK p1-block) + (CATCH p1-catch) + (DECLARE identity) + (EVAL-WHEN p1-eval-when) + (FLET p1-flet) + (FUNCALL p1-funcall) + (FUNCTION p1-function) + (GO p1-go) + (IF p1-if) + (LABELS p1-labels) + (LAMBDA p1-lambda) + (LET p1-let/let*) + (LET* p1-let/let*) + (LOAD-TIME-VALUE identity) + (LOCALLY p1-locally) + (MULTIPLE-VALUE-BIND p1-m-v-b) + (MULTIPLE-VALUE-CALL p1-default) + (MULTIPLE-VALUE-LIST p1-default) + (MULTIPLE-VALUE-PROG1 p1-default) + (OR p1-default) + (PROGN p1-default) + (PROGV p1-progv) + (QUOTE p1-quote) + (RETURN-FROM p1-return-from) + (SETQ p1-setq) + (SYMBOL-MACROLET identity) + (TAGBODY p1-tagbody) + (THE p1-the) + (THROW p1-throw) + (TRULY-THE p1-truly-the) + (UNWIND-PROTECT p1-unwind-protect))) + (install-p1-handler (%car pair) (%cadr pair)))) + +(initialize-p1-handlers) + +(defun p1-compiland (compiland) +;; (format t "p1-compiland name = ~S~%" (compiland-name compiland)) + (let ((form (compiland-lambda-expression compiland))) + (aver (eq (car form) 'LAMBDA)) + (process-optimization-declarations (cddr form)) + + (let* ((lambda-list (cadr form)) + (body (cddr form)) + (auxvars (memq '&AUX lambda-list))) + (when auxvars + (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) + (setf body (list (append (list 'LET* (cdr auxvars)) body)))) + + (when (and (null (compiland-parent compiland)) + ;; FIXME support SETF functions! + (symbolp (compiland-name compiland))) + (when (memq '&OPTIONAL lambda-list) + (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list)) + (let ((required-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list))) + (optional-args (cdr (memq '&OPTIONAL lambda-list)))) + (dformat t "optional-args = ~S~%" optional-args) + (when (= (length optional-args) 1) + (let* ((optional-arg (car optional-args)) + (name (if (consp optional-arg) (%car optional-arg) optional-arg)) + (initform (if (consp optional-arg) (cadr optional-arg) nil)) + (supplied-p-var (and (consp optional-arg) + (= (length optional-arg) 3) + (third optional-arg))) + (all-args + (append required-args (list name) + (when supplied-p-var (list supplied-p-var))))) + (when (<= (length all-args) call-registers-limit) + (dformat t "optional-arg = ~S~%" optional-arg) + (dformat t "supplied-p-var = ~S~%" supplied-p-var) + (dformat t "required-args = ~S~%" required-args) + (dformat t "all-args = ~S~%" all-args) + (cond (supplied-p-var + (let ((xep-lambda-expression + `(lambda ,required-args + (let* ((,name ,initform) + (,supplied-p-var nil)) + (%call-internal , at all-args))))) + (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) + (let ((xep-compiland + (make-compiland :lambda-expression (precompile-form xep-lambda-expression t) + :class-file (compiland-class-file compiland)))) + (compile-xep xep-compiland))) + (let ((xep-lambda-expression + `(lambda ,(append required-args (list name)) + (let* ((,supplied-p-var t)) + (%call-internal , at all-args))))) + (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) + (let ((xep-compiland + (make-compiland :lambda-expression (precompile-form xep-lambda-expression t) + :class-file (compiland-class-file compiland)))) + (compile-xep xep-compiland))) + (setf lambda-list all-args) + (setf (compiland-kind compiland) :internal)) + (t + (let ((xep-lambda-expression + `(lambda ,required-args + (let* ((,name ,initform)) + (,(compiland-name compiland) , at all-args))))) + (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression) + (let ((xep-compiland + (make-compiland :lambda-expression (precompile-form xep-lambda-expression t) + :class-file (compiland-class-file compiland)))) + (compile-xep xep-compiland))) + (setf lambda-list all-args)))))))))) + + (let* ((closure (make-closure `(lambda ,lambda-list nil) nil)) + (syms (sys::varlist closure)) + (vars nil)) + (dolist (sym syms) + (let ((var (make-variable :name sym))) + (push var vars) + (push var *all-variables*))) + (setf (compiland-arg-vars compiland) (nreverse vars)) + (let ((*visible-variables* *visible-variables*)) + (dolist (var (compiland-arg-vars compiland)) + (push var *visible-variables*)) + (let ((free-specials (process-declarations-for-vars body *visible-variables*))) + (dolist (var free-specials) + (push var *visible-variables*))) + (setf (compiland-p1-result compiland) + (list* 'LAMBDA lambda-list (p1-body body)))))))) + +(provide "COMPILER-PASS1") \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compiler-pass2.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,8865 @@ +;;; compiler-pass2.lisp +;;; +;;; Copyright (C) 2003-2008 Peter Graves +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: compiler-pass2.lisp 11652 2009-02-10 07:10:23Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "JVM") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "LOOP") + (require "FORMAT") + (require "CLOS") + (require "PRINT-OBJECT") + (require "COMPILER-TYPES") + (require "KNOWN-FUNCTIONS") + (require "KNOWN-SYMBOLS") + (require "DUMP-FORM") + (require "OPCODES") + (require "JAVA")) + + +(defun dump-pool () + (let ((pool (reverse *pool*)) + entry type) + (dotimes (index (1- *pool-count*)) + (setq entry (car pool)) + (setq type (case (car entry) + (7 'class) + (9 'field) + (10 'method) + (11 'interface) + (8 'string) + (3 'integer) + (4 'float) + (5 'long) + (6 'double) + (12 'name-and-type) + (1 'utf8))) + (format t "~D: ~A ~S~%" (1+ index) type entry) + (setq pool (cdr pool)))) + t) + +(defknown pool-get (t) (integer 1 65535)) +(defun pool-get (entry) + (declare (optimize speed (safety 0))) + (let* ((ht *pool-entries*) + (index (gethash1 entry ht))) + (declare (type hash-table ht)) + (unless index + (setf index *pool-count*) + (push entry *pool*) + (setf (gethash entry ht) index) + (setf *pool-count* (1+ index))) + index)) + +(declaim (ftype (function (string) fixnum) pool-name)) +(declaim (inline pool-name)) +(defun pool-name (name) + (declare (optimize speed)) + (pool-get (list 1 (length name) name))) + +(declaim (ftype (function (string string) fixnum) pool-name-and-type)) +(declaim (inline pool-name-and-type)) +(defun pool-name-and-type (name type) + (declare (optimize speed)) + (pool-get (list 12 + (pool-name name) + (pool-name type)))) + +;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp" +;; as opposed to "org.armedbear.lisp.Lisp"). +(declaim (ftype (function (string) fixnum) pool-class)) +(declaim (inline pool-class)) +(defun pool-class (class-name) + (declare (optimize speed)) + (pool-get (list 7 (pool-name class-name)))) + +;; (tag class-index name-and-type-index) +(declaim (ftype (function (string string string) fixnum) pool-field)) +(declaim (inline pool-field)) +(defun pool-field (class-name field-name type-name) + (declare (optimize speed)) + (pool-get (list 9 + (pool-class class-name) + (pool-name-and-type field-name type-name)))) + +;; (tag class-index name-and-type-index) +(declaim (ftype (function (string string string) fixnum) pool-method)) +(declaim (inline pool-method)) +(defun pool-method (class-name method-name type-name) + (declare (optimize speed)) + (pool-get (list 10 + (pool-class class-name) + (pool-name-and-type method-name type-name)))) + +(declaim (ftype (function (string) fixnum) pool-string)) +(defun pool-string (string) + (declare (optimize speed)) + (pool-get (list 8 (pool-name string)))) + +(defknown pool-int (fixnum) (integer 1 65535)) +(defun pool-int (n) + (declare (optimize speed)) + (pool-get (list 3 n))) + +(defknown pool-float (single-float) (integer 1 65535)) +(defun pool-float (n) + (declare (optimize speed)) + (pool-get (list 4 (%float-bits n)))) + +(defknown pool-long (integer) (integer 1 65535)) +(defun pool-long (n) + (declare (optimize speed)) + (declare (type java-long n)) + (let* ((entry (list 5 + (logand (ash n -32) #xffffffff) + (logand n #xffffffff))) + (ht *pool-entries*) + (index (gethash1 entry ht))) + (declare (type hash-table ht)) + (unless index + (setf index *pool-count*) + (push entry *pool*) + (setf (gethash entry ht) index) + ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte + ;; constants take up two entries in the constant_pool table of the class + ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the + ;; item in the constant_pool table at index n, then the next usable item in + ;; the pool is located at index n+2. The constant_pool index n+1 must be + ;; valid but is considered unusable." So: + (setf *pool-count* (+ index 2))) + index)) + +(defknown pool-double (double-float) (integer 1 65535)) +(defun pool-double (n) + (declare (optimize speed)) + (let* ((n (%float-bits n)) + (entry (list 6 + (logand (ash n -32) #xffffffff) + (logand n #xffffffff))) + (ht *pool-entries*) + (index (gethash1 entry ht))) + (declare (type hash-table ht)) + (unless index + (setf index *pool-count*) + (push entry *pool*) + (setf (gethash entry ht) index) + ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte + ;; constants take up two entries in the constant_pool table of the class + ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the + ;; item in the constant_pool table at index n, then the next usable item in + ;; the pool is located at index n+2. The constant_pool index n+1 must be + ;; valid but is considered unusable." So: + (setf *pool-count* (+ index 2))) + index)) + +(defknown u2 (fixnum) cons) +(defun u2 (n) + (declare (optimize speed)) + (declare (type (unsigned-byte 16) n)) + (when (not (<= 0 n 65535)) + (error "u2 argument ~A out of 65k range." n)) + (list (logand (ash n -8) #xff) + (logand n #xff))) + +(defknown s1 (fixnum) fixnum) +(defun s1 (n) + (declare (optimize speed)) + (declare (type (signed-byte 8) n)) + (when (not (<= -128 n 127)) + (error "s2 argument ~A out of 16-bit signed range." n)) + (if (< n 0) + (1+ (logxor (- n) #xFF)) + n)) + + +(defknown s2 (fixnum) cons) +(defun s2 (n) + (declare (optimize speed)) + (declare (type (signed-byte 16) n)) + (when (not (<= -32768 n 32767)) + (error "s2 argument ~A out of 16-bit signed range." n)) + (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) + n))) + +(defconstant +java-string+ "Ljava/lang/String;") +(defconstant +lisp-class+ "org/armedbear/lisp/Lisp") +(defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil") +(defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass") +(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject") +(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;") +(defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;") +(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol") +(defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;") +(defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") +(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") +(defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") +(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") +(defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;") +(defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") +(defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;") +(defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") +(defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") +(defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;") +(defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum") +(defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;") +(defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat") +(defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;") +(defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat") +(defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;") +(defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter") +(defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;") +(defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;") +(defconstant +lisp-abstract-bit-vector-class+ "org/armedbear/lisp/AbstractBitVector") +(defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector") +(defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString") +(defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector") +(defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") +(defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") +(defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;") +(defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;") +(defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw") +(defconstant +lisp-return-class+ "org/armedbear/lisp/Return") +(defconstant +lisp-go-class+ "org/armedbear/lisp/Go") +(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") +(defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") +(defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") +(defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") +(defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable") +(defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable") +(defconstant +lisp-package-class+ "org/armedbear/lisp/Package") +(defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable") +(defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream") + +(defstruct (instruction (:constructor %make-instruction (opcode args))) + (opcode 0 :type (integer 0 255)) + args + stack + depth + wide) + +(defun make-instruction (opcode args) + (let ((inst (apply #'%make-instruction + (list opcode + (remove :wide-prefix args))))) + (when (memq :wide-prefix args) + (setf (inst-wide inst) t)) + inst)) + +(defun print-instruction (instruction) + (sys::%format nil "~A ~A stack = ~S depth = ~S" + (opcode-name (instruction-opcode instruction)) + (instruction-args instruction) + (instruction-stack instruction) + (instruction-depth instruction))) + +(defknown inst * t) +(defun inst (instr &optional args) + (declare (optimize speed)) + (let ((opcode (if (fixnump instr) + instr + (opcode-number instr)))) + (unless (listp args) + (setf args (list args))) + (make-instruction opcode args))) + +(defknown %%emit * t) +(defun %%emit (instr &rest args) + (declare (optimize speed)) + (let ((instruction (make-instruction instr args))) + (push instruction *code*) + instruction)) + +(defknown %emit * t) +(defun %emit (instr &rest args) + (declare (optimize speed)) + (let ((instruction (inst instr args))) + (push instruction *code*) + instruction)) + +(defmacro emit (instr &rest args) + (when (and (consp instr) (eq (car instr) 'QUOTE) (symbolp (cadr instr))) + (setf instr (opcode-number (cadr instr)))) + (if (fixnump instr) + `(%%emit ,instr , at args) + `(%emit ,instr , at args))) + +(defknown label (symbol) t) +(defun label (symbol) + (declare (type symbol symbol)) + (declare (optimize speed)) + (emit 'label symbol) + (setf (symbol-value symbol) nil)) + +(defknown aload (fixnum) t) +(defun aload (index) + (case index + (0 (emit 'aload_0)) + (1 (emit 'aload_1)) + (2 (emit 'aload_2)) + (3 (emit 'aload_3)) + (t (emit 'aload index)))) + +(defknown astore (fixnum) t) +(defun astore (index) + (case index + (0 (emit 'astore_0)) + (1 (emit 'astore_1)) + (2 (emit 'astore_2)) + (3 (emit 'astore_3)) + (t (emit 'astore index)))) + +(defknown emit-push-nil () t) +(declaim (inline emit-push-nil)) +(defun emit-push-nil () + (emit 'getstatic +lisp-class+ "NIL" +lisp-object+)) + +(defknown emit-push-t () t) +(declaim (inline emit-push-t)) +(defun emit-push-t () + (emit 'getstatic +lisp-class+ "T" +lisp-symbol+)) + +(defknown emit-push-false (t) t) +(defun emit-push-false (representation) + (declare (optimize speed (safety 0))) + (ecase representation + (:boolean + (emit 'iconst_0)) + ((nil) + (emit-push-nil)))) + +(defknown emit-push-true (t) t) +(defun emit-push-true (representation) + (declare (optimize speed (safety 0))) + (ecase representation + (:boolean + (emit 'iconst_1)) + ((nil) + (emit-push-t)))) + +(defknown emit-push-constant-int (fixnum) t) +(defun emit-push-constant-int (n) + (case n + (-1 + (emit 'iconst_m1)) + (0 + (emit 'iconst_0)) + (1 + (emit 'iconst_1)) + (2 + (emit 'iconst_2)) + (3 + (emit 'iconst_3)) + (4 + (emit 'iconst_4)) + (5 + (emit 'iconst_5)) + (t + (if (<= -128 n 127) + (emit 'bipush n) + (if (<= -32768 n 32767) + (emit 'sipush n) + (emit 'ldc (pool-int n))))))) + +(defknown emit-push-constant-long (integer) t) +(defun emit-push-constant-long (n) + (case n + (0 (emit 'lconst_0)) + (1 (emit 'lconst_1)) + (t + (emit 'ldc2_w (pool-long n))))) + +(defknown emit-push-constant-float (single-float) t) +(defun emit-push-constant-float (n) + (case n + (0.0s0 (emit 'fconst_0)) + (1.0s0 (emit 'fconst_1)) + (2.0s0 (emit 'fconst_2)) + (t (emit 'ldc (pool-float n))))) + +(defknown emit-push-constant-double (double-float) t) +(defun emit-push-constant-double (n) + (case n + (0.0d0 (emit 'dconst_0)) + (1.0d0 (emit 'dconst_1)) + (t (emit 'ldc2_w (pool-double n))))) + +(defknown emit-dup (symbol) t) +(defun emit-dup (representation &key (past nil past-supplied-p)) + "Emits the 'dup' instruction required to duplicate `representation'. + +If `past' is specified, the newly duplicated value is inserted on the +stack past the top-most value, which is assumed to be of the representation +passed in `past'." + (emit + (nth (if past-supplied-p + (representation-size past) 0) + (ecase (representation-size representation) + (1 '(dup dup_x1 dup_x2)) + (2 '(dup2 dup2_x1 dup2_x2)))))) + +(defknown emit-swap (symbol symbol) t) +(defun emit-swap (rep1 rep2) + "Swaps 2 values on the stack, +the top-most value's representation being 'rep1'." + (let ((r1-size (representation-size rep1)) + (r2-size (representation-size rep2))) + (cond ((and (= 1 r1-size) + (= 1 r2-size)) + (emit 'swap)) + ((and (= 1 r1-size) + (= 2 r2-size)) + (emit 'dup2_x1) + (emit 'pop2)) + ((and (= 2 r1-size) + (= 1 r2-size)) + (emit 'dup_x2) + (emit 'pop)) + ((and (= 2 r1-size) + (= 2 r2-size)) + (emit 'dup2_x2) + (emit 'pop2))))) + +(declaim (ftype (function (t t) cons) make-descriptor-info)) +(defun make-descriptor-info (arg-types return-type) + (let ((descriptor (with-standard-io-syntax + (with-output-to-string (s) + (princ #\( s) + (dolist (type arg-types) + (princ type s)) + (princ #\) s) + (princ (or return-type "V") s)))) + (stack-effect (let ((result (cond ((null return-type) 0) + ((or (equal return-type "J") + (equal return-type "D")) 2) + (t 1)))) + (dolist (type arg-types result) + (decf result (if (or (equal type "J") + (equal type "D")) + 2 1)))))) + (cons descriptor stack-effect))) + +(defparameter *descriptors* (make-hash-table :test #'equal)) + +;; Just an experiment... +(defmacro defsubst (name lambda-list &rest body) + (let* ((block-name (fdefinition-block-name name)) + (expansion (generate-inline-expansion block-name lambda-list body))) +;; (format t "expansion = ~S~%" expansion) + `(progn + (%defun ',name (lambda ,lambda-list (block ,block-name , at body))) + (precompile ',name) + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (inline-expansion ',name) ',expansion)) + ',name))) + +#+nil +(defmacro defsubst (&rest args) + `(defun , at args)) + + +(declaim (ftype (function (t t) cons) get-descriptor-info)) +(defun get-descriptor-info (arg-types return-type) + (let* ((key (list arg-types return-type)) + (ht *descriptors*) + (descriptor-info (gethash1 key ht))) + (declare (type hash-table ht)) + (or descriptor-info + (setf (gethash key ht) (make-descriptor-info arg-types return-type))))) + +(defsubst get-descriptor (arg-types return-type) + (car (get-descriptor-info arg-types return-type))) + +(declaim (ftype (function * t) emit-invokestatic)) +(defun emit-invokestatic (class-name method-name arg-types return-type) + (let* ((info (get-descriptor-info arg-types return-type)) + (descriptor (car info)) + (stack-effect (cdr info)) + (instruction (emit 'invokestatic class-name method-name descriptor))) + (setf (instruction-stack instruction) stack-effect))) + +(defknown pretty-java-type (t) string) +(defun pretty-java-type (type) + (let ((arrayp nil) + (pretty-string nil)) + (when (and (stringp type) + (> (length type) 0) + (char= (char type 0) #\[)) + (setf arrayp t + type (subseq type 1))) + (setf pretty-string + (cond ((equal type +lisp-object+) + "LispObject") + ((equal type +lisp-symbol+) + "Symbol") + ((equal type +lisp-thread+) + "LispThread") + ((equal type "C") + "char") + ((equal type "I") + "int") + ((equal type "Z") + "boolean") + ((null type) + "void") + (t + type))) + (when arrayp + (setf pretty-string (concatenate 'string pretty-string "[]"))) + pretty-string)) + +(defvar type-representations '((:int fixnum) + (:long (integer #.most-negative-java-long + #.most-positive-java-long)) + (:float single-float) + (:double double-float) + (:char base-char character) + (:boolean boolean) + ) + "Lists the widest Lisp types to be stored in each of the Java primitives +supported (and used) by the compiler.") + +(defun type-representation (the-type) + "Converts a type specification or compiler type into a representation." + (when (null the-type) + (return-from type-representation)) + (do* ((types type-representations (cdr types))) + ((endp types) nil) + (do* ((type-list (cdr (car types)) (cdr type-list)) + (type (car type-list) (car type-list))) + ((endp type-list)) + (when (or (subtypep the-type type) + (compiler-subtypep the-type (make-compiler-type type))) + (return-from type-representation (caar types)))))) + +(defun representation-size (representation) + (ecase representation + ((NIL :int :boolean :float :char) 1) + ((:long :double) 2))) + + +(defknown emit-unbox-boolean () t) +(defun emit-unbox-boolean () + (emit 'instanceof +lisp-nil-class+) + (emit 'iconst_1) + (emit 'ixor)) ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit + +(defknown emit-unbox-character () t) +(defun emit-unbox-character () + (cond ((> *safety* 0) + (emit-invokestatic +lisp-character-class+ "getValue" + (lisp-object-arg-types 1) "C")) + (t + (emit 'checkcast +lisp-character-class+) + (emit 'getfield +lisp-character-class+ "value" "C")))) + +;; source type / +;; targets :boolean :char :int :long :float :double +(defvar rep-conversion `((NIL . #( ,#'emit-unbox-boolean + ,#'emit-unbox-character + "intValue" "longValue" + "floatValue" "doubleValue")) + (:boolean . #( NIL :err :err :err :err :err)) + (:char . #( 1 NIL :err :err :err :err)) + (:int . #( 1 :err NIL i2l i2f i2d)) + (:long . #( 1 :err l2i NIL l2f l2d)) + (:float . #( 1 :err :err :err NIL f2d)) + (:double . #( 1 :err :err :err d2f NIL))) + "Contains a table with operations to be performed to do +internal representation conversion.") + +(defvar rep-classes + '((:boolean #.+lisp-object-class+ #.+lisp-object+) + (:char #.+lisp-character-class+ #.+lisp-character+) + (:int #.+lisp-integer-class+ #.+lisp-integer+) + (:long #.+lisp-integer-class+ #.+lisp-integer+) + (:float #.+lisp-single-float-class+ #.+lisp-single-float+) + (:double #.+lisp-double-float-class+ #.+lisp-double-float+)) + "Lists the class on which to call the `getInstance' method on, +when converting the internal representation to a LispObject.") + +(defvar rep-arg-chars + '((:boolean . "Z") + (:char . "C") + (:int . "I") + (:long . "J") + (:float . "F") + (:double . "D")) + "Lists the argument type identifiers for each +of the internal representations.") + +(defun convert-representation (in out) + "Converts the value on the stack in the `in' representation +to a value on the stack in the `out' representation." + (when (eql in out) + ;; no-op + (return-from convert-representation)) + (when (null out) + ;; Convert back to a lisp object + (when in + (let ((class (cdr (assoc in rep-classes))) + (arg-spec (cdr (assoc in rep-arg-chars)))) + (emit-invokestatic (first class) "getInstance" (list arg-spec) + (second class)))) + (return-from convert-representation)) + (let* ((in-map (cdr (assoc in rep-conversion))) + (op-num (position out '(:boolean :char :int :long :float :double))) + (op (aref in-map op-num))) + (when op + ;; Convert from one internal representation into another + (assert (neq op :err)) + (cond ((eql op 1) + (emit-move-from-stack nil in) + (emit 'iconst_1)) + ((functionp op) + (funcall op)) + ((stringp op) + (emit-invokevirtual +lisp-object-class+ op nil + (cdr (assoc out rep-arg-chars)))) + (t + (emit op)))))) + +(defvar common-representations '((:int :long :long) + (:int :float :double) + (:int :double :double) + (:float :int :double) + (:float :double :double) + (:double :int :double) + (:double :float :double)) + "Representations to convert unequal representations to, in order +to get the correct (exact where required) comparisons.") + +(defun common-representation (rep1 rep2) + (when (eq rep1 rep2) + (return-from common-representation rep1)) + (do* ((remaining common-representations (cdr remaining)) + (rep (car remaining) (car remaining))) + ((endp remaining)) + (destructuring-bind + (r1 r2 result) rep + (when (and (eq rep1 r1) (eq rep2 r2)) + (return-from common-representation result))))) + + + +(declaim (ftype (function t string) pretty-java-class)) +(defun pretty-java-class (class) + (cond ((equal class +lisp-object-class+) + "LispObject") + ((equal class +lisp-symbol+) + "Symbol") + ((equal class +lisp-thread-class+) + "LispThread") + (t + class))) + +(defknown emit-invokevirtual (t t t t) t) +(defun emit-invokevirtual (class-name method-name arg-types return-type) + (let* ((info (get-descriptor-info arg-types return-type)) + (descriptor (car info)) + (stack-effect (cdr info)) + (instruction (emit 'invokevirtual class-name method-name descriptor))) + (declare (type (signed-byte 8) stack-effect)) + (let ((explain *explain*)) + (when (and explain (memq :java-calls explain)) + (unless (string= method-name "execute") + (format t "; call to ~A ~A.~A(~{~A~^,~})~%" + (pretty-java-type return-type) + (pretty-java-class class-name) + method-name + (mapcar 'pretty-java-type arg-types))))) + (setf (instruction-stack instruction) (1- stack-effect)))) + +(defknown emit-invokespecial-init (string list) t) +(defun emit-invokespecial-init (class-name arg-types) + (let* ((info (get-descriptor-info arg-types nil)) + (descriptor (car info)) + (stack-effect (cdr info)) + (instruction (emit 'invokespecial class-name "" descriptor))) + (declare (type (signed-byte 8) stack-effect)) + (setf (instruction-stack instruction) (1- stack-effect)))) + +;; Index of local variable used to hold the current thread. +(defvar *thread* nil) + +(defvar *initialize-thread-var* nil) + +(defun maybe-initialize-thread-var () + (when *initialize-thread-var* + (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+) + (astore *thread*) + (setf *initialize-thread-var* nil))) + +(defknown ensure-thread-var-initialized () t) +(declaim (inline ensure-thread-var-initialized)) +(defun ensure-thread-var-initialized () + (setf *initialize-thread-var* t)) + +(defknown emit-push-current-thread () t) +(defun emit-push-current-thread () + (declare (optimize speed)) + (ensure-thread-var-initialized) + (aload *thread*)) + +(defun local-variable-p (variable) + "Return non-NIL if `variable' is a local variable. + +Special variables are not considered local." + (or (variable-register variable) ;; either register or index + (variable-index variable))) ;; is non-nil for local variables + +(defun emit-load-local-variable (variable) + "Loads a local variable in the top stack position." + (aver (local-variable-p variable)) + (if (variable-register variable) + (aload (variable-register variable)) + (progn + (aload (compiland-argument-register *current-compiland*)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload)))) + +(defun emit-push-variable-name (variable) + (emit 'getstatic *this-class* (declare-symbol (variable-name variable)) + +lisp-symbol+)) + +(defknown generate-instanceof-type-check-for-variable (t t) t) +(defun generate-instanceof-type-check-for-variable (variable expected-type) + "Generate a type check for `variable'. + +The stack pointer is returned to the position from +before the emitted code: the code is 'stack-neutral'." + (declare (type symbol expected-type)) + (unless (local-variable-p variable) + (return-from generate-instanceof-type-check-for-variable)) + (let ((instanceof-class (ecase expected-type + (SYMBOL +lisp-symbol-class+) + (CHARACTER +lisp-character-class+) + (CONS +lisp-cons-class+) + (HASH-TABLE +lisp-hash-table-class+) + (FIXNUM +lisp-fixnum-class+) + (STREAM +lisp-stream-class+) + (STRING +lisp-abstract-string-class+) + (VECTOR +lisp-abstract-vector-class+))) + (expected-type-java-symbol-name (case expected-type + (HASH-TABLE "HASH_TABLE") + (t + (symbol-name expected-type)))) + (LABEL1 (gensym))) + (emit-load-local-variable variable) + (emit 'instanceof instanceof-class) + (emit 'ifne LABEL1) + (emit-load-local-variable variable) + (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name + +lisp-symbol+) + (emit-invokestatic +lisp-class+ "type_error" + (lisp-object-arg-types 2) +lisp-object+) + (emit 'pop) ; Needed for JVM stack consistency. + (label LABEL1)) + t) + +(defun find-type-for-type-check (declared-type) + (if (eq declared-type :none) nil + (or + (when (fixnum-type-p declared-type) 'FIXNUM) + (find-if #'(lambda (type) (eq type declared-type)) + '(SYMBOL CHARACTER CONS HASH-TABLE)) + (find-if #'(lambda (type) (subtypep declared-type type)) + '(STRING VECTOR STREAM))))) + + +(defknown generate-type-check-for-variable (t) t) +(defun generate-type-check-for-variable (variable) + (let ((type-to-use + (find-type-for-type-check (variable-declared-type variable)))) + (when type-to-use + (generate-instanceof-type-check-for-variable variable type-to-use)))) + +(defknown maybe-generate-type-check (t) t) +(defun maybe-generate-type-check (variable) + (unless (or (zerop *safety*) + (variable-special-p variable) + ;### + (eq (variable-representation variable) :int)) + (let ((declared-type (variable-declared-type variable))) + (unless (eq declared-type :none) + (unless (subtypep (derive-type (variable-initform variable)) declared-type) + (generate-type-check-for-variable variable)))))) + +(defknown generate-type-checks-for-variables (list) t) +(defun generate-type-checks-for-variables (variables) + (unless (zerop *safety*) + (dolist (variable variables) + (unless (variable-special-p variable) + (generate-type-check-for-variable variable))) + t)) + +(defun generate-arg-count-check (arity) + (aver (fixnump arity)) + (aver (not (minusp arity))) + (aver (not (null (compiland-argument-register *current-compiland*)))) + (let ((label1 (gensym))) + (aload (compiland-argument-register *current-compiland*)) + (emit 'arraylength) + (emit-push-constant-int arity) + (emit 'if_icmpeq label1) + (aload 0) ; this + (emit-invokevirtual *this-class* "argCountError" nil nil) + (label label1))) + +(defun maybe-generate-interrupt-check () + (unless (> *speed* *safety*) + (let ((label1 (gensym))) + (emit 'getstatic +lisp-class+ "interrupted" "Z") + (emit 'ifeq label1) + (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil) + (label label1)))) + +(defknown single-valued-p (t) t) +(defun single-valued-p (form) + (cond ((block-node-p form) + (if (equal (block-name form) '(TAGBODY)) + (not (unsafe-p (node-form form))) + (single-valued-p (node-form form)))) + ((var-ref-p form) + t) + ((atom form) + t) + (t + (let ((op (%car form)) + result-type + compiland) + (cond ((eq op 'IF) + (and (single-valued-p (third form)) + (single-valued-p (fourth form)))) + ((eq op 'PROGN) + (single-valued-p (car (last form)))) + ((eq op 'BLOCK) + (single-valued-p (car (last form)))) + ((memq op '(LET LET*)) + (single-valued-p (car (last (cddr form))))) + ((memq op '(AND OR)) + (every #'single-valued-p (cdr form))) + ((eq op 'RETURN-FROM) + (single-valued-p (third form))) + ((memq op '(THE TRULY-THE)) + (single-valued-p (third form))) + ((setf result-type + (or (function-result-type op) + (and (proclaimed-ftype op) + (ftype-result-type (proclaimed-ftype op))))) + (cond ((eq result-type '*) + nil) + ((atom result-type) + t) + ((eq (%car result-type) 'VALUES) + (= (length result-type) 2)) + (t + t))) + ((and (setf compiland *current-compiland*) + (eq op (compiland-name compiland))) + (compiland-%single-valued-p compiland)) + (t + nil)))))) + +(defknown emit-clear-values () t) +(defun emit-clear-values () + (declare (optimize speed (safety 0))) + (ensure-thread-var-initialized) + (emit 'clear-values)) + +(defknown maybe-emit-clear-values (&rest t) t) +(defun maybe-emit-clear-values (&rest forms) + (declare (optimize speed)) + (dolist (form forms) + (unless (single-valued-p form) +;; (let ((*print-structure* nil)) +;; (format t "Not single-valued: ~S~%" form)) + (ensure-thread-var-initialized) + (emit 'clear-values) + (return)))) + +(defun compile-forms-and-maybe-emit-clear-values (&rest forms-and-compile-args) + (let ((forms-for-emit-clear + (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr + do (compile-form form arg1 arg2) + collecting form))) + (apply #'maybe-emit-clear-values forms-for-emit-clear))) + +(defknown emit-unbox-fixnum () t) +(defun emit-unbox-fixnum () + (declare (optimize speed)) + (cond ((= *safety* 3) + (emit-invokestatic +lisp-fixnum-class+ "getValue" + (lisp-object-arg-types 1) "I")) + (t + (emit 'checkcast +lisp-fixnum-class+) + (emit 'getfield +lisp-fixnum-class+ "value" "I")))) + +(defknown emit-unbox-long () t) +(defun emit-unbox-long () + (emit-invokestatic +lisp-bignum-class+ "longValue" + (lisp-object-arg-types 1) "J")) + +(defknown emit-unbox-float () t) +(defun emit-unbox-float () + (declare (optimize speed)) + (cond ((= *safety* 3) + (emit-invokestatic +lisp-single-float-class+ "getValue" + (lisp-object-arg-types 1) "F")) + (t + (emit 'checkcast +lisp-single-float-class+) + (emit 'getfield +lisp-single-float-class+ "value" "F")))) + +(defknown emit-unbox-double () t) +(defun emit-unbox-double () + (declare (optimize speed)) + (cond ((= *safety* 3) + (emit-invokestatic +lisp-double-float-class+ "getValue" + (lisp-object-arg-types 1) "D")) + (t + (emit 'checkcast +lisp-double-float-class+) + (emit 'getfield +lisp-double-float-class+ "value" "D")))) + +(defknown fix-boxing (t t) t) +(defun fix-boxing (required-representation derived-type) + "Generate code to convert a boxed LispObject on the stack to the specified +representation, based on the derived type of the LispObject." + (cond ((null required-representation)) ; Nothing to do. + ((eq required-representation :int) + (cond ((and (fixnum-type-p derived-type) + (< *safety* 3)) + (emit 'checkcast +lisp-fixnum-class+) + (emit 'getfield +lisp-fixnum-class+ "value" "I")) + (t + (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")))) + ((eq required-representation :char) + (emit-unbox-character)) + ((eq required-representation :boolean) + (emit-unbox-boolean)) + ((eq required-representation :long) + (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) + ((eq required-representation :float) + (emit-invokevirtual +lisp-object-class+ "floatValue" nil "F")) + ((eq required-representation :double) + (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D")) + (t (assert nil)))) + +(defknown emit-move-from-stack (t &optional t) t) +(defun emit-move-from-stack (target &optional representation) + (declare (optimize speed)) + (cond ((null target) + (ecase representation + ((:long :double) + (emit 'pop2)) + ((NIL :int :boolean :char :float) + (emit 'pop)))) + ((eq target 'stack)) ; Nothing to do. + ((fixnump target) + ;; A register. + (emit (ecase representation + ((:int :boolean :char) + 'istore) + (:long 'lstore) + (:float 'fstore) + (:double 'dstore) + ((nil) 'astore)) + target)) + (t + (sys::%format t "emit-move-from-stack general case~%") + (aver nil)))) + +;; Expects value on stack. +(defknown emit-invoke-method (t t t) t) +(defun emit-invoke-method (method-name target representation) + (emit-invokevirtual +lisp-object-class+ method-name nil +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + +(defvar *style-warnings* nil) +(defvar *warnings* nil) +(defvar *errors* nil) + +(defvar *last-error-context* nil) + +(defun note-error-context () + (let ((context *compiler-error-context*)) + (when (and context (neq context *last-error-context*)) + (fresh-line *error-output*) + (princ "; in " *error-output*) + (let ((*print-length* 2) + (*print-level* 2) + (*print-pretty* nil)) + (prin1 context *error-output*)) + (terpri *error-output*) + (terpri *error-output*) + (setf *last-error-context* context)))) + +(defvar *resignal-compiler-warnings* nil) ; bind this to t inside slime compilation + +(defun handle-style-warning (condition) + (cond (*resignal-compiler-warnings* + (signal condition)) + (t + (unless *suppress-compiler-warnings* + (fresh-line *error-output*) + (note-error-context) + (format *error-output* "; Caught ~A:~%; ~A~2%" (type-of condition) condition)) + (incf *style-warnings*) + (muffle-warning)))) + +(defun handle-warning (condition) + (cond (*resignal-compiler-warnings* + (signal condition)) + (t + (unless *suppress-compiler-warnings* + (fresh-line *error-output*) + (note-error-context) + (format *error-output* "; Caught ~A:~%; ~A~2%" (type-of condition) condition)) + (incf *warnings*) + (muffle-warning)))) + +(defun handle-compiler-error (condition) + (fresh-line *error-output*) + (note-error-context) + (format *error-output* "; Caught ERROR:~%; ~A~2%" condition) + (incf *errors*) + (throw 'compile-defun-abort (funcall *compiler-error-bailout*))) + +;; "In addition to situations for which the standard specifies that conditions +;; of type WARNING must or might be signaled, warnings might be signaled in +;; situations where the compiler can determine that the consequences are +;; undefined or that a run-time error will be signaled. Examples of this +;; situation are as follows: violating type declarations, altering or assigning +;; the value of a constant defined with DEFCONSTANT, calling built-in Lisp +;; functions with a wrong number of arguments or malformed keyword argument +;; lists, and using unrecognized declaration specifiers." (3.2.5) +(defknown check-arg-count (t fixnum) t) +(defun check-arg-count (form n) + (declare (type fixnum n)) + (let* ((op (car form)) + (args (cdr form)) + (ok (= (length args) n))) + (declare (type boolean ok)) + (unless ok + (funcall (if (eq (symbol-package op) +cl-package+) + #'compiler-warn ; See above! + #'compiler-style-warn) + "Wrong number of arguments for ~A (expected ~D, but received ~D)." + op n (length args))) + ok)) + +(declaim (ftype (function (t fixnum) t) check-min-args)) +(defun check-min-args (form n) + (declare (type fixnum n)) + (let* ((op (car form)) + (args (cdr form)) + (ok (>= (length args) n))) + (unless ok + (funcall (if (eq (symbol-package op) +cl-package+) + #'compiler-warn ; See above! + #'compiler-style-warn) + "Wrong number of arguments for ~A (expected at least ~D, but received ~D)." + op n (length args))) + ok)) + +(defun unsupported-opcode (instruction) + (error "Unsupported opcode ~D." (instruction-opcode instruction))) + +(declaim (type hash-table +resolvers+)) +(defconst +resolvers+ (make-hash-table)) + +(defun initialize-resolvers () + (let ((ht +resolvers+)) + (dotimes (n (1+ *last-opcode*)) + (setf (gethash n ht) #'unsupported-opcode)) + ;; The following opcodes resolve to themselves. + (dolist (n '(0 ; nop + 1 ; aconst_null + 2 ; iconst_m1 + 3 ; iconst_0 + 4 ; iconst_1 + 5 ; iconst_2 + 6 ; iconst_3 + 7 ; iconst_4 + 8 ; iconst_5 + 9 ; lconst_0 + 10 ; lconst_1 + 11 ; fconst_0 + 12 ; fconst_1 + 13 ; fconst_2 + 14 ; dconst_0 + 15 ; dconst_1 + 42 ; aload_0 + 43 ; aload_1 + 44 ; aload_2 + 45 ; aload_3 + 50 ; aaload + 75 ; astore_0 + 76 ; astore_1 + 77 ; astore_2 + 78 ; astore_3 + 83 ; aastore + 87 ; pop + 88 ; pop2 + 89 ; dup + 90 ; dup_x1 + 91 ; dup_x2 + 92 ; dup2 + 93 ; dup2_x1 + 94 ; dup2_x2 + 95 ; swap + 96 ; iadd + 97 ; ladd + 98 ; fadd + 99 ; dadd + 100 ; isub + 101 ; lsub + 102 ; fsub + 103 ; dsub + 104 ; imul + 105 ; lmul + 106 ; fmul + 107 ; dmul + 116 ; ineg + 117 ; lneg + 118 ; fneg + 119 ; dneg + 120 ; ishl + 121 ; lshl + 122 ; ishr + 123 ; lshr + 126 ; iand + 127 ; land + 128 ; ior + 129 ; lor + 130 ; ixor + 131 ; lxor + 133 ; i2l + 134 ; i2f + 135 ; i2d + 136 ; l2i + 137 ; l2f + 138 ; l2d + 141 ; f2d + 144 ; d2f + 148 ; lcmp + 149 ; fcmpd + 150 ; fcmpg + 151 ; dcmpd + 152 ; dcmpg + 153 ; ifeq + 154 ; ifne + 155 ; ifge + 156 ; ifgt + 157 ; ifgt + 158 ; ifle + 159 ; if_icmpeq + 160 ; if_icmpne + 161 ; if_icmplt + 162 ; if_icmpge + 163 ; if_icmpgt + 164 ; if_icmple + 165 ; if_acmpeq + 166 ; if_acmpne + 167 ; goto + 168 ; jsr + 169 ; ret + 176 ; areturn + 177 ; return + 190 ; arraylength + 191 ; athrow + 198 ; ifnull + 202 ; label + )) + (setf (gethash n ht) nil)))) + +(initialize-resolvers) + +(defmacro define-resolver (opcodes args &body body) + (let ((name (gensym))) + `(progn + (defun ,name ,args , at body) + (eval-when (:load-toplevel :execute) + ,(if (listp opcodes) + `(dolist (op ',opcodes) + (setf (gethash op +resolvers+) (symbol-function ',name))) + `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name))))))) + +;; aload +(define-resolver 25 (instruction) + (let* ((args (instruction-args instruction)) + (index (car args))) + (declare (type (unsigned-byte 16) index)) + (cond ((<= 0 index 3) + (inst (+ index 42))) + ((<= 0 index 255) + (inst 25 index)) + (t + (error "ALOAD unsupported case"))))) + +;; astore +(define-resolver 58 (instruction) + (let* ((args (instruction-args instruction)) + (index (car args))) + (declare (type (unsigned-byte 16) index)) + (cond ((<= 0 index 3) + (inst (+ index 75))) + ((<= 0 index 255) + (inst 58 index)) + (t + (error "ASTORE unsupported case"))))) + +;; iload +(define-resolver 21 (instruction) + (let* ((args (instruction-args instruction)) + (index (car args))) + (declare (type (unsigned-byte 16) index)) + (cond ((<= 0 index 3) + (inst (+ index 26))) + ((<= 0 index 255) + (inst 21 index)) + (t + (error "ILOAD unsupported case"))))) + +;; istore +(define-resolver 54 (instruction) + (let* ((args (instruction-args instruction)) + (index (car args))) + (declare (type (unsigned-byte 16) index)) + (cond ((<= 0 index 3) + (inst (+ index 59))) + ((<= 0 index 255) + (inst 54 index)) + (t + (error "ASTORE unsupported case"))))) + +;; lload +(define-resolver 22 (instruction) + (let* ((args (instruction-args instruction)) + (index (car args))) + (declare (type (unsigned-byte 16) index)) + (cond ((<= 0 index 3) + (inst (+ index 30))) + ((<= 0 index 255) + (inst 22 index)) + (t + (error "LLOAD unsupported case"))))) + +;; lstore +(define-resolver 55 (instruction) + (let* ((args (instruction-args instruction)) + (index (car args))) + (declare (type (unsigned-byte 16) index)) + (cond ((<= 0 index 3) + (inst (+ index 63))) + ((<= 0 index 255) + (inst 55 index)) + (t + (error "ASTORE unsupported case"))))) + +;; getstatic, putstatic +(define-resolver (178 179) (instruction) + (let* ((args (instruction-args instruction)) + (index (pool-field (first args) (second args) (third args)))) + (inst (instruction-opcode instruction) (u2 index)))) + +;; bipush, sipush +(define-resolver (16 17) (instruction) + (let* ((args (instruction-args instruction)) + (n (first args))) + (declare (type fixnum n)) + (cond ((<= 0 n 5) + (inst (+ n 3))) + ((<= -128 n 127) + (inst 16 (logand n #xff))) ; BIPUSH + (t ; SIPUSH + (inst 17 (s2 n)))))) + +;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor +(define-resolver (182 183 184) (instruction) + (let* ((args (instruction-args instruction)) + (index (pool-method (first args) (second args) (third args)))) + (setf (instruction-args instruction) (u2 index)) + instruction)) + +;; ldc +(define-resolver 18 (instruction) + (let* ((args (instruction-args instruction))) + (unless (= (length args) 1) + (error "Wrong number of args for LDC.")) + (if (> (car args) 255) + (inst 19 (u2 (car args))) ; LDC_W + (inst 18 args)))) + +;; ldc2_w +(define-resolver 20 (instruction) +;; (format t "resolving ldc2_w...~%") + (let* ((args (instruction-args instruction))) +;; (format t "args = ~S~%" args) + (unless (= (length args) 1) + (error "Wrong number of args for LDC2_W.")) +;; (if (> (car args) 255) +;; (inst 19 (u2 (car args))) ; LDC_W +;; (inst 18 args)))) + (inst 20 (u2 (car args))))) + +;; getfield, putfield class-name field-name type-name +(define-resolver (180 181) (instruction) + (let* ((args (instruction-args instruction)) + (index (pool-field (first args) (second args) (third args)))) + (inst (instruction-opcode instruction) (u2 index)))) + +;; new, anewarray, checkcast, instanceof class-name +(define-resolver (187 189 192 193) (instruction) + (let* ((args (instruction-args instruction)) + (index (pool-class (first args)))) + (inst (instruction-opcode instruction) (u2 index)))) + +;; iinc +(define-resolver 132 (instruction) + (let* ((args (instruction-args instruction)) + (register (first args)) + (n (second args))) + (when (not (<= -128 n 127)) + (error "IINC argument ~A out of bounds." n)) + (inst 132 (list register (s1 n))))) + +(defknown resolve-instruction (t) t) +(defun resolve-instruction (instruction) + (declare (optimize speed)) + (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+))) + (if resolver + (funcall resolver instruction) + instruction))) + +(defun resolve-instructions (code) + (let ((vector (make-array 512 :fill-pointer 0 :adjustable t))) + (dotimes (index (length code) vector) + (declare (type (unsigned-byte 16) index)) + (let ((instruction (svref code index))) + (case (instruction-opcode instruction) + (205 ; CLEAR-VALUES + (let ((instructions + (list + (inst 'aload *thread*) + (inst 'aconst_null) + (inst 'putfield (list +lisp-thread-class+ "_values" + +lisp-object-array+))))) + (dolist (instruction instructions) + (vector-push-extend (resolve-instruction instruction) vector)))) + (t + (vector-push-extend (resolve-instruction instruction) vector))))))) + +;; (defconstant +branch-opcodes+ +;; '(153 ; IFEQ +;; 154 ; IFNE +;; 155 ; IFLT +;; 156 ; IFGE +;; 157 ; IFGT +;; 158 ; IFLE +;; 159 ; IF_ICMPEQ +;; 160 ; IF_ICMPNE +;; 161 ; IF_ICMPLT +;; 162 ; IF_ICMPGE +;; 163 ; IF_ICMPGT +;; 164 ; IF_ICMPLE +;; 165 ; IF_ACMPEQ +;; 166 ; IF_ACMPNE +;; 167 ; GOTO +;; 168 ; JSR +;; 198 ; IFNULL +;; )) + +(declaim (ftype (function (t) t) branch-opcode-p)) +(declaim (inline branch-opcode-p)) +(defun branch-opcode-p (opcode) + (declare (optimize speed)) + (declare (type '(integer 0 255) opcode)) + (or (<= 153 opcode 168) + (= opcode 198))) + +(declaim (ftype (function (t t t) t) walk-code)) +(defun walk-code (code start-index depth) + (declare (optimize speed)) + (declare (type fixnum start-index depth)) + (do* ((i start-index (1+ i)) + (limit (length code))) + ((>= i limit)) + (declare (type fixnum i limit)) + (let* ((instruction (aref code i)) + (instruction-depth (instruction-depth instruction)) + (instruction-stack (instruction-stack instruction))) + (declare (type fixnum instruction-stack)) + (when instruction-depth + (unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack))) + (format t "~&Stack inconsistency at index ~D: found ~S, expected ~S.~%" + i instruction-depth (+ depth instruction-stack))) + (return-from walk-code)) + (let ((opcode (instruction-opcode instruction))) + (unless (eql opcode 168) ; JSR + (setf depth (+ depth instruction-stack))) + (setf (instruction-depth instruction) depth) + (if (eql opcode 168) ; JSR + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (walk-code code (symbol-value label) (1+ depth))) + (when (branch-opcode-p opcode) + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (walk-code code (symbol-value label) depth)))) + (when (member opcode '(167 169 176 191)) ; GOTO RET ARETURN ATHROW + ;; Current path ends. + (return-from walk-code)))))) + +(declaim (ftype (function () t) analyze-stack)) +(defun analyze-stack () + (declare (optimize speed)) + (let* ((code *code*) + (code-length (length code))) + (declare (type vector code)) + (dotimes (i code-length) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (when (eql opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label i))) + (if (instruction-stack instruction) + (when (opcode-stack-effect opcode) + (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode)) + (sys::%format t "instruction-stack = ~S opcode-stack-effect = ~S~%" + (instruction-stack instruction) + (opcode-stack-effect opcode)) + (sys::%format t "index = ~D instruction = ~A~%" i (print-instruction instruction)))) + (setf (instruction-stack instruction) (opcode-stack-effect opcode))) + (unless (instruction-stack instruction) + (sys::%format t "no stack information for instruction ~D~%" (instruction-opcode instruction)) + (aver nil)))) + (walk-code code 0 0) + (dolist (handler *handlers*) + ;; Stack depth is always 1 when handler is called. + (walk-code code (symbol-value (handler-code handler)) 1)) + (let ((max-stack 0)) + (declare (type fixnum max-stack)) + (dotimes (i code-length) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (instruction-depth (instruction-depth instruction))) + (when instruction-depth + (setf max-stack (max max-stack (the fixnum instruction-depth)))))) +;; (when *compiler-debug* +;; (sys::%format t "compiland name = ~S~%" (compiland-name *current-compiland*)) +;; (sys::%format t "max-stack = ~D~%" max-stack) +;; (sys::%format t "----- after stack analysis -----~%") +;; (print-code)) + max-stack))) + + +(defun finalize-code () + (setf *code* (nreverse (coerce *code* 'vector)))) + +(defun print-code () + (dotimes (i (length *code*)) + (let ((instruction (elt *code* i))) + (sys::%format t "~D ~A ~S ~S ~S~%" + i + (opcode-name (instruction-opcode instruction)) + (instruction-args instruction) + (instruction-stack instruction) + (instruction-depth instruction))))) + +(defun print-code2 (code) + (dotimes (i (length code)) + (let ((instruction (elt code i))) + (case (instruction-opcode instruction) + (202 ; LABEL + (format t "~A:~%" (car (instruction-args instruction)))) + (t + (format t "~8D: ~A ~S~%" + i + (opcode-name (instruction-opcode instruction)) + (instruction-args instruction))))))) + +(declaim (ftype (function (t) boolean) label-p)) +(defun label-p (instruction) +;; (declare (optimize safety)) +;; (declare (type instruction instruction)) + (and instruction + (= (the fixnum (instruction-opcode (the instruction instruction))) 202))) + +(declaim (ftype (function (t) t) instruction-label)) +(defun instruction-label (instruction) +;; (declare (optimize safety)) + (and instruction + (= (instruction-opcode (the instruction instruction)) 202) + (car (instruction-args instruction)))) + +;; Remove unused labels. +(defun optimize-1 () + (let ((code (coerce *code* 'vector)) + (changed nil) + (marker (gensym))) + ;; Mark the labels that are actually branched to. + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (branch-opcode-p (instruction-opcode instruction)) + (let ((label (car (instruction-args instruction)))) + (set label marker))))) + ;; Add labels used for exception handlers. + (dolist (handler *handlers*) + (set (handler-from handler) marker) + (set (handler-to handler) marker) + (set (handler-code handler) marker)) + ;; Remove labels that are not used as branch targets. + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (= (instruction-opcode instruction) 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (declare (type symbol label)) + (unless (eq (symbol-value label) marker) + (setf (aref code i) nil) + (setf changed t)))))) + (when changed + (setf *code* (delete nil code)) + t))) + +(defun optimize-2 () + (let* ((code (coerce *code* 'vector)) + (length (length code)) + (changed nil)) + (declare (type (unsigned-byte 16) length)) + ;; Since we're looking at this instruction and the next one, we can stop + ;; one before the end. + (dotimes (i (1- length)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO + (do* ((j (1+ i) (1+ j)) + (next-instruction (aref code j) (aref code j))) + ((>= j length)) + (declare (type (unsigned-byte 16) j)) + (when next-instruction + (cond ((= (instruction-opcode next-instruction) 167) ; GOTO + (cond ((= j (1+ i)) + ;; Two GOTOs in a row: the second instruction is + ;; unreachable. + (setf (aref code j) nil) + (setf changed t)) + (;;(equal next-instruction instruction) + (eq (car (instruction-args next-instruction)) + (car (instruction-args instruction))) + ;; We've reached another GOTO to the same destination. + ;; We don't need the first GOTO; we can just fall + ;; through to the second one. + (setf (aref code i) nil) + (setf changed t))) + (return)) + ((= (instruction-opcode next-instruction) 202) ; LABEL + (when (eq (car (instruction-args instruction)) + (car (instruction-args next-instruction))) + ;; GOTO next instruction; we don't need this one. + (setf (aref code i) nil) + (setf changed t) + (return))) + (t + ;; Not a GOTO or a label. + (return)))))))) + (when changed + (setf *code* (delete nil code)) + t))) + +(declaim (ftype (function (t) hash-table) hash-labels)) +(defun hash-labels (code) + (let ((ht (make-hash-table :test 'eq)) + (code (coerce code 'vector)) + (pending-labels '())) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (cond ((label-p instruction) + (push (instruction-label instruction) pending-labels)) + (t + ;; Not a label. + (when pending-labels + (dolist (label pending-labels) + (setf (gethash label ht) instruction)) + (setf pending-labels nil)))))) + ht)) + +(defun optimize-2b () + (let* ((code (coerce *code* 'vector)) + (ht (hash-labels code)) + (changed nil)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO + (let* ((target-label (car (instruction-args instruction))) + (next-instruction (gethash1 target-label ht))) + (when next-instruction + (case (instruction-opcode next-instruction) + (167 ; GOTO + (setf (instruction-args instruction) + (instruction-args next-instruction) + changed t)) + (176 ; ARETURN + (setf (instruction-opcode instruction) 176 + (instruction-args instruction) nil + changed t)))))))) + (when changed + (setf *code* code) + t))) + +;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES +;; GETSTATIC POP => nothing +(defun optimize-3 () + (let* ((code (coerce *code* 'vector)) + (changed nil)) + (dotimes (i (1- (length code))) + (declare (type (unsigned-byte 16) i)) + (let* ((this-instruction (aref code i)) + (this-opcode (and this-instruction (instruction-opcode this-instruction))) + (next-instruction (aref code (1+ i))) + (next-opcode (and next-instruction (instruction-opcode next-instruction)))) + (case this-opcode + (205 ; CLEAR-VALUES + (when (eql next-opcode 205) ; CLEAR-VALUES + (setf (aref code i) nil) + (setf changed t))) + (178 ; GETSTATIC + (when (eql next-opcode 87) ; POP + (setf (aref code i) nil) + (setf (aref code (1+ i)) nil) + (setf changed t)))))) + (when changed + (setf *code* (delete nil code)) + t))) + +(defun delete-unreachable-code () + ;; Look for unreachable code after GOTO. + (let* ((code (coerce *code* 'vector)) + (changed nil) + (after-goto/areturn nil)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (cond (after-goto/areturn + (if (= opcode 202) ; LABEL + (setf after-goto/areturn nil) + ;; Unreachable. + (progn + (setf (aref code i) nil) + (setf changed t)))) + ((= opcode 176) ; ARETURN + (setf after-goto/areturn t)) + ((= opcode 167) ; GOTO + (setf after-goto/areturn t))))) + (when changed + (setf *code* (delete nil code)) + t))) + +(defvar *enable-optimization* t) + +(defknown optimize-code () t) +(defun optimize-code () + (unless *enable-optimization* + (format t "optimizations are disabled~%")) + (when *enable-optimization* + (when *compiler-debug* + (format t "----- before optimization -----~%") + (print-code)) + (loop + (let ((changed-p nil)) + (setf changed-p (or (optimize-1) changed-p)) + (setf changed-p (or (optimize-2) changed-p)) + (setf changed-p (or (optimize-2b) changed-p)) + (setf changed-p (or (optimize-3) changed-p)) + (setf changed-p (or (delete-unreachable-code) changed-p)) + (unless changed-p + (return)))) + (unless (vectorp *code*) + (setf *code* (coerce *code* 'vector))) + (when *compiler-debug* + (sys::%format t "----- after optimization -----~%") + (print-code))) + t) + +(defun code-bytes (code) + (let ((length 0)) + (declare (type (unsigned-byte 16) length)) + ;; Pass 1: calculate label offsets and overall length. + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let* ((instruction (aref code i)) + (opcode (instruction-opcode instruction))) + (if (= opcode 202) ; LABEL + (let ((label (car (instruction-args instruction)))) + (set label length)) + (incf length (opcode-size opcode))))) + ;; Pass 2: replace labels with calculated offsets. + (let ((index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (when (branch-opcode-p (instruction-opcode instruction)) + (let* ((label (car (instruction-args instruction))) + (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index))) + (setf (instruction-args instruction) (s2 offset)))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (incf index (opcode-size (instruction-opcode instruction))))))) + ;; Expand instructions into bytes, skipping LABEL pseudo-instructions. + (let ((bytes (make-array length)) + (index 0)) + (declare (type (unsigned-byte 16) index)) + (dotimes (i (length code)) + (declare (type (unsigned-byte 16) i)) + (let ((instruction (aref code i))) + (unless (= (instruction-opcode instruction) 202) ; LABEL + (setf (svref bytes index) (instruction-opcode instruction)) + (incf index) + (dolist (byte (instruction-args instruction)) + (setf (svref bytes index) byte) + (incf index))))) + bytes))) + +(declaim (inline write-u1)) +(defun write-u1 (n stream) + (declare (optimize speed)) + (declare (type (unsigned-byte 8) n)) + (declare (type stream stream)) + (write-8-bits n stream)) + +(defknown write-u2 (t t) t) +(defun write-u2 (n stream) + (declare (optimize speed)) + (declare (type (unsigned-byte 16) n)) + (declare (type stream stream)) + (write-8-bits (logand (ash n -8) #xFF) stream) + (write-8-bits (logand n #xFF) stream)) + +(defknown write-u4 (integer stream) t) +(defun write-u4 (n stream) + (declare (optimize speed)) + (declare (type (unsigned-byte 32) n)) + (write-u2 (logand (ash n -16) #xFFFF) stream) + (write-u2 (logand n #xFFFF) stream)) + +(declaim (ftype (function (t t) t) write-s4)) +(defun write-s4 (n stream) + (declare (optimize speed)) + (cond ((minusp n) + (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream)) + (t + (write-u4 n stream)))) + +(declaim (ftype (function (t t t) t) write-ascii)) +(defun write-ascii (string length stream) + (declare (type string string)) + (declare (type (unsigned-byte 16) length)) + (declare (type stream stream)) + (write-u2 length stream) + (dotimes (i length) + (declare (type (unsigned-byte 16) i)) + (write-8-bits (char-code (char string i)) stream))) + +(declaim (ftype (function (t t) t) write-utf8)) +(defun write-utf8 (string stream) + (declare (optimize speed)) + (declare (type string string)) + (declare (type stream stream)) + (let ((length (length string)) + (must-convert nil)) + (declare (type fixnum length)) + (dotimes (i length) + (declare (type fixnum i)) + (unless (< 0 (char-code (char string i)) #x80) + (setf must-convert t) + (return))) + (if must-convert + (let ((octets (make-array (* length 2) + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) + (declare (type (vector (unsigned-byte 8)) octets)) + (dotimes (i length) + (declare (type fixnum i)) + (let* ((c (char string i)) + (n (char-code c))) + (cond ((zerop n) + (vector-push-extend #xC0 octets) + (vector-push-extend #x80 octets)) + ((< 0 n #x80) + (vector-push-extend n octets)) + (t + (let ((char-octets (char-to-utf8 c))) + (dotimes (j (length char-octets)) + (declare (type fixnum j)) + (vector-push-extend (svref char-octets j) octets))))))) + (write-u2 (length octets) stream) + (dotimes (i (length octets)) + (declare (type fixnum i)) + (write-8-bits (aref octets i) stream))) + (write-ascii string length stream)))) + +(defknown write-constant-pool-entry (t t) t) +(defun write-constant-pool-entry (entry stream) + (declare (optimize speed)) + (declare (type stream stream)) + (let ((tag (first entry))) + (declare (type (integer 1 12) tag)) + (write-u1 tag stream) + (case tag + (1 ; UTF8 + (write-utf8 (third entry) stream)) + ((3 4) ; int + (write-u4 (second entry) stream)) + ((5 6) ; long double + (write-u4 (second entry) stream) + (write-u4 (third entry) stream)) + ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType + (write-u2 (second entry) stream) + (write-u2 (third entry) stream)) + ((7 8) ; class string + (write-u2 (second entry) stream)) + (t + (error "write-constant-pool-entry unhandled tag ~D~%" tag))))) + +(defun write-constant-pool (stream) + (declare (optimize speed)) + (write-u2 *pool-count* stream) + (dolist (entry (reverse *pool*)) + (write-constant-pool-entry entry stream))) + +(defstruct (field (:constructor make-field (name descriptor))) + access-flags + name + descriptor + name-index + descriptor-index) + +(defstruct (java-method (:conc-name method-) (:constructor make-method)) + access-flags + name + descriptor + name-index + descriptor-index + max-stack + max-locals + code + handlers) + +(defun emit-constructor-lambda-name (lambda-name) + (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name))) + (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name)))) + (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name))))) + (emit-invokestatic +lisp-class+ "internInPackage" + (list +java-string+ +java-string+) +lisp-symbol+)) + (t + ;; No name. + (emit-push-nil)))) + +(defun emit-constructor-lambda-list (lambda-list) + (if lambda-list + (let* ((*print-level* nil) + (*print-length* nil) + (s (sys::%format nil "~S" lambda-list))) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+)) + (emit-push-nil))) + +(defun make-constructor (super lambda-name args) + (let* ((*compiler-debug* nil) + ;; We don't normally need to see debugging output for constructors. + (constructor (make-method :name "" + :descriptor "()V")) + (*code* ()) + (*handlers* nil)) + (setf (method-name-index constructor) (pool-name (method-name constructor))) + (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor))) + (setf (method-max-locals constructor) 1) + (aload 0) ;; this + (cond ((equal super +lisp-compiled-function-class+) + (emit-constructor-lambda-name lambda-name) + (emit-constructor-lambda-list args) + (emit-push-nil) ;; body + (emit 'aconst_null) ;; environment + (emit-invokespecial-init super + (list +lisp-object+ +lisp-object+ + +lisp-object+ +lisp-environment+))) + ((equal super +lisp-primitive-class+) + (emit-constructor-lambda-name lambda-name) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 2))) + ((equal super "org/armedbear/lisp/Primitive0R") + (emit-constructor-lambda-name lambda-name) + (push '&REST args) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 2))) + ((equal super "org/armedbear/lisp/Primitive1R") + (emit-constructor-lambda-name lambda-name) + (setf args (list (first args) '&REST (second args))) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 2))) + ((equal super "org/armedbear/lisp/Primitive2R") + (emit-constructor-lambda-name lambda-name) + (setf args (list (first args) (second args) '&REST (third args))) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 2))) + ((equal super +lisp-ctf-class+) + (emit-constructor-lambda-list args) + (emit-invokespecial-init super (lisp-object-arg-types 1))) + (t + (aver nil))) + (setf *code* (append *static-code* *code*)) + (emit 'return) + (finalize-code) + ;;(optimize-code) + (setf *code* (resolve-instructions *code*)) + (setf (method-max-stack constructor) (analyze-stack)) + (setf (method-code constructor) (code-bytes *code*)) + (setf (method-handlers constructor) (nreverse *handlers*)) + constructor)) + +(defun write-exception-table (method stream) + (let ((handlers (method-handlers method))) + (write-u2 (length handlers) stream) ; number of entries + (dolist (handler handlers) + (write-u2 (symbol-value (handler-from handler)) stream) + (write-u2 (symbol-value (handler-to handler)) stream) + (write-u2 (symbol-value (handler-code handler)) stream) + (write-u2 (handler-catch-type handler) stream)))) + +(defun write-source-file-attr (source-file stream) + (let* ((name-index (pool-name "SourceFile")) + (source-file-index (pool-name source-file))) + (write-u2 name-index stream) + ;; "The value of the attribute_length item of a SourceFile_attribute + ;; structure must be 2." + (write-u4 2 stream) + (write-u2 source-file-index stream))) + +(defvar *source-line-number* nil) + +(defun write-line-number-table (stream) + (let* ((name-index (pool-name "LineNumberTable"))) + (write-u2 name-index stream) + (write-u4 6 stream) ; "the length of the attribute, excluding the initial six bytes" + (write-u2 1 stream) ; number of entries + (write-u2 0 stream) ; start_pc + (write-u2 *source-line-number* stream))) + +(defun write-code-attr (method stream) + (declare (optimize speed)) + (declare (type stream stream)) + (let* ((name-index (pool-name "Code")) + (code (method-code method)) + (code-length (length code)) + (line-number-available-p (and (fixnump *source-line-number*) + (plusp *source-line-number*))) + (length (+ code-length 12 + (* (length (method-handlers method)) 8) + (if line-number-available-p 12 0))) + (max-stack (or (method-max-stack method) 20)) + (max-locals (or (method-max-locals method) 1))) + (write-u2 name-index stream) + (write-u4 length stream) + (write-u2 max-stack stream) + (write-u2 max-locals stream) + (write-u4 code-length stream) + (dotimes (i code-length) + (declare (type index i)) + (write-u1 (the (unsigned-byte 8) (svref code i)) stream)) + (write-exception-table method stream) + (cond (line-number-available-p + ; attributes count + (write-u2 1 stream) + (write-line-number-table stream)) + (t + ; attributes count + (write-u2 0 stream))))) + +(defun write-method (method stream) + (declare (optimize speed)) + (write-u2 (or (method-access-flags method) #x1) stream) ; access flags + (write-u2 (method-name-index method) stream) + (write-u2 (method-descriptor-index method) stream) + (write-u2 1 stream) ; attributes count + (write-code-attr method stream)) + +(defun write-field (field stream) + (declare (optimize speed)) + (write-u2 (or (field-access-flags field) #x1) stream) ; access flags + (write-u2 (field-name-index field) stream) + (write-u2 (field-descriptor-index field) stream) + (write-u2 0 stream)) ; attributes count + +(defknown declare-field (t t) t) +(defun declare-field (name descriptor) + (let ((field (make-field name descriptor))) + ;; final private static + (setf (field-access-flags field) (logior #x10 #x8 #x2)) + (setf (field-name-index field) (pool-name (field-name field))) + (setf (field-descriptor-index field) (pool-name (field-descriptor field))) + (push field *fields*))) + +(defknown sanitize (symbol) string) +(defun sanitize (symbol) + (declare (type symbol symbol)) + (declare (optimize speed)) + (let* ((input (symbol-name symbol)) + (output (make-array (length input) :fill-pointer 0 :element-type 'character))) + (dotimes (i (length input)) + (declare (type fixnum i)) + (let ((c (char-upcase (char input i)))) + (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z)) + (vector-push c output)) + ((<= #.(char-code #\0) (char-code c) #.(char-code #\9)) + (vector-push c output)) + ((eql c #\-) + (vector-push #\_ output))))) + (when (plusp (length output)) + output))) + +(defmacro declare-with-hashtable (declared-item hashtable hashtable-var + item-var &body body) + `(let* ((,hashtable-var ,hashtable) + (,item-var (gethash1 ,declared-item ,hashtable-var))) + (declare (type hash-table ,hashtable-var)) + (unless ,item-var + , at body) + ,item-var)) + + +(defknown declare-symbol (symbol) string) +(defun declare-symbol (symbol) + (declare (type symbol symbol)) + (declare-with-hashtable + symbol *declared-symbols* ht g + (cond ((null (symbol-package symbol)) + (setf g (if *compile-file-truename* + (declare-object-as-string symbol +lisp-symbol+ + +lisp-symbol-class+) + (declare-object symbol +lisp-symbol+ + +lisp-symbol-class+)))) + (t + (let ((*code* *static-code*) + (s (sanitize symbol))) + (setf g (symbol-name (gensym "SYM"))) + (when s + (setf g (concatenate 'string g "_" s))) + (declare-field g +lisp-symbol+) + (emit 'ldc (pool-string (symbol-name symbol))) + (emit 'ldc (pool-string (package-name (symbol-package symbol)))) + (emit-invokestatic +lisp-class+ "internInPackage" + (list +java-string+ +java-string+) +lisp-symbol+) + (emit 'putstatic *this-class* g +lisp-symbol+) + (setf *static-code* *code*) + (setf (gethash symbol ht) g)))))) + +(defknown declare-keyword (symbol) string) +(defun declare-keyword (symbol) + (declare (type symbol symbol)) + (declare-with-hashtable + symbol *declared-symbols* ht g + (let ((*code* *static-code*)) + (setf g (symbol-name (gensym "KEY"))) + (declare-field g +lisp-symbol+) + (emit 'ldc (pool-string (symbol-name symbol))) + (emit-invokestatic +lisp-class+ "internKeyword" + (list +java-string+) +lisp-symbol+) + (emit 'putstatic *this-class* g +lisp-symbol+) + (setf *static-code* *code*) + (setf (gethash symbol ht) g)))) + +(defknown declare-function (symbol) string) +(defun declare-function (symbol) + (declare (type symbol symbol)) + (declare-with-hashtable + symbol *declared-functions* ht f + (setf f (symbol-name (gensym "FUN"))) + (let ((s (sanitize symbol))) + (when s + (setf f (concatenate 'string f "_" s)))) + (let ((*code* *static-code*) + (g (gethash1 symbol (the hash-table *declared-symbols*)))) + (cond (g + (emit 'getstatic *this-class* g +lisp-symbol+)) + (t + (emit 'ldc (pool-string (symbol-name symbol))) + (emit 'ldc (pool-string (package-name (symbol-package symbol)))) + (emit-invokestatic +lisp-class+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+))) + (declare-field f +lisp-object+) + (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie" + nil +lisp-object+) + (emit 'putstatic *this-class* f +lisp-object+) + (setf *static-code* *code*) + (setf (gethash symbol ht) f)))) + +(defknown declare-setf-function (name) string) +(defun declare-setf-function (name) + (declare-with-hashtable + name *declared-functions* ht f + (let ((symbol (cadr name))) + (declare (type symbol symbol)) + (setf f (symbol-name (gensym))) + (let ((s (sanitize symbol))) + (when s + (setf f (concatenate 'string f "_SETF_" s)))) + (let ((*code* *static-code*) + (g (gethash1 symbol (the hash-table *declared-symbols*)))) + (cond (g + (emit 'getstatic *this-class* g +lisp-symbol+)) + (t + (emit 'ldc (pool-string (symbol-name symbol))) + (emit 'ldc (pool-string (package-name (symbol-package symbol)))) + (emit-invokestatic +lisp-class+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+))) + (declare-field f +lisp-object+) + (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" + nil +lisp-object+) + (emit 'putstatic *this-class* f +lisp-object+) + (setf *static-code* *code*) + (setf (gethash name ht) f))))) + + +(defknown declare-local-function (local-function) string) +(defun declare-local-function (local-function) + (declare-with-hashtable + local-function *declared-functions* ht g + (setf g (symbol-name (gensym "LFUN"))) + (let* ((pathname (class-file-pathname (local-function-class-file local-function))) + (*code* *static-code*)) + (declare-field g +lisp-object+) + (emit 'ldc (pool-string (file-namestring pathname))) + (emit-invokestatic +lisp-class+ "loadCompiledFunction" + (list +java-string+) +lisp-object+) + (emit 'putstatic *this-class* g +lisp-object+) + (setf *static-code* *code*) + (setf (gethash local-function ht) g)))) + +(defknown declare-fixnum (fixnum) string) +(defun declare-fixnum (n) + (declare (type fixnum n)) + (declare-with-hashtable + n *declared-integers* ht g + (let ((*code* *static-code*)) + (setf g (format nil "FIXNUM_~A~D" + (if (minusp n) "MINUS_" "") + (abs n))) + (declare-field g +lisp-integer+) + (cond ((<= 0 n 255) + (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) + (emit-push-constant-int n) + (emit 'aaload)) + (t + (emit-push-constant-int n) + (convert-representation :int nil))) + (emit 'putstatic *this-class* g +lisp-integer+) + (setf *static-code* *code*) + (setf (gethash n ht) g)))) + +(defknown declare-bignum (integer) string) +(defun declare-bignum (n) + (declare-with-hashtable + n *declared-integers* ht g + (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym)))) + (let ((*code* *static-code*)) + (declare-field g +lisp-integer+) + (emit 'new +lisp-bignum-class+) + (emit 'dup) + (cond ((<= most-negative-java-long n most-positive-java-long) +;; (setf g (format nil "BIGNUM_~A~D" +;; (if (minusp n) "MINUS_" "") +;; (abs n))) + (emit 'ldc2_w (pool-long n)) + (emit-invokespecial-init +lisp-bignum-class+ '("J"))) + (t + (let* ((*print-base* 10) + (s (with-output-to-string (stream) (dump-form n stream)))) + (emit 'ldc (pool-string s)) + (emit-push-constant-int 10) + (emit-invokespecial-init +lisp-bignum-class+ + (list +java-string+ "I"))))) + (emit 'putstatic *this-class* g +lisp-integer+) + (setf *static-code* *code*)) + (setf (gethash n ht) g))) + +(defknown declare-float (single-float) string) +(defun declare-float (s) + (declare-with-hashtable + s *declared-floats* ht g + (let* ((*code* *static-code*)) + (setf g (concatenate 'string "FLOAT_" (symbol-name (gensym)))) + (declare-field g +lisp-single-float+) + (emit 'new +lisp-single-float-class+) + (emit 'dup) + (emit 'ldc (pool-float s)) + (emit-invokespecial-init +lisp-single-float-class+ '("F")) + (emit 'putstatic *this-class* g +lisp-single-float+) + (setf *static-code* *code*)) + (setf (gethash s ht) g))) + +(defknown declare-double (double-float) string) +(defun declare-double (d) + (declare-with-hashtable + d *declared-doubles* ht g + (let ((*code* *static-code*)) + (setf g (concatenate 'string "DOUBLE_" (symbol-name (gensym)))) + (declare-field g +lisp-double-float+) + (emit 'new +lisp-double-float-class+) + (emit 'dup) + (emit 'ldc2_w (pool-double d)) + (emit-invokespecial-init +lisp-double-float-class+ '("D")) + (emit 'putstatic *this-class* g +lisp-double-float+) + (setf *static-code* *code*)) + (setf (gethash d ht) g))) + +(defknown declare-character (t) string) +(defun declare-character (c) + (let ((g (symbol-name (gensym "CHAR"))) + (n (char-code c)) + (*code* *static-code*)) + (declare-field g +lisp-character+) + (cond ((<= 0 n 255) + (emit 'getstatic +lisp-character-class+ "constants" +lisp-character-array+) + (emit-push-constant-int n) + (emit 'aaload)) + (t + (emit 'new +lisp-character-class+) + (emit 'dup) + (emit-push-constant-int n) + (emit-invokespecial-init +lisp-character-class+ '("C")))) + (emit 'putstatic *this-class* g +lisp-character+) + (setf *static-code* *code*) + g)) + +(defknown declare-object-as-string (t &optional t) string) +(defun declare-object-as-string (obj &optional (obj-ref +lisp-object+) + obj-class) + (let* ((g (symbol-name (gensym "OBJSTR"))) + (s (with-output-to-string (stream) (dump-form obj stream))) + (*code* *static-code*)) + (declare-field g obj-ref) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (when (and obj-class (string/= obj-class +lisp-object+)) + (emit 'checkcast obj-class)) + (emit 'putstatic *this-class* g obj-ref) + (setf *static-code* *code*) + g)) + +(defun declare-load-time-value (obj) + (let* ((g (symbol-name (gensym "LTV"))) + (s (with-output-to-string (stream) (dump-form obj stream))) + (*code* *static-code*)) + (declare-field g +lisp-object+) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit-invokestatic +lisp-class+ "loadTimeValue" + (lisp-object-arg-types 1) +lisp-object+) + (emit 'putstatic *this-class* g +lisp-object+) + (setf *static-code* *code*) + g)) + +(defknown declare-instance (t) t) +(defun declare-instance (obj) + (aver (not (null *compile-file-truename*))) + (aver (or (structure-object-p obj) (standard-object-p obj) + (java:java-object-p obj))) + (let* ((g (symbol-name (gensym "INSTANCE"))) + (s (with-output-to-string (stream) (dump-form obj stream))) + (*code* *static-code*)) + (declare-field g +lisp-object+) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit-invokestatic +lisp-class+ "loadTimeValue" + (lisp-object-arg-types 1) +lisp-object+) + (emit 'putstatic *this-class* g +lisp-object+) + (setf *static-code* *code*) + g)) + +(defun declare-package (obj) + (let* ((g (symbol-name (gensym "PKG"))) + (*print-level* nil) + (*print-length* nil) + (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj))) + (*code* *static-code*)) + (declare-field g +lisp-object+) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit 'putstatic *this-class* g +lisp-object+) + (setf *static-code* *code*) + g)) + +(declaim (ftype (function (t &optional t) string) declare-object)) +(defun declare-object (obj &optional (obj-ref +lisp-object+) + obj-class) + (let ((key (symbol-name (gensym "OBJ")))) + (remember key obj) + (let* ((g1 (declare-string key)) + (g2 (symbol-name (gensym "O2BJ")))) + (let* ( + (*code* *static-code*)) + (declare-field g2 obj-ref) + (emit 'getstatic *this-class* g1 +lisp-simple-string+) + (emit-invokestatic +lisp-class+ "recall" + (list +lisp-simple-string+) +lisp-object+) + (when (and obj-class (string/= obj-class +lisp-object-class+)) + (emit 'checkcast obj-class)) + (emit 'putstatic *this-class* g2 obj-ref) + (setf *static-code* *code*) + g2)))) + +(defun declare-lambda (obj) + (let* ((g (symbol-name (gensym "LAMBDA"))) + (*print-level* nil) + (*print-length* nil) + (s (format nil "~S" obj)) + (*code* *static-code*)) + (declare-field g +lisp-object+) + (emit 'ldc + (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+) + (emit-invokestatic +lisp-class+ "coerceToFunction" + (lisp-object-arg-types 1) +lisp-object+) + (emit 'putstatic *this-class* g +lisp-object+) + (setf *static-code* *code*) + g)) + +(defun declare-string (string) + (declare-with-hashtable + string *declared-strings* ht g + (let ((*code* *static-code*)) + (setf g (symbol-name (gensym "STR"))) + (declare-field g +lisp-simple-string+) + (emit 'new +lisp-simple-string-class+) + (emit 'dup) + (emit 'ldc (pool-string string)) + (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+)) + (emit 'putstatic *this-class* g +lisp-simple-string+) + (setf *static-code* *code*) + (setf (gethash string ht) g)))) + +(defknown compile-constant (t t t) t) +(defun compile-constant (form target representation) + (unless target + (return-from compile-constant)) + (ecase representation + (:int + (cond ((fixnump form) + (emit-push-constant-int form)) + ((integerp form) + (emit 'getstatic *this-class* (declare-bignum form) +lisp-integer+) + (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")) + (t + (sys::%format t "compile-constant int representation~%") + (assert nil))) + (emit-move-from-stack target representation) + (return-from compile-constant)) + (:long + (cond ((<= most-negative-java-long form most-positive-java-long) + (emit-push-constant-long form)) + ((integerp form) + (emit 'getstatic *this-class* (declare-bignum form) +lisp-integer+) + (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) + (t + (sys::%format t "compile-constant long representation~%") + (assert nil))) + (emit-move-from-stack target representation) + (return-from compile-constant)) + (:char + (cond ((characterp form) + (emit-push-constant-int (char-code form)) + (emit-move-from-stack target representation) + (return-from compile-constant)) + (t + (sys::%format t "compile-constant :char representation~%") + (assert nil)))) + (:boolean + (emit (if form 'iconst_1 'iconst_0)) + (emit-move-from-stack target representation) + (return-from compile-constant)) + (:float + (cond ((integerp form) + (emit-push-constant-float (coerce form 'single-float))) + ((typep form 'single-float) + (emit-push-constant-float form)) + ((typep form 'double-float) + (emit-push-constant-double form) + (emit 'd2f)) + (t + (sys::%format t "compile-constant :float representation~%") + (assert nil))) + (emit-move-from-stack target representation) + (return-from compile-constant)) + (:double + (cond ((or (integerp form) + (typep form 'single-float)) + (emit-push-constant-double (coerce form 'double-float))) + ((typep form 'double-float) + (emit-push-constant-double form)) + (t + (sys::%format t "compile-constant :double representation~%") + (assert nil))) + (emit-move-from-stack target representation) + (return-from compile-constant)) + ((NIL))) + (cond ((fixnump form) + (let ((translation (case form + (0 "ZERO") + (1 "ONE") + (2 "TWO") + (3 "THREE") + (-1 "MINUS_ONE")))) + (if translation + (emit 'getstatic +lisp-fixnum-class+ translation +lisp-fixnum+) + (emit 'getstatic *this-class* (declare-fixnum form) + +lisp-integer+)))) + ((integerp form) + ;; A bignum. + (emit 'getstatic *this-class* (declare-bignum form) +lisp-integer+)) + ((typep form 'single-float) + (emit 'getstatic *this-class* + (declare-float form) +lisp-single-float+)) + ((typep form 'double-float) + (emit 'getstatic *this-class* + (declare-double form) +lisp-double-float+)) + ((numberp form) + ;; A number, but not a fixnum. + (emit 'getstatic *this-class* + (declare-object-as-string form) +lisp-object+)) + ((stringp form) + (if *compile-file-truename* + (emit 'getstatic *this-class* + (declare-string form) +lisp-simple-string+) + (emit 'getstatic *this-class* + (declare-object form) +lisp-object+))) + ((vectorp form) + (if *compile-file-truename* + (emit 'getstatic *this-class* + (declare-object-as-string form) +lisp-object+) + (emit 'getstatic *this-class* + (declare-object form) +lisp-object+))) + ((characterp form) + (emit 'getstatic *this-class* + (declare-character form) +lisp-character+)) + ((or (hash-table-p form) (typep form 'generic-function)) + (emit 'getstatic *this-class* + (declare-object form) +lisp-object+)) + ((pathnamep form) + (let ((g (if *compile-file-truename* + (declare-object-as-string form) + (declare-object form)))) + (emit 'getstatic *this-class* g +lisp-object+))) + ((packagep form) + (let ((g (if *compile-file-truename* + (declare-package form) + (declare-object form)))) + (emit 'getstatic *this-class* g +lisp-object+))) + ((or (structure-object-p form) + (standard-object-p form) + (java:java-object-p form)) + (let ((g (if *compile-file-truename* + (declare-instance form) + (declare-object form)))) + (emit 'getstatic *this-class* g +lisp-object+))) + (t + (if *compile-file-truename* + (error "COMPILE-CONSTANT unhandled case ~S" form) + (emit 'getstatic *this-class* + (declare-object form) +lisp-object+)))) + (emit-move-from-stack target representation)) + +(defparameter *unary-operators* nil) + +(defun initialize-unary-operators () + (let ((ht (make-hash-table :test 'eq))) + (dolist (pair '((ABS "ABS") + (CADDR "caddr") + (CADR "cadr") + (CDDR "cddr") + (CDR "cdr") + (CLASS-OF "classOf") + (COMPLEXP "COMPLEXP") + (DENOMINATOR "DENOMINATOR") + (FIRST "car") + (LENGTH "LENGTH") + (NREVERSE "nreverse") + (NUMERATOR "NUMERATOR") + (REST "cdr") + (REVERSE "reverse") + (SECOND "cadr") + (SIMPLE-STRING-P "SIMPLE_STRING_P") + (STRING "STRING") + (THIRD "caddr"))) + (setf (gethash (%car pair) ht) (%cadr pair))) + (setf *unary-operators* ht))) + +(initialize-unary-operators) + +(defknown install-p2-handler * t) +(defun install-p2-handler (symbol &optional handler) + (declare (type symbol symbol)) + (let ((handler (or handler + (find-symbol (concatenate 'string "COMPILE-" (symbol-name symbol)) 'jvm)))) + (unless (and handler (fboundp handler)) + (error "Handler not found: ~S" handler)) + (setf (get symbol 'p2-handler) handler))) + +(defparameter *predicates* (make-hash-table :test 'eq)) + +(defun define-predicate (name boxed-method-name unboxed-method-name) + (setf (gethash name *predicates*) (cons boxed-method-name unboxed-method-name)) + (install-p2-handler name 'p2-predicate)) + +(defmacro define-inlined-function (name params preamble-and-test &body body) + (let* ((test (second preamble-and-test)) + (preamble (and test (first preamble-and-test))) + (test (or test (first preamble-and-test)))) + `(defun ,name ,params + ,preamble + (unless ,test + (compile-function-call , at params) + (return-from ,name)) + , at body))) + +(defknown p2-predicate (t t t) t) +(define-inlined-function p2-predicate (form target representation) + ((= (length form) 2)) + (let* ((op (car form)) + (info (gethash op *predicates*)) + (boxed-method-name (car info)) + (unboxed-method-name (cdr info))) + (cond ((and boxed-method-name unboxed-method-name) + (let ((arg (cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (ecase representation + (:boolean + (emit-invokevirtual +lisp-object-class+ + unboxed-method-name + nil "Z")) + ((NIL) + (emit-invokevirtual +lisp-object-class+ + boxed-method-name + nil +lisp-object+))) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation))))) + +(define-predicate 'constantp "CONSTANTP" "constantp") +(define-predicate 'endp "ENDP" "endp") +(define-predicate 'evenp "EVENP" "evenp") +(define-predicate 'floatp "FLOATP" "floatp") +(define-predicate 'integerp "INTEGERP" "integerp") +(define-predicate 'listp "LISTP" "listp") +(define-predicate 'minusp "MINUSP" "minusp") +(define-predicate 'numberp "NUMBERP" "numberp") +(define-predicate 'oddp "ODDP" "oddp") +(define-predicate 'plusp "PLUSP" "plusp") +(define-predicate 'rationalp "RATIONALP" "rationalp") +(define-predicate 'realp "REALP" "realp") + +(declaim (ftype (function (t t t t) t) compile-function-call-1)) +(defun compile-function-call-1 (op args target representation) + (let ((arg (first args))) + (when (eq op '1+) + (p2-plus (list '+ arg 1) target representation) + (return-from compile-function-call-1 t)) + (when (eq op '1-) + (p2-minus (list '- arg 1) target representation) + (return-from compile-function-call-1 t)) + (let ((s (gethash1 op (the hash-table *unary-operators*)))) + (cond (s + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invoke-method s target representation) + t) + (t + nil))))) + +(defparameter *binary-operators* nil) + +(defun initialize-binary-operators () + (let ((ht (make-hash-table :test 'eq))) + (dolist (pair '((EQL "EQL") + (EQUAL "EQUAL") + (+ "add") + (- "subtract") + (/ "divideBy") + (* "multiplyBy") + (< "IS_LT") + (<= "IS_LE") + (> "IS_GT") + (>= "IS_GE") + ( = "IS_E") + (/= "IS_NE") + (ASH "ash") + (AREF "AREF") + (SIMPLE-TYPEP "typep") + (RPLACA "RPLACA") + (RPLACD "RPLACD"))) + (setf (gethash (%car pair) ht) (%cadr pair))) + (setf *binary-operators* ht))) + +(initialize-binary-operators) + +(defun compile-binary-operation (op args target representation) + (let ((arg1 (car args)) + (arg2 (cadr args))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ op + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + +(declaim (ftype (function (t t t t) t) compile-function-call-2)) +(defun compile-function-call-2 (op args target representation) + (let ((translation (gethash1 op (the hash-table *binary-operators*)))) + (when translation + (compile-binary-operation translation args target representation)))) + +(declaim (ftype (function (t) t) fixnum-or-unboxed-variable-p)) +(defun fixnum-or-unboxed-variable-p (arg) + (or (fixnump arg) + (unboxed-fixnum-variable arg))) + +(declaim (ftype (function (t) t) emit-push-int)) +(defun emit-push-int (arg) + (if (fixnump arg) + (emit-push-constant-int arg) + (let ((variable (unboxed-fixnum-variable arg))) + (if variable + (emit 'iload (variable-register variable)) + (progn + (sys::%format t "emit-push-int~%") + (aver nil)))))) + +(declaim (ftype (function (t) t) emit-push-long)) +(defun emit-push-long (arg) + (cond ((eql arg 0) + (emit 'lconst_0)) + ((eql arg 1) + (emit 'lconst_1)) + ((fixnump arg) + (emit-push-constant-int arg) + (emit 'i2l)) + (t + (let ((variable (unboxed-fixnum-variable arg))) + (aver (not (null variable))) + (aver (not (null (variable-register variable)))) + (emit 'iload (variable-register variable)) + (emit 'i2l))))) + +(defknown p2-eq/neq (t t t) t) +(define-inlined-function p2-eq/neq (form target representation) + ((aver (or (null representation) (eq representation :boolean))) + (check-arg-count form 2)) + (let* ((op (%car form)) + (args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2)) + (emit-move-from-stack target representation)) + t) + +(defun emit-ifne-for-eql (representation instruction-type) + (emit-invokevirtual +lisp-object-class+ "eql" instruction-type "Z") + (convert-representation :boolean representation)) + +(defknown p2-eql (t t t) t) +(define-inlined-function p2-eql (form target representation) + ((aver (or (null representation) (eq representation :boolean))) + (check-arg-count form 2)) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (fixnum-type-p type1) + (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (let ((label1 (gensym)) + (label2 (gensym))) + (emit 'if_icmpeq label1) + (emit-push-false representation) + (emit 'goto label2) + (label label1) + (emit-push-true representation) + (label label2))) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-ifne-for-eql representation '("I"))) + ((fixnum-type-p type1) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + (emit 'swap) + (emit-ifne-for-eql representation '("I"))) + ((eq type2 'CHARACTER) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :char) + (emit-ifne-for-eql representation '("C"))) + ((eq type1 'CHARACTER) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack nil) + (emit 'swap) + (emit-ifne-for-eql representation '("C"))) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (ecase representation + (:boolean + (emit-invokevirtual +lisp-object-class+ "eql" + (lisp-object-arg-types 1) "Z")) + ((NIL) + (emit-invokevirtual +lisp-object-class+ "EQL" + (lisp-object-arg-types 1) +lisp-object+))))) + (emit-move-from-stack target representation))) + +(defknown p2-memq (t t t) t) +(define-inlined-function p2-memq (form target representation) + ((check-arg-count form 2)) + (cond ((eq representation :boolean) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args))) + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil) + (emit-invokestatic +lisp-class+ "memq" + (lisp-object-arg-types 2) "Z") + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +(defknown p2-memql (t t t) t) +(define-inlined-function p2-memql (form target representation) + ((check-arg-count form 2)) + (cond ((eq representation :boolean) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (type1 (derive-compiler-type arg1))) + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil) + (cond ((eq type1 'SYMBOL) ; FIXME + (emit-invokestatic +lisp-class+ "memq" + (lisp-object-arg-types 2) "Z")) + (t + (emit-invokestatic +lisp-class+ "memql" + (lisp-object-arg-types 2) "Z"))) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +(defun p2-gensym (form target representation) + (cond ((and (null representation) (null (cdr form))) + (emit-push-current-thread) + (emit-invokestatic +lisp-class+ "gensym" + (list +lisp-thread+) +lisp-symbol+) + (emit-move-from-stack target)) + (t + (compile-function-call form target representation)))) + +;; get symbol indicator &optional default => value +(defun p2-get (form target representation) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (arg3 (third args))) + (case (length args) + ((2 3) + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil) + (cond ((null arg3) + (maybe-emit-clear-values arg1 arg2)) + (t + (compile-form arg3 'stack nil) + (maybe-emit-clear-values arg1 arg2 arg3))) + (emit-invokestatic +lisp-class+ "get" + (lisp-object-arg-types (if arg3 3 2)) + +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compiler-warn "Wrong number of arguments for ~A (expected 2 or 3, but received ~D)." + 'GET (length args)) + (compile-function-call form target representation))))) + +;; getf plist indicator &optional default => value +(defun p2-getf (form target representation) + (let* ((args (cdr form)) + (arg-count (length args))) + (case arg-count + ((2 3) + (let ((arg1 (first args)) + (arg2 (second args)) + (arg3 (third args))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil + arg3 'stack nil) + (emit-invokestatic +lisp-class+ "getf" + (lisp-object-arg-types 3) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation))))) + +;; gethash key hash-table &optional default => value, present-p +(defun p2-gethash (form target representation) + (cond ((and (eq (car form) 'GETHASH1) + (= (length form) 3) + (eq (derive-type (%caddr form)) 'HASH-TABLE)) + (let ((key-form (%cadr form)) + (ht-form (%caddr form))) + (compile-form ht-form 'stack nil) + (emit 'checkcast +lisp-hash-table-class+) + (compile-form key-form 'stack nil) + (maybe-emit-clear-values ht-form key-form) + (emit-invokevirtual +lisp-hash-table-class+ "gethash1" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +;; puthash key hash-table new-value &optional default => value +(defun p2-puthash (form target representation) + (cond ((and (= (length form) 4) + (eq (derive-type (%caddr form)) 'HASH-TABLE)) + (let ((key-form (%cadr form)) + (ht-form (%caddr form)) + (value-form (fourth form))) + (compile-form ht-form 'stack nil) + (emit 'checkcast +lisp-hash-table-class+) + (compile-form key-form 'stack nil) + (compile-form value-form 'stack nil) + (maybe-emit-clear-values ht-form key-form value-form) + (cond (target + (emit-invokevirtual +lisp-hash-table-class+ "puthash" + (lisp-object-arg-types 2) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (emit-invokevirtual +lisp-hash-table-class+ "put" + (lisp-object-arg-types 2) nil))))) + (t + (compile-function-call form target representation)))) + +(defvar *functions-defined-in-current-file* nil) + +(defun inline-ok (name) + (declare (optimize speed)) + (cond ((notinline-p name) + nil) + ((built-in-function-p name) + t) + ((memq name *functions-defined-in-current-file*) + t) + (t + nil))) + +(defknown process-args (t) t) +(defun process-args (args) + "Compiles forms specified as function call arguments. + +The results are either accumulated on the stack or in an array +in order to call the relevant `execute' form. The function call +itself is *not* compiled by this function." + (when args + (let ((numargs (length args))) + (let ((must-clear-values nil)) + (declare (type boolean must-clear-values)) + (cond ((<= numargs call-registers-limit) + (dolist (arg args) + (compile-form arg 'stack nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t))))) + (t + (emit-push-constant-int numargs) + (emit 'anewarray +lisp-object-class+) + (let ((i 0)) + (dolist (arg args) + (emit 'dup) + (emit-push-constant-int i) + (compile-form arg 'stack nil) + (emit 'aastore) ; store value in array + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t))) + (incf i))))) + (when must-clear-values + (emit-clear-values))))) + t) + +(defknown lisp-object-arg-types (fixnum) list) +(let ((table (make-array 10))) + (dotimes (i 10) + (declare (type fixnum i)) + (setf (aref table i) (make-list i :initial-element +lisp-object+))) + (defun lisp-object-arg-types (n) + (declare (type fixnum n)) + (declare (optimize speed (safety 0))) + (if (< n 10) + (aref table n) + (make-list n :initial-element +lisp-object+)))) + +(declaim (ftype (function (t) t) emit-call-execute)) +(defun emit-call-execute (numargs) + (let ((arg-types (if (<= numargs call-registers-limit) + (lisp-object-arg-types numargs) + (list +lisp-object-array+))) + (return-type +lisp-object+)) + (emit-invokevirtual +lisp-object-class+ "execute" arg-types return-type))) + +(declaim (ftype (function (t) t) emit-call-thread-execute)) +(defun emit-call-thread-execute (numargs) + (let ((arg-types (if (<= numargs call-registers-limit) + (lisp-object-arg-types (1+ numargs)) + (list +lisp-object+ +lisp-object-array+))) + (return-type +lisp-object+)) + (emit-invokevirtual +lisp-thread-class+ "execute" arg-types return-type))) + +(defknown compile-function-call (t t t) t) +(defun compile-function-call (form target representation) + (let ((op (car form)) + (args (cdr form))) + (declare (type symbol op)) + (when (find-local-function op) + (return-from compile-function-call + (compile-local-function-call form target representation))) + (when (and (boundp '*defined-functions*) (boundp '*undefined-functions*)) + (unless (or (fboundp op) + (eq op (compiland-name *current-compiland*)) + (memq op *defined-functions*) + (proclaimed-ftype op)) + (pushnew op *undefined-functions*))) + (let ((numargs (length args))) + (case numargs + (1 + (when (compile-function-call-1 op args target representation) + (return-from compile-function-call))) + (2 + (when (compile-function-call-2 op args target representation) + (return-from compile-function-call)))) + (let ((explain *explain*)) + (when (and explain (memq :calls explain)) + (let ((package (symbol-package op))) + (when (or (eq package +cl-package+) (eq package (find-package "SYSTEM"))) + (format t "; full call to ~S~%" op))))) + (when (or (<= *speed* *debug*) *require-stack-frame*) + (emit-push-current-thread)) + (cond ((eq op (compiland-name *current-compiland*)) ; recursive call + (if (notinline-p op) + (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+) + (aload 0))) + ((null (symbol-package op)) + (let ((g (if *compile-file-truename* + (declare-object-as-string op) + (declare-object op)))) + (emit 'getstatic *this-class* g +lisp-object+))) + (t + (let ((name (lookup-known-symbol op))) + (if name + (emit 'getstatic +lisp-symbol-class+ name +lisp-symbol+) + (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+))))) + (process-args args) + (if (or (<= *speed* *debug*) *require-stack-frame*) + (emit-call-thread-execute numargs) + (emit-call-execute numargs)) + (fix-boxing representation (derive-compiler-type form)) + (emit-move-from-stack target representation)))) + +(defun compile-call (args) + "Compiles a function call. + +Depending on the `*speed*' and `*debug*' settings, a stack frame +is registered (or not)." + (let ((numargs (length args))) + (cond ((> *speed* *debug*) + (process-args args) + (emit-call-execute numargs)) + (t + (emit-push-current-thread) + (emit 'swap) ; Stack: thread function + (process-args args) + (emit-call-thread-execute numargs))))) + +(define-source-transform funcall (&whole form fun &rest args) + (cond ((> *debug* *speed*) + form) + ((and (consp fun) + (eq (%car fun) 'FUNCTION) + (symbolp (cadr fun))) + `(,(cadr fun) , at args)) + ((and (consp fun) + (eq (%car fun) 'QUOTE)) + (let ((sym (cadr fun))) + (if (and (symbolp sym) + (eq (symbol-package (truly-the symbol sym)) +cl-package+) + (not (special-operator-p sym)) + (not (macro-function sym))) + `(,(cadr fun) , at args) + form))) + (t + form))) + +(define-source-transform mapcar (&whole form function &rest lists) + (cond ((or (> *debug* *speed*) + (> *space* *speed*)) + form) + ((= (length lists) 1) + (let ((list (gensym)) + (result (gensym)) + (temp (gensym))) + `(let* ((,list ,(car lists)) + (,result (list nil)) + (,temp ,result)) + (loop + (when (null ,list) + (return (cdr ,result))) + (rplacd ,temp (setf ,temp (list (funcall ,function (car ,list))))) + (setf ,list (cdr ,list)))))) + (t + form))) + +(define-source-transform mapc (&whole form function &rest lists) + (cond ((or (> *debug* *speed*) + (> *space* *speed*)) + form) + ((= (length lists) 1) + (let ((list (gensym)) + (result (gensym))) + `(let* ((,list ,(car lists)) + (,result ,list)) + (loop + (when (null ,list) + (return ,result)) + (funcall ,function (car ,list)) + (setf ,list (%cdr ,list)))))) + (t + form))) + +;; (define-source-transform min (&whole form &rest args) +;; (cond ((= (length args) 2) +;; (let* ((arg1 (%car args)) +;; (arg2 (%cadr args)) +;; (sym1 (gensym)) +;; (sym2 (gensym))) +;; `(let ((,sym1 ,arg1) +;; (,sym2 ,arg2)) +;; (if (<= ,sym1 ,sym2) ,sym1 ,sym2)))) +;; (t +;; form))) + +;; (define-source-transform max (&whole form &rest args) +;; (cond ((= (length args) 2) +;; (let* ((arg1 (%car args)) +;; (arg2 (%cadr args)) +;; (sym1 (gensym)) +;; (sym2 (gensym))) +;; `(let ((,sym1 ,arg1) +;; (,sym2 ,arg2)) +;; (if (>= ,sym1 ,sym2) ,sym1 ,sym2)))) +;; (t +;; form))) + +(defknown p2-funcall (t t t) t) +(defun p2-funcall (form target representation) + (unless (> (length form) 1) + (compiler-warn "Wrong number of arguments for ~A." (car form)) + (compile-function-call form target representation) + (return-from p2-funcall)) + (when (> *debug* *speed*) + (return-from p2-funcall (compile-function-call form target representation))) + (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) + (compile-call (cddr form)) +;; (case representation +;; (:int (emit-unbox-fixnum)) +;; (:char (emit-unbox-character))) + (fix-boxing representation nil) + (emit-move-from-stack target)) + +(defun save-variables (variables) + (let ((saved-vars '())) + (dolist (variable variables) + (when (variable-closure-index variable) + (let ((register (allocate-register))) + (aload (compiland-closure-register *current-compiland*)) + (emit-push-constant-int (variable-closure-index variable)) + (emit 'aaload) + (astore register) + (push (cons variable register) saved-vars)))) + saved-vars)) + +(defun restore-variables (saved-vars) + (dolist (saved-var saved-vars) + (let ((variable (car saved-var)) + (register (cdr saved-var))) + (aload (compiland-closure-register *current-compiland*)) + (emit-push-constant-int (variable-closure-index variable)) + (aload register) + (emit 'aastore)))) + +(defknown compile-local-function-call (t t t) t) +(defun compile-local-function-call (form target representation) + "Compiles a call to a function marked as `*child-p*'; a local function. + +Functions this applies to can be FLET, LABELS, LAMBDA or NAMED-LAMBDA. +Note: DEFUN implies a named lambda." + (let* ((compiland *current-compiland*) + (op (car form)) + (args (cdr form)) + (local-function (find-local-function op)) + (*register* *register*) + (saved-vars '())) + (cond ((local-function-variable local-function) + ;; LABELS + (dformat t "compile-local-function-call LABELS case variable = ~S~%" + (variable-name (local-function-variable local-function))) + (unless (null (compiland-parent compiland)) + (setf saved-vars + (save-variables (intersection + (compiland-arg-vars (local-function-compiland local-function)) + *visible-variables*)))) +;; (emit 'var-ref (local-function-variable local-function) 'stack) + (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) + (t + (dformat t "compile-local-function-call default case~%") + (let* ((g (if *compile-file-truename* + (declare-local-function local-function) + (declare-object (local-function-function local-function))))) + (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function + (when *closure-variables* + (emit 'checkcast +lisp-ctf-class+) + (aload (compiland-closure-register compiland)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))))) + (process-args args) + (emit-call-execute (length args)) + (fix-boxing representation nil) + (emit-move-from-stack target representation) + (when saved-vars + (restore-variables saved-vars))) + t) + + +;; < <= > >= = +(defvar comparison-ops '(< <= > >= =)) +(defvar comparison-ins + '((:int . #(if_icmpge if_icmpgt if_icmple if_icmplt if_icmpne)) + (:long . #((lcmp ifge) (lcmp ifgt) (lcmp ifle) + (lcmp iflt) (lcmp ifne))) + (:float . #((fcmpg ifge) (fcmpg ifgt) (fcmpl ifle) + (fcmpl iflt) (fcmpl ifne))) + (:double . #((dcmpg ifge) (dcmpg ifgt) (dcmpl ifle) + (dcmpl iflt) (dcmpl ifne)))) + "Instructions to be generated upon each comparison operation, +given a specific common representation.") + + +(defun emit-numeric-comparison (op representation false-LABEL) + (let* ((pos (position op comparison-ops)) + (ops-table (cdr (assoc representation comparison-ins))) + (ops (aref ops-table pos))) + (if (listp ops) + (progn + (emit (car ops)) + (emit (cadr ops) false-LABEL)) + (emit ops false-LABEL)))) + +;; Note that /= is not transitive, so we don't handle it here. +(defknown p2-numeric-comparison (t t t) t) +(defun p2-numeric-comparison (form target representation) + (aver (or (null representation) (eq representation :boolean))) + (let ((op (car form)) + (args (%cdr form))) + (case (length args) + (2 + (let* ((arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2)) + (common-rep (common-representation (type-representation type1) + (type-representation type2)))) + (cond ((and (integerp arg1) (integerp arg2)) + (let ((result (funcall op arg1 arg2))) + (if result + (emit-push-true representation) + (emit-push-false representation))) + (emit-move-from-stack target representation) + (return-from p2-numeric-comparison)) + (common-rep + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (compile-forms-and-maybe-emit-clear-values + arg1 'stack common-rep + arg2 'stack common-rep) + (emit-numeric-comparison op common-rep LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2)) + (emit-move-from-stack target representation) + (return-from p2-numeric-comparison)) + ((fixnump arg2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit-push-constant-int arg2) + (emit-invokevirtual +lisp-object-class+ + (case op + (< "isLessThan") + (<= "isLessThanOrEqualTo") + (> "isGreaterThan") + (>= "isGreaterThanOrEqualTo") + (= "isEqualTo")) + '("I") + "Z") + ;; Java boolean on stack here + (convert-representation :boolean representation) + (emit-move-from-stack target representation) + (return-from p2-numeric-comparison))))) + (3 + (when (dolist (arg args t) + (unless (fixnum-type-p (derive-compiler-type arg)) + (return nil))) + (let* ((arg1 (%car args)) + (arg2 (%cadr args)) + (arg3 (%caddr args)) + (test (case op + (< 'if_icmpge) + (<= 'if_icmpgt) + (> 'if_icmple) + (>= 'if_icmplt) + (= 'if_icmpne))) + (LABEL1 (gensym)) + (LABEL2 (gensym)) + ;; If we do both tests, we need to use the arg2 value twice, + ;; so we store that value in a temporary register. + (*register* *register*) + (arg2-register + (unless (and (or (node-constant-p arg2) + (var-ref-p arg2)) + (node-constant-p arg3)) + (allocate-register))) + (arg3-register + (unless (node-constant-p arg3) (allocate-register)))) + (compile-form arg1 'stack :int) + (compile-form arg2 'stack :int) + (when arg2-register + (emit 'dup) + (emit 'istore arg2-register)) + (cond (arg3-register + (compile-form arg3 'stack :int) + (emit 'istore arg3-register) + (maybe-emit-clear-values arg1 arg2 arg3)) + (t + (maybe-emit-clear-values arg1 arg2))) + ;; First test. + (emit test LABEL1) + ;; Second test. + (cond (arg2-register + (emit 'iload arg2-register)) + (t + (compile-form arg2 'stack :int))) + (cond (arg3-register + (emit 'iload arg3-register)) + (t + (compile-form arg3 'stack :int))) + (emit test LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2) + (emit-move-from-stack target representation) + (return-from p2-numeric-comparison)))))) + ;; Still here? + (compile-function-call form target representation)) + +(defparameter *p2-test-handlers* nil) + +(defun p2-test-handler (op) + (gethash1 op (the hash-table *p2-test-handlers*))) + +(defun initialize-p2-test-handlers () + (let ((ht (make-hash-table :test 'eq))) + (dolist (pair '( +;; (CHAR= p2-test-char=) + (/= p2-test-/=) + (< p2-test-numeric-comparison) + (<= p2-test-numeric-comparison) + (= p2-test-numeric-comparison) + (> p2-test-numeric-comparison) + (>= p2-test-numeric-comparison) + (AND p2-test-and) + (ATOM p2-test-atom) + (BIT-VECTOR-P p2-test-bit-vector-p) + (CHAR= p2-test-char=) + (CHARACTERP p2-test-characterp) + (CLASSP p2-test-classp) + (CONSP p2-test-consp) + (CONSTANTP p2-test-constantp) + (ENDP p2-test-endp) + (EQ p2-test-eq) + (NEQ p2-test-neq) + (EQL p2-test-eql) + (EQUAL p2-test-equality) + (EQUALP p2-test-equality) + (EVENP p2-test-evenp) + (FIXNUMP p2-test-fixnump) + (FLOATP p2-test-floatp) + (INTEGERP p2-test-integerp) + (LISTP p2-test-listp) + (MEMQ p2-test-memq) + (MEMQL p2-test-memql) + (MINUSP p2-test-minusp) + (NOT p2-test-not/null) + (NULL p2-test-not/null) + (NUMBERP p2-test-numberp) + (PACKAGEP p2-test-packagep) + (ODDP p2-test-oddp) + (PLUSP p2-test-plusp) + (RATIONALP p2-test-rationalp) + (REALP p2-test-realp) + (SIMPLE-TYPEP p2-test-simple-typep) + (SIMPLE-VECTOR-P p2-test-simple-vector-p) + (SPECIAL-OPERATOR-P p2-test-special-operator-p) + (SPECIAL-VARIABLE-P p2-test-special-variable-p) + (STRINGP p2-test-stringp) + (SYMBOLP p2-test-symbolp) + (VECTORP p2-test-vectorp) + (ZEROP p2-test-zerop) + )) + (setf (gethash (%car pair) ht) (%cadr pair))) + (setf *p2-test-handlers* ht))) + +(initialize-p2-test-handlers) + +(defknown p2-test-predicate (t t) t) +(defun p2-test-predicate (form java-predicate) + (when (check-arg-count form 1) + (let ((arg (%cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invokevirtual +lisp-object-class+ java-predicate nil "Z") + 'ifeq))) + +(declaim (ftype (function (t t) t) p2-test-instanceof-predicate)) +(defun p2-test-instanceof-predicate (form java-class) + (when (check-arg-count form 1) + (let ((arg (%cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit 'instanceof java-class) + 'ifeq))) + +(defun p2-test-bit-vector-p (form) + (p2-test-instanceof-predicate form +lisp-abstract-bit-vector-class+)) + +(defun p2-test-characterp (form) + (p2-test-instanceof-predicate form +lisp-character-class+)) + +;; constantp form &optional environment => generalized-boolean +(defun p2-test-constantp (form) + (when (= (length form) 2) + (let ((arg (%cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invokevirtual +lisp-object-class+ "constantp" nil "Z") + 'ifeq))) + +(defun p2-test-endp (form) + (p2-test-predicate form "endp")) + +(defmacro p2-test-integer-predicate (form predicate &body instructions) + (let ((tmpform (gensym))) + `(let ((,tmpform ,form)) + (when (check-arg-count ,tmpform 1) + (let ((arg (%cadr ,tmpform))) + (cond ((fixnum-type-p (derive-compiler-type arg)) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + , at instructions) + (t + (p2-test-predicate ,tmpform ,predicate)))))))) + +(defun p2-test-evenp (form) + (p2-test-integer-predicate form "evenp" + (emit-push-constant-int 1) + (emit 'iand) + 'ifne)) + +(defun p2-test-oddp (form) + (p2-test-integer-predicate form "oddp" + (emit-push-constant-int 1) + (emit 'iand) + 'ifeq)) + +(defun p2-test-floatp (form) + (p2-test-predicate form "floatp")) + +(defun p2-test-integerp (form) + (p2-test-predicate form "integerp")) + +(defun p2-test-listp (form) + (when (check-arg-count form 1) + (let* ((arg (%cadr form)) + (arg-type (derive-compiler-type arg))) + (cond ((memq arg-type '(CONS LIST NULL)) + (compile-forms-and-maybe-emit-clear-values arg nil nil) + :consequent) + ((neq arg-type t) + (compile-forms-and-maybe-emit-clear-values arg nil nil) + :alternate) + (t + (p2-test-predicate form "listp")))))) + +(defun p2-test-minusp (form) + (p2-test-integer-predicate form "minusp" 'ifge)) + +(defun p2-test-plusp (form) + (p2-test-integer-predicate form "plusp" 'ifle)) + +(defun p2-test-zerop (form) + (p2-test-integer-predicate form "zerop" 'ifne)) + +(defun p2-test-numberp (form) + (p2-test-predicate form "numberp")) + +(defun p2-test-packagep (form) + (p2-test-instanceof-predicate form +lisp-package-class+)) + +(defun p2-test-rationalp (form) + (p2-test-predicate form "rationalp")) + +(defun p2-test-realp (form) + (p2-test-predicate form "realp")) + +(defun p2-test-special-operator-p (form) + (p2-test-predicate form "isSpecialOperator")) + +(defun p2-test-special-variable-p (form) + (p2-test-predicate form "isSpecialVariable")) + +(defun p2-test-classp (form) + (p2-test-instanceof-predicate form +lisp-class-class+)) + +(defun p2-test-symbolp (form) + (p2-test-instanceof-predicate form +lisp-symbol-class+)) + +(defun p2-test-consp (form) + (p2-test-instanceof-predicate form +lisp-cons-class+)) + +(defun p2-test-atom (form) + (p2-test-instanceof-predicate form +lisp-cons-class+) + 'ifne) + +(defun p2-test-fixnump (form) + (p2-test-instanceof-predicate form +lisp-fixnum-class+)) + +(defun p2-test-stringp (form) + (p2-test-instanceof-predicate form +lisp-abstract-string-class+)) + +(defun p2-test-vectorp (form) + (p2-test-instanceof-predicate form +lisp-abstract-vector-class+)) + +(defun p2-test-simple-vector-p (form) + (p2-test-instanceof-predicate form +lisp-simple-vector-class+)) + +(defknown compile-test-form (t) t) +(defun compile-test-form (test-form) + (when (consp test-form) + (let* ((op (%car test-form)) + (handler (p2-test-handler op)) + (result (and handler (funcall handler test-form)))) + (when result + (return-from compile-test-form result)))) + (cond ((eq test-form t) + :consequent) + ((null test-form) + :alternate) + ((eq (derive-compiler-type test-form) 'BOOLEAN) + (compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean) + 'ifeq) + (t + (compile-forms-and-maybe-emit-clear-values test-form 'stack nil) + (emit-push-nil) + 'if_acmpeq))) + +(defun p2-test-not/null (form) + (when (check-arg-count form 1) + (let* ((arg (%cadr form)) + (result (compile-test-form arg))) + (ecase result + ('if_acmpeq 'if_acmpne) + ('if_acmpne 'if_acmpeq) + ('ifeq 'ifne) + ('ifne 'ifeq) + ('iflt 'ifge) + ('ifge 'iflt) + ('ifgt 'ifle) + ('ifle 'ifgt) + ('if_icmpeq 'if_icmpne) + ('if_icmpne 'if_icmpeq) + ('if_icmplt 'if_icmpge) + ('if_icmpge 'if_icmplt) + ('if_icmpgt 'if_icmple) + ('if_icmple 'if_icmpgt) + (:alternate :consequent) + (:consequent :alternate))))) + +(defun p2-test-char= (form) + (when (check-arg-count form 2) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack :char) + 'if_icmpne))) + +(defun p2-test-eq (form) + (when (check-arg-count form 2) + (let ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + 'if_acmpne))) + +(defun p2-test-and (form) + (let ((args (cdr form))) + (case (length args) + (0 + :consequent) + (1 + (compile-test-form (%car args))) + (2 + (compile-form form 'stack :boolean) + 'ifeq) + (t + (compile-forms-and-maybe-emit-clear-values form 'stack nil) + (emit-push-nil) + 'if_acmpeq)))) + +(defun p2-test-neq (form) + (p2-test-eq form) + 'if_acmpeq) + +(defun p2-test-eql (form) + (when (check-arg-count form 2) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (fixnum-type-p type1) (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + 'if_icmpne) + ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack :char) + 'if_icmpne) + ((eq type2 'CHARACTER) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :char) + (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") + 'ifeq) + ((eq type1 'CHARACTER) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack nil) + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") + 'ifeq) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") + 'ifeq) + ((fixnum-type-p type1) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") + 'ifeq) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "eql" + (lisp-object-arg-types 1) "Z") + 'ifeq))))) + +(defun p2-test-equality (form) +;; (format t "p2-test-equality ~S~%" (%car form)) + (when (check-arg-count form 2) + (let* ((op (%car form)) + (translated-op (ecase op +;; (EQL "eql") + (EQUAL "equal") + (EQUALP "equalp"))) + (arg1 (%cadr form)) + (arg2 (%caddr form))) + (cond ((fixnum-type-p (derive-compiler-type arg2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ + translated-op + '("I") "Z")) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ + translated-op + (lisp-object-arg-types 1) "Z"))) + 'ifeq))) + +(defun p2-test-simple-typep (form) + (when (check-arg-count form 2) + (let ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "typep" + (lisp-object-arg-types 1) +lisp-object+) + (emit-push-nil) + 'if_acmpeq))) + +(defun p2-test-memq (form) + (when (check-arg-count form 2) + (let ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokestatic +lisp-class+ "memq" + (lisp-object-arg-types 2) "Z") + 'ifeq))) + +(defun p2-test-memql (form) + (when (check-arg-count form 2) + (let ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokestatic +lisp-class+ "memql" + (lisp-object-arg-types 2) "Z") + 'ifeq))) + +(defun p2-test-/= (form) + (when (= (length form) 3) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (numberp arg1) (numberp arg2)) + (if (/= arg1 arg2) :consequent :alternate)) + ((and (fixnum-type-p type1) + (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + 'if_icmpeq) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z") + 'ifeq) + ((fixnum-type-p type1) + ;; FIXME Compile the args in reverse order and avoid the swap if + ;; either arg is a fixnum or a lexical variable. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z") + 'ifeq) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" + (lisp-object-arg-types 1) "Z") + 'ifeq))))) + +(defun p2-test-numeric-comparison (form) + (when (check-min-args form 1) + (when (= (length form) 3) + (let* ((op (%car form)) + (args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (fixnump arg1) (fixnump arg2)) + (if (funcall op arg1 arg2) :consequent :alternate)) + ((and (fixnum-type-p type1) (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (ecase op + (< 'if_icmpge) + (<= 'if_icmpgt) + (> 'if_icmple) + (>= 'if_icmplt) + (= 'if_icmpne))) + ((and (java-long-type-p type1) (java-long-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) + (emit 'lcmp) + (ecase op + (< 'ifge) + (<= 'ifgt) + (> 'ifle) + (>= 'iflt) + (= 'ifne))) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ + (ecase op + (< "isLessThan") + (<= "isLessThanOrEqualTo") + (> "isGreaterThan") + (>= "isGreaterThanOrEqualTo") + (= "isEqualTo")) + '("I") "Z") + 'ifeq) + ((fixnum-type-p type1) + ;; FIXME We can compile the args in reverse order and avoid + ;; the swap if either arg is a fixnum or a lexical variable. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ + (ecase op + (< "isGreaterThan") + (<= "isGreaterThanOrEqualTo") + (> "isLessThan") + (>= "isLessThanOrEqualTo") + (= "isEqualTo")) + '("I") "Z") + 'ifeq) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ + (ecase op + (< "isLessThan") + (<= "isLessThanOrEqualTo") + (> "isGreaterThan") + (>= "isGreaterThanOrEqualTo") + (= "isEqualTo")) + (lisp-object-arg-types 1) "Z") + 'ifeq)))))) + +(defknown p2-if-or (t t t) t) +(defun p2-if-or (form target representation) + (let* ((test (second form)) + (consequent (third form)) + (alternate (fourth form)) + (LABEL1 (gensym)) + (LABEL2 (gensym))) + (aver (and (consp test) (eq (car test) 'OR))) + (let* ((args (cdr test))) + (case (length args) + (0 + (compile-form alternate target representation)) + (1 + (p2-if (list 'IF (%car args) consequent alternate) target representation)) + (t + (dolist (arg args) + (cond ((and (consp arg) (eq (first arg) 'EQ)) + ;; ERROR CHECKING HERE! + (let ((arg1 (second arg)) + (arg2 (third arg))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit 'if_acmpeq LABEL1))) + ((eq (derive-compiler-type arg) 'BOOLEAN) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (emit 'ifne LABEL1)) + (t + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-push-nil) + (emit 'if_acmpne LABEL1)))) + (compile-form alternate target representation) + (emit 'goto LABEL2) + (label LABEL1) + (compile-form consequent target representation) + (label LABEL2)))))) + +(defknown p2-if-and (t t t) t) +(defun p2-if-and (form target representation) + (let* ((test (second form)) + (consequent (third form)) + (alternate (fourth form)) + (LABEL1 (gensym)) + (LABEL2 (gensym))) + (aver (and (consp test) (eq (car test) 'AND))) + (let* ((args (cdr test))) + (case (length args) + (0 + (compile-form consequent target representation)) + (1 + (p2-if (list 'IF (%car args) consequent alternate) target representation)) + (t + (dolist (arg args) +;; (let ((type (derive-compiler-type arg))) +;; (cond +;; ((eq type 'BOOLEAN) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (emit 'ifeq LABEL1) +;; ) +;; (t +;; (compile-form arg 'stack nil) +;; (maybe-emit-clear-values arg) +;; (emit-push-nil) +;; (emit 'if_acmpeq LABEL1)) +;; ) +;; ) + ) + (compile-form consequent target representation) + (emit 'goto LABEL2) + (label LABEL1) + (compile-form alternate target representation) + (label LABEL2)))))) + +(defknown p2-if-not-and (t t t) t) +(defun p2-if-not-and (form target representation) +;; (format t "p2-if-not-and~%") +;; (aver (eq (first form) 'IF)) +;; (aver (consp (second form))) +;; (aver (memq (first (second form)) '(NOT NULL))) +;; (aver (eq (first (second (second form))) 'AND)) + (let* ((inverted-test (second (second form))) + (consequent (third form)) + (alternate (fourth form)) + (LABEL1 (gensym)) + (LABEL2 (gensym))) +;; (aver (and (consp inverted-test) (eq (car inverted-test) 'AND))) + (let* ((args (cdr inverted-test))) + (case (length args) + (0 + (compile-form alternate target representation)) + (1 + (p2-if (list 'IF (%car args) alternate consequent) target representation)) + (t + (dolist (arg args) + (let ((type (derive-compiler-type arg))) + (cond ((eq type 'BOOLEAN) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (emit 'ifeq LABEL1)) + (t + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-push-nil) + (emit 'if_acmpeq LABEL1))))) + (compile-form alternate target representation) + (emit 'goto LABEL2) + (label LABEL1) + (compile-form consequent target representation) + (label LABEL2)))))) + +(defknown p2-if (t t t) t) +(defun p2-if (form target representation) + (let* ((test (second form)) + (consequent (third form)) + (alternate (fourth form)) + (LABEL1 (gensym)) + (LABEL2 (gensym))) + (cond ((eq test t) + (compile-form consequent target representation)) + ((null test) + (compile-form alternate target representation)) + ((numberp test) + (compile-form consequent target representation)) + ((equal (derive-compiler-type test) +true-type+) + (compile-forms-and-maybe-emit-clear-values test nil nil) + (compile-form consequent target representation)) + ((and (consp test) (eq (car test) 'OR)) + (p2-if-or form target representation)) + ((and (consp test) (eq (car test) 'AND)) + (p2-if-and form target representation)) + ((and (consp test) + (memq (first test) '(NOT NULL)) + (consp (second test)) + (eq (first (second test)) 'AND)) + (p2-if-not-and form target representation)) + (t + (let ((result (compile-test-form test))) + (case result + (:consequent + (compile-form consequent target representation)) + (:alternate + (compile-form alternate target representation)) + (t + (emit result LABEL1) + (compile-form consequent target representation) + (emit 'goto LABEL2) + (label LABEL1) + (compile-form alternate target representation) + (label LABEL2)))))))) + +(defun compile-multiple-value-list (form target representation) + (emit-clear-values) + (compile-form (second form) 'stack nil) + (emit-invokestatic +lisp-class+ "multipleValueList" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target)) + +(defun compile-multiple-value-prog1 (form target representation) + (let ((first-subform (cadr form)) + (subforms (cddr form)) + (result-register (allocate-register)) + (values-register (allocate-register))) + ;; Make sure there are no leftover values from previous calls. + (emit-clear-values) + (compile-form first-subform result-register nil) + ;; Save multiple values returned by first subform. + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (astore values-register) + (dolist (subform subforms) + (compile-form subform nil nil)) + ;; Restore multiple values returned by first subform. + (emit-push-current-thread) + (aload values-register) + (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + ;; Result. + (aload result-register) + (fix-boxing representation nil) + (emit-move-from-stack target))) + +(defun compile-multiple-value-call (form target representation) + ;; FIXME What if we're called with a non-NIL representation? + (aver (null representation)) + (case (length form) + (1 + (error "Wrong number of arguments for MULTIPLE-VALUE-CALL.")) + (2 + (compile-form (second form) 'stack nil) + (emit-invokestatic +lisp-class+ "coerceToFunction" + (lisp-object-arg-types 1) +lisp-object+) + (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+)) + (3 + (let* ((*register* *register*) + (function-register (allocate-register))) + (compile-form (second form) function-register nil) + (compile-form (third form) 'stack nil) + (aload function-register) + (emit-push-current-thread) + (emit-invokestatic +lisp-class+ "multipleValueCall1" + (list +lisp-object+ +lisp-object+ +lisp-thread+) + +lisp-object+))) + (t + ;; The general case. + (let* ((*register* *register*) + (function-register (allocate-register)) + (values-register (allocate-register))) + (compile-form (second form) 'stack nil) + (emit-invokestatic +lisp-class+ "coerceToFunction" + (lisp-object-arg-types 1) +lisp-object+) + (emit-move-from-stack function-register) + (emit 'aconst_null) + (astore values-register) + (dolist (values-form (cddr form)) + (compile-form values-form 'stack nil) + (emit-push-current-thread) + (emit 'swap) + (aload values-register) + (emit-invokevirtual +lisp-thread-class+ "accumulateValues" + (list +lisp-object+ +lisp-object-array+) + +lisp-object-array+) + (astore values-register) + (maybe-emit-clear-values values-form)) + (aload function-register) + (aload values-register) + (emit-invokevirtual +lisp-object-class+ "dispatch" + (list +lisp-object-array+) +lisp-object+)))) + (fix-boxing representation nil) + (emit-move-from-stack target)) + +(defknown unused-variable (t) t) +(defun unused-variable (variable) + (unless (or (variable-ignore-p variable) + (variable-ignorable-p variable)) + (compiler-style-warn "The variable ~S is defined but never used." + (variable-name variable)))) + +(defknown check-for-unused-variables (list) t) +(defun check-for-unused-variables (list) + (dolist (variable list) + (when (and (not (variable-special-p variable)) + (zerop (variable-reads variable)) + (zerop (variable-writes variable))) + (unused-variable variable)))) + +;; Generates code to bind variable to value at top of runtime stack. +(declaim (ftype (function (t) t) compile-binding)) +(defun compile-binding (variable) + (cond ((variable-register variable) + (astore (variable-register variable))) + ((variable-special-p variable) + (emit-push-current-thread) + (emit 'swap) + (emit-push-variable-name variable) + (emit 'swap) + (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) nil)) + ((variable-closure-index variable) + (aload (compiland-closure-register *current-compiland*)) + (emit 'swap) ; array value + (emit-push-constant-int (variable-closure-index variable)) + (emit 'swap) ; array index value + (emit 'aastore)) + (t + (sys::%format t "compile-binding~%") + (aver nil)))) + +(defknown compile-progn-body (t t &optional t) t) +(defun compile-progn-body (body target &optional representation) + (cond ((null body) + (when target + (emit-push-nil) + (emit-move-from-stack target))) + (t + (let ((clear-values nil) + (tail body)) + (loop + (let ((form (car tail))) + (cond ((null (cdr tail)) + ;; Last form. + (when clear-values + (emit-clear-values)) + (compile-form form target representation) + (return)) + (t + ;; Not the last form. + (compile-form form nil nil) + (unless clear-values + (unless (single-valued-p form) + (setq clear-values t))))) + (setq tail (cdr tail))))))) + t) + +(defun p2-m-v-b-node (block target) + (let* ((*blocks* (cons block *blocks*)) + (*register* *register*) + (form (block-form block)) + (*visible-variables* *visible-variables*) + (vars (second form)) + (bind-special-p nil) + (variables (block-vars block))) + (dolist (variable variables) + (let ((special-p (variable-special-p variable))) + (cond (special-p + (setf bind-special-p t)) + (t + (unless (variable-closure-index variable) + (setf (variable-register variable) (allocate-register))))))) + ;; If we're going to bind any special variables... + (when bind-special-p + (dformat t "p2-m-v-b-node lastSpecialBinding~%") + ;; Save current dynamic environment. + (setf (block-environment-register block) (allocate-register)) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (astore (block-environment-register block))) + ;; Make sure there are no leftover values from previous calls. + (emit-clear-values) + ;; Bind the variables. + (aver (= (length vars) (length variables))) + (cond ((= (length vars) 1) + (compile-forms-and-maybe-emit-clear-values (third form) 'stack nil) + (compile-binding (car variables))) + (t + (let* ((*register* *register*) + (result-register (allocate-register)) + (values-register (allocate-register)) + (LABEL1 (gensym)) + (LABEL2 (gensym))) + ;; Store primary value from values form in result register. + (compile-form (third form) result-register nil) + ;; Store values from values form in values register. + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (emit-move-from-stack values-register) + ;; Did we get just one value? + (aload values-register) + (emit 'ifnull LABEL1) + ;; Reaching here, we have multiple values (or no values at all). We need + ;; the slow path if we have more variables than values. + (aload values-register) + (emit 'arraylength) + (emit-push-constant-int (length vars)) + (emit 'if_icmplt LABEL1) + ;; Reaching here, we have enough values for all the variables. We can use + ;; the values we have. This is the fast path. + (aload values-register) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-current-thread) + (aload result-register) + (emit-push-constant-int (length vars)) + (emit-invokevirtual +lisp-thread-class+ "getValues" + (list +lisp-object+ "I") +lisp-object-array+) + ;; Values array is now on the stack at runtime. + (label LABEL2) + (let ((index 0)) + (dolist (variable variables) + (when (< index (1- (length vars))) + (emit 'dup)) + (emit-push-constant-int index) + (incf index) + (emit 'aaload) + ;; Value is on the runtime stack at this point. + (compile-binding variable))) + (maybe-emit-clear-values (third form))))) + ;; Make the variables visible for the body forms. + (dolist (variable variables) + (push variable *visible-variables*)) + ;; Body. + (compile-progn-body (cdddr form) target) + (when bind-special-p + ;; Restore dynamic environment. + (aload *thread*) + (aload (block-environment-register block)) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)))) + +(defun propagate-vars (block) + (let ((removed '())) + (dolist (variable (block-vars block)) + (unless (or (variable-special-p variable) + (variable-closure-index variable)) + (when (eql (variable-writes variable) 0) + ;; There are no writes to the variable. + (let ((initform (variable-initform variable))) + (cond ((var-ref-p initform) + (let ((source-var (var-ref-variable initform))) + (cond ((null source-var) + (aver (var-ref-constant-p initform)) + (let ((value (var-ref-constant-value initform))) + (dolist (ref (variable-references variable)) + (aver (eq (var-ref-variable ref) variable)) + (setf (var-ref-variable ref) nil + (var-ref-constant-p ref) t + (var-ref-constant-value ref) value)))) + (t + (unless (or (variable-special-p source-var) + (variable-used-non-locally-p source-var)) + (when (eql (variable-writes source-var) 0) + ;; We can eliminate the variable. + ;; FIXME This may no longer be true when we start tracking writes! + (aver (= (variable-reads variable) (length (variable-references variable)))) + (dolist (ref (variable-references variable)) + (aver (eq (var-ref-variable ref) variable)) + (setf (var-ref-variable ref) source-var)) + ;; Check for DOTIMES limit variable. + (when (get (variable-name variable) 'sys::dotimes-limit-variable-p) + (let* ((symbol (get (variable-name variable) 'sys::dotimes-index-variable-name)) + (index-variable (find-variable symbol (block-vars block)))) + (when index-variable + (setf (get (variable-name index-variable) 'sys::dotimes-limit-variable-name) + (variable-name source-var))))) + (push variable removed))))))) + ((fixnump initform) + (dolist (ref (variable-references variable)) + (aver (eq (var-ref-variable ref) variable)) + (setf (var-ref-variable ref) nil + (var-ref-constant-p ref) t + (var-ref-constant-value ref) initform)) + (push variable removed))))))) + (when removed + (dolist (variable removed) + (setf (block-vars block) (remove variable (block-vars block))))))) + +(defun derive-variable-representation (variable block + &key (type nil type-supplied-p)) + (when (not (null (variable-representation variable))) + ;; representation already derived + (return-from derive-variable-representation)) + (when type-supplied-p + (setf (variable-declared-type variable) type)) + (let ((type (variable-declared-type variable))) + (when (and (eq (variable-declared-type variable) :none) + (eql (variable-writes variable) 0)) + (setf type (variable-derived-type variable))) + (cond ((neq type :none) + (setf (variable-representation variable) + (type-representation type)) + (unless (memq (variable-representation variable) '(:int :long)) + ;; We don't support unboxed variables other than INT and LONG (yet) + (setf (variable-representation variable) NIL))) + ((zerop (variable-writes variable)) + (when (eq :none (variable-derived-type variable)) + (setf (variable-derived-type variable) + (derive-compiler-type (variable-initform variable)))) + (let ((derived-type (variable-derived-type variable))) + (setf (variable-derived-type variable) derived-type) + (setf (variable-representation variable) + (type-representation derived-type)) + (unless (memq (variable-representation variable) '(:int :long)) + ;; We don't support unboxed variables other than INT and LONG (yet) + (setf (variable-representation variable) NIL)))) + ((and block + (get (variable-name variable) 'sys::dotimes-index-variable-p)) + ;; DOTIMES index variable. + (let* ((name (get (variable-name variable) + 'sys::dotimes-limit-variable-name)) + (limit-variable (and name + (or (find-variable name + (block-vars block)) + (find-visible-variable name))))) + (when limit-variable + (derive-variable-representation limit-variable block) + (setf (variable-representation variable) + (variable-representation limit-variable)))))))) + +(defun allocate-variable-register (variable) + (setf (variable-register variable) + (if (= 2 (representation-size (variable-representation variable))) + (allocate-register-pair) + (allocate-register)))) + +(defun emit-move-to-variable (variable) + (let ((representation (variable-representation variable))) + (flet ((emit-array-store (representation) + (emit (ecase representation + ((:int :boolean :char) + 'iastore) + (:long 'lastore) + (:float 'fastore) + (:double 'dastore) + ((nil) 'aastore))))) + (cond ((variable-register variable) + (emit (ecase (variable-representation variable) + ((:int :boolean :char) + 'istore) + (:long 'lstore) + (:float 'fstore) + (:double 'dstore) + ((nil) 'astore)) + (variable-register variable))) + ((variable-index variable) + (aload (compiland-argument-register *current-compiland*)) + (emit-swap representation nil) + (emit-push-constant-int (variable-index variable)) + (emit-swap representation :int) + (emit-array-store (variable-representation variable))) + ((variable-closure-index variable) + (aload (compiland-closure-register *current-compiland*)) + (emit-swap representation nil) + (emit-push-constant-int (variable-closure-index variable)) + (emit-swap representation :int) + (emit-array-store (variable-representation variable))) + (t + ;;###FIXME: We might want to address the "temp-register" case too. + (assert nil)))))) + +(defun emit-push-variable (variable) + (flet ((emit-array-store (representation) + (emit (ecase representation + ((:int :boolean :char) + 'iaload) + (:long 'laload) + (:float 'faload) + (:double 'daload) + ((nil) 'aaload))))) + (cond ((variable-register variable) + (emit (ecase (variable-representation variable) + ((:int :boolean :char) + 'iload) + (:long 'lload) + (:float 'fload) + (:double 'dload) + ((nil) 'aload)) + (variable-register variable))) + ((variable-index variable) + (aload (compiland-argument-register *current-compiland*)) + (emit-push-constant-int (variable-index variable)) + (emit-array-store (variable-representation variable))) + ((variable-closure-index variable) + (aload (compiland-closure-register *current-compiland*)) + (emit-push-constant-int (variable-closure-index variable)) + (emit-array-store (variable-representation variable))) + (t ;;###FIXME: We might want to address the "temp-register" case too. + (assert nil))))) + + +(defknown p2-let-bindings (t) t) +(defun p2-let-bindings (block) + (dolist (variable (block-vars block)) + (unless (or (variable-special-p variable) + (variable-closure-index variable) + (zerop (variable-reads variable))) + (aver (null (variable-register variable))) + (setf (variable-register variable) t))) + (let ((must-clear-values nil)) + (declare (type boolean must-clear-values)) + ;; Evaluate each initform. If the variable being bound is special, allocate + ;; a temporary register for the result; LET bindings must be done in + ;; parallel, so we can't modify any specials until all the initforms have + ;; been evaluated. Note that we can't just push the values on the stack + ;; because we'll lose JVM stack consistency if there is a non-local + ;; transfer of control from one of the initforms. + (dolist (variable (block-vars block)) + (let* ((initform (variable-initform variable)) + (unused-p (and (not (variable-special-p variable)) + ;; If it's never read, we don't care about writes. + (zerop (variable-reads variable))))) + (cond (unused-p + (compile-form initform nil nil)) ; for effect + (t + (cond (initform + (when (eq (variable-register variable) t) + (derive-variable-representation variable block)) + (compile-form initform 'stack + (variable-representation variable)) + (unless must-clear-values + (unless (single-valued-p initform) + (setf must-clear-values t)))) + (t + ;; No initform. + (emit-push-nil))) + (when (eq (variable-register variable) t) + ;; Now allocate the register. + (allocate-variable-register variable)) + (cond ((variable-special-p variable) + (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register)))) + ((variable-representation variable) + (emit-move-to-variable variable)) + (t + (compile-binding variable))))))) + (when must-clear-values + (emit-clear-values)) + ;; Now that all the initforms have been evaluated, move the results from + ;; the temporary registers (if any) to their proper destinations. + (dolist (variable (block-vars block)) + (when (variable-temp-register variable) + (aver (variable-special-p variable)) + (aload (variable-temp-register variable)) + (compile-binding variable)))) + ;; Now make the variables visible. + (dolist (variable (block-vars block)) + (push variable *visible-variables*)) + t) + +(defknown p2-let*-bindings (t) t) +(defun p2-let*-bindings (block) + (let ((must-clear-values nil)) + (declare (type boolean must-clear-values)) + ;; Generate code to evaluate initforms and bind variables. + (dolist (variable (block-vars block)) + (let* ((initform (variable-initform variable)) + (unused-p (and (not (variable-special-p variable)) + (zerop (variable-reads variable)) + (zerop (variable-writes variable)))) + (boundp nil)) + (declare (type boolean unused-p boundp)) + (macrolet ((update-must-clear-values () + `(unless must-clear-values + (unless (single-valued-p initform) + (setf must-clear-values t))))) + (cond ((and (variable-special-p variable) + (eq initform (variable-name variable))) + ;; The special case of binding a special to its current value. + (emit-push-current-thread) + (emit-push-variable-name variable) + (emit-invokevirtual +lisp-thread-class+ + "bindSpecialToCurrentValue" + (list +lisp-symbol+) + nil) + (setf boundp t)) + ((and (not (variable-special-p variable)) + (zerop (variable-reads variable))) + ;; We don't have to bind it if we never read it. + (compile-form initform nil nil) ; for effect + (update-must-clear-values) + (setf boundp t)) + ((null initform) + (cond ((and (null (variable-closure-index variable)) + (not (variable-special-p variable)) + (eq (variable-declared-type variable) 'BOOLEAN)) + (setf (variable-representation variable) :boolean) + (setf (variable-register variable) (allocate-register)) + (emit 'iconst_0) + (emit 'istore (variable-register variable)) + (setf boundp t)) + (t + (emit-push-nil)))) + (t + (cond (unused-p + (compile-form initform nil nil) ; for effect + (update-must-clear-values) + (setf boundp t)) + ((and (null (variable-closure-index variable)) + (not (variable-special-p variable))) + (when (and (eq (variable-declared-type variable) :none) + (eql (variable-writes variable) 0)) + (setf (variable-derived-type variable) + (derive-compiler-type initform))) + (derive-variable-representation variable block) + (allocate-variable-register variable) + (compile-form initform 'stack + (variable-representation variable)) + (update-must-clear-values) + (emit-move-to-variable variable) + (setf boundp t)) + (t + (compile-form initform 'stack nil) + (update-must-clear-values)))))) + (unless (or boundp (variable-special-p variable)) + (unless (or (variable-closure-index variable) + (variable-register variable)) + (setf (variable-register variable) (allocate-register)))) + (push variable *visible-variables*) + (unless boundp + (compile-binding variable)) + (maybe-generate-type-check variable))) + (when must-clear-values + (emit-clear-values))) + t) + +(defun p2-let/let*-node (block target representation) + (let* ((*blocks* (cons block *blocks*)) + (*register* *register*) + (form (block-form block)) + (*visible-variables* *visible-variables*) + (specialp nil)) + ;; Walk the variable list looking for special bindings and unused lexicals. + (dolist (variable (block-vars block)) + (cond ((variable-special-p variable) + (setf specialp t)) + ((zerop (variable-reads variable)) + (unused-variable variable)))) + ;; If there are any special bindings... + (when specialp + ;; We need to save current dynamic environment. + (setf (block-environment-register block) (allocate-register)) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (astore (block-environment-register block))) + (propagate-vars block) + (ecase (car form) + (LET + (p2-let-bindings block)) + (LET* + (p2-let*-bindings block))) + ;; Make declarations of free specials visible. + (dolist (variable (block-free-specials block)) + (push variable *visible-variables*)) + ;; Body of LET/LET*. + (with-saved-compiler-policy + (process-optimization-declarations (cddr form)) + (compile-progn-body (cddr form) target representation)) + (when specialp + ;; Restore dynamic environment. + (aload *thread*) + (aload (block-environment-register block)) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)))) + +(defun p2-locally (form target representation) + (with-saved-compiler-policy + (let ((body (cdr form))) + (process-optimization-declarations body) + (compile-progn-body body target representation)))) + +(defknown find-tag (t) t) +(defun find-tag (name) + (dolist (tag *visible-tags*) + (when (eql name (tag-name tag)) + (return tag)))) + +(defknown p2-tagbody-node (t t) t) +(defun p2-tagbody-node (block target) + (let* ((*blocks* (cons block *blocks*)) + (*visible-tags* *visible-tags*) + (*register* *register*) + (form (block-form block)) + (body (cdr form)) + (local-tags ()) + (BEGIN-BLOCK (gensym)) + (END-BLOCK (gensym)) + (EXIT (gensym)) + environment-register + (must-clear-values nil)) + ;; Scan for tags. + (dolist (subform body) + (when (or (symbolp subform) (integerp subform)) + (let* ((tag (make-tag :name subform :label (gensym) :block block))) + (push tag local-tags) + (push tag *visible-tags*)))) + (when (block-non-local-go-p block) + (dformat t "p2-tagbody-node lastSpecialBinding~%") + (setf environment-register (allocate-register)) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (astore environment-register)) + (label BEGIN-BLOCK) + (do* ((rest body (cdr rest)) + (subform (car rest) (car rest))) + ((null rest)) + (cond ((or (symbolp subform) (integerp subform)) + (let ((tag (find-tag subform))) + (unless tag + (error "COMPILE-TAGBODY: tag not found: ~S~%" subform)) + (label (tag-label tag)))) + (t + (compile-form subform nil nil) + (unless must-clear-values + (unless (single-valued-p subform) +;; (let ((*print-structure* nil)) +;; (format t "not single-valued: ~S~%" subform)) + (setf must-clear-values t)))))) + (label END-BLOCK) + (emit 'goto EXIT) + (when (block-non-local-go-p block) + ; We need a handler to catch non-local GOs. + (let* ((HANDLER (gensym)) + (*register* *register*) + (go-register (allocate-register)) + (tag-register (allocate-register))) + (label HANDLER) + ;; The Go object is on the runtime stack. Stack depth is 1. + (emit 'dup) + (astore go-register) + ;; Get the tag. + (emit 'checkcast +lisp-go-class+) + (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. + (astore tag-register) + (dolist (tag local-tags) + (let ((NEXT (gensym))) + (aload tag-register) + (emit 'getstatic *this-class* + (if *compile-file-truename* + (declare-object-as-string (tag-label tag)) + (declare-object (tag-label tag))) + +lisp-object+) + (emit 'if_acmpne NEXT) ;; Jump if not EQ. + ;; Restore dynamic environment. + (emit-push-current-thread) + (aver (fixnump environment-register)) + (aload environment-register) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (emit 'goto (tag-label tag)) + (label NEXT))) + ;; Not found. Re-throw Go. + (aload go-register) + (emit 'athrow) + ;; Finally... + (push (make-handler :from BEGIN-BLOCK + :to END-BLOCK + :code HANDLER + :catch-type (pool-class +lisp-go-class+)) + *handlers*))) + (label EXIT) + (when must-clear-values + (emit-clear-values)) + ;; TAGBODY returns NIL. + (when target + (emit-push-nil) + (emit-move-from-stack target)))) + +(defknown p2-go (t t t) t) +(defun p2-go (form target representation) + ;; FIXME What if we're called with a non-NIL representation? + (declare (ignore representation)) + (let* ((name (cadr form)) + (tag (find-tag name))) + (unless tag + (error "p2-go: tag not found: ~S" name)) + (when (eq (tag-compiland tag) *current-compiland*) + ;; Local case. + (let* ((tag-block (tag-block tag)) + (register nil) + (protected + ;; Does the GO leave an enclosing CATCH or UNWIND-PROTECT? + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block tag-block) + (return nil)) + (let ((block-name (block-name enclosing-block))) + (when (or (equal block-name '(CATCH)) + (equal block-name '(UNWIND-PROTECT))) + (return t)))))) + (unless protected + (dolist (block *blocks*) + (if (eq block tag-block) + (return) + (setf register (or (block-environment-register block) register)))) + (when register + ;; Restore dynamic environment. + (aload *thread*) + (aload register) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)) + (maybe-generate-interrupt-check) + (emit 'goto (tag-label tag)) + (return-from p2-go)))) + ;; Non-local GO. + (emit 'new +lisp-go-class+) + (emit 'dup) + (compile-form `',(tag-label tag) 'stack nil) ; Tag. + (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 1)) + (emit 'athrow) + ;; Following code will not be reached, but is needed for JVM stack + ;; consistency. + (when target + (emit-push-nil) + (emit-move-from-stack target)))) + +(defknown p2-atom (t t t) t) +(define-inlined-function p2-atom (form target representation) + ((aver (or (null representation) (eq representation :boolean))) + (check-arg-count form 1)) + (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) + (emit 'instanceof +lisp-cons-class+) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'ifeq LABEL1) + (ecase representation + (:boolean + (emit 'iconst_0)) + ((nil) + (emit-push-nil))) + (emit 'goto LABEL2) + (label LABEL1) + (ecase representation + (:boolean + (emit 'iconst_1)) + ((nil) + (emit-push-t))) + (label LABEL2) + (emit-move-from-stack target representation))) + +(defknown p2-instanceof-predicate (t t t t) t) +(defun p2-instanceof-predicate (form target representation java-class) + (unless (check-arg-count form 1) + (compile-function-call form target representation) + (return-from p2-instanceof-predicate)) + (let ((arg (%cadr form))) + (cond ((null target) + (compile-forms-and-maybe-emit-clear-values arg nil nil)) + (t + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit 'instanceof java-class) + (convert-representation :boolean representation) + (emit-move-from-stack target representation))))) + +(defun p2-bit-vector-p (form target representation) + (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector-class+)) + +(defun p2-characterp (form target representation) + (p2-instanceof-predicate form target representation +lisp-character-class+)) + +(defun p2-classp (form target representation) + (p2-instanceof-predicate form target representation +lisp-class-class+)) + +(defun p2-consp (form target representation) + (p2-instanceof-predicate form target representation +lisp-cons-class+)) + +(defun p2-fixnump (form target representation) + (p2-instanceof-predicate form target representation +lisp-fixnum-class+)) + +(defun p2-packagep (form target representation) + (p2-instanceof-predicate form target representation +lisp-package-class+)) + +(defun p2-readtablep (form target representation) + (p2-instanceof-predicate form target representation +lisp-readtable-class+)) + +(defun p2-simple-vector-p (form target representation) + (p2-instanceof-predicate form target representation +lisp-simple-vector-class+)) + +(defun p2-stringp (form target representation) + (p2-instanceof-predicate form target representation +lisp-abstract-string-class+)) + +(defun p2-symbolp (form target representation) + (p2-instanceof-predicate form target representation +lisp-symbol-class+)) + +(defun p2-vectorp (form target representation) + (p2-instanceof-predicate form target representation +lisp-abstract-vector-class+)) + +(define-inlined-function p2-coerce-to-function (form target representation) + ((check-arg-count form 1)) + (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil) + (emit-invokestatic +lisp-class+ "coerceToFunction" + (lisp-object-arg-types 1) +lisp-object+) + (emit-move-from-stack target)) + +(defun p2-block-node (block target representation) + (unless (block-node-p block) + (sys::%format t "type-of block = ~S~%" (type-of block)) + (aver (block-node-p block))) + (let* ((*blocks* (cons block *blocks*)) + (*register* *register*)) + (cond ((block-return-p block) + (setf (block-target block) target) + (dformat t "p2-block-node lastSpecialBinding~%") + (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) + (cond ((some #'variable-special-p *all-variables*) + ;; Save the current dynamic environment. + (setf (block-environment-register block) (allocate-register)) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (astore (block-environment-register block))) + (t + (dformat t "no specials~%"))) + (setf (block-catch-tag block) (gensym)) + (let* ((*register* *register*) + (BEGIN-BLOCK (gensym)) + (END-BLOCK (gensym)) + (BLOCK-EXIT (block-exit block))) + (label BEGIN-BLOCK) ; Start of protected range. + ;; Implicit PROGN. + (compile-progn-body (cddr (block-form block)) target) + (label END-BLOCK) ; End of protected range. + (emit 'goto BLOCK-EXIT) ; Jump over handler (if any). + (when (block-non-local-return-p block) + ; We need a handler to catch non-local RETURNs. + (let ((HANDLER (gensym)) + (RETHROW (gensym))) + (label HANDLER) + ;; The Return object is on the runtime stack. Stack depth is 1. + (emit 'dup) ; Stack depth is 2. + (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2. + (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. Stack depth is 3. + ;; If it's not the tag we're looking for... + (emit 'if_acmpne RETHROW) ; Stack depth is 1. + (emit 'getfield +lisp-return-class+ "result" +lisp-object+) + (emit-move-from-stack target) ; Stack depth is 0. + (emit 'goto BLOCK-EXIT) + (label RETHROW) + ;; Not the tag we're looking for. + (emit 'athrow) + ;; Finally... + (push (make-handler :from BEGIN-BLOCK + :to END-BLOCK + :code HANDLER + :catch-type (pool-class +lisp-return-class+)) + *handlers*))) + (label BLOCK-EXIT)) + (when (block-environment-register block) + ;; We saved the dynamic environment above. Restore it now. + (aload *thread*) + (aload (block-environment-register block)) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)) + (fix-boxing representation nil) + ) + (t + ;; No explicit returns. + (compile-progn-body (cddr (block-form block)) target representation))))) + +(defknown p2-return-from (t t t) t) +(defun p2-return-from (form target representation) + ;; FIXME What if we're called with a non-NIL representation? + (declare (ignore representation)) + (let* ((name (second form)) + (result-form (third form)) + (block (find-block name))) + (when (null block) + (error "No block named ~S is currently visible." name)) + (let ((compiland *current-compiland*)) + (when (eq (block-compiland block) compiland) + ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is + ;; inside the block we're returning from? + (let ((protected + (dolist (enclosing-block *blocks*) + (when (eq enclosing-block block) + (return nil)) + (when (equal (block-name enclosing-block) '(UNWIND-PROTECT)) + (return t))))) + (unless protected + (unless (compiland-single-valued-p *current-compiland*) +;; (format t "compiland not single-valued: ~S~%" +;; (compiland-name *current-compiland*)) + (emit-clear-values)) + (compile-form result-form (block-target block) nil) + (emit 'goto (block-exit block)) + (return-from p2-return-from))))) + ;; Non-local RETURN. + (aver (block-non-local-return-p block)) + (cond ((node-constant-p result-form) + (emit 'new +lisp-return-class+) + (emit 'dup) + (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. + (emit-clear-values) + (compile-form result-form 'stack nil)) ; Result. + (t + (let* ((*register* *register*) + (temp-register (allocate-register))) + (emit-clear-values) + (compile-form result-form temp-register nil) ; Result. + (emit 'new +lisp-return-class+) + (emit 'dup) + (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. + (aload temp-register)))) + (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2)) + (emit 'athrow) + ;; Following code will not be reached, but is needed for JVM stack + ;; consistency. + (when target + (emit-push-nil) + (emit-move-from-stack target)))) + +(defun emit-car/cdr (arg target representation field) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invoke-method field target representation)) + +(define-inlined-function p2-car (form target representation) + ((check-arg-count form 1)) + (let ((arg (%cadr form))) + (cond ((and (null target) (< *safety* 3)) + (compile-form arg target nil)) + ((and (consp arg) (eq (%car arg) 'cdr) (= (length arg) 2)) + (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil) + (emit-invoke-method "cadr" target representation)) + (t + (emit-car/cdr arg target representation "car"))))) + +(define-inlined-function p2-cdr (form target representation) + ((check-arg-count form 1)) + (let ((arg (%cadr form))) + (emit-car/cdr arg target representation "cdr"))) + +(define-inlined-function p2-cons (form target representation) + ((check-arg-count form 2)) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (let* ((args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (emit-move-from-stack target)) + +(defun compile-progn (form target representation) + (compile-progn-body (cdr form) target) + (fix-boxing representation nil)) + +(defun p2-eval-when (form target representation) + (cond ((or (memq :execute (cadr form)) + (memq 'eval (cadr form))) + (compile-progn-body (cddr form) target) + (fix-boxing representation nil)) + (t + (emit-push-nil) + (emit-move-from-stack target)))) + +(defun p2-load-time-value (form target representation) + (cond (*compile-file-truename* + (emit 'getstatic *this-class* + (declare-load-time-value (second form)) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-constant (eval (second form)) target representation)))) + +(defun p2-progv (form target representation) + (let* ((symbols-form (cadr form)) + (values-form (caddr form)) + (*register* *register*) + (environment-register (allocate-register))) + (compile-form symbols-form 'stack nil) + (compile-form values-form 'stack nil) + (unless (and (single-valued-p symbols-form) + (single-valued-p values-form)) + (emit-clear-values)) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (astore environment-register) + ;; Compile call to Lisp.progvBindVars(). + (aload *thread*) + (emit-invokestatic +lisp-class+ "progvBindVars" + (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) + ;; Implicit PROGN. + (compile-progn-body (cdddr form) target) + ;; Restore dynamic environment. + (aload *thread*) + (aload environment-register) + (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+) + (fix-boxing representation nil))) + +(defun p2-quote (form target representation) + (aver (or (null representation) (eq representation :boolean))) + (let ((obj (second form))) + (cond ((null obj) + (when target + (emit-push-false representation) + (emit-move-from-stack target representation))) + ((eq representation :boolean) + (emit 'iconst_1) + (emit-move-from-stack target representation)) + ((keywordp obj) + (let ((name (lookup-known-keyword obj))) + (if name + (emit 'getstatic "org/armedbear/lisp/Keyword" name +lisp-symbol+) + (emit 'getstatic *this-class* (declare-keyword obj) +lisp-symbol+))) + (emit-move-from-stack target representation)) + ((symbolp obj) + (let ((name (lookup-known-symbol obj))) + (cond (name + (emit 'getstatic +lisp-symbol-class+ name +lisp-symbol+)) + ((symbol-package (truly-the symbol obj)) + (emit 'getstatic *this-class* (declare-symbol obj) +lisp-symbol+)) + (t + ;; An uninterned symbol. + (let ((g (if *compile-file-truename* + (declare-object-as-string obj) + (declare-object obj)))) + (emit 'getstatic *this-class* g +lisp-object+)))) + (emit-move-from-stack target representation))) + ((listp obj) + (let ((g (if *compile-file-truename* + (declare-object-as-string obj) + (declare-object obj)))) + (emit 'getstatic *this-class* g +lisp-object+) + (emit-move-from-stack target representation))) + ((constantp obj) + (compile-constant obj target representation)) + (t + (compiler-unsupported "COMPILE-QUOTE: unsupported case: ~S" form))))) + +(define-inlined-function p2-rplacd (form target representation) + ((check-arg-count form 2)) + (let ((args (cdr form))) + (compile-form (first args) 'stack nil) + (when target + (emit 'dup)) + (compile-form (second args) 'stack nil) + (emit-invokevirtual +lisp-object-class+ + "setCdr" + (lisp-object-arg-types 1) + nil) + (when target + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + +(define-inlined-function p2-set-car/cdr (form target representation) + ((check-arg-count form 2)) + (let ((op (%car form)) + (args (%cdr form))) + (compile-form (%car args) 'stack nil) + (compile-form (%cadr args) 'stack nil) + (when target + (emit-dup nil :past nil)) + (emit-invokevirtual +lisp-object-class+ + (if (eq op 'sys:set-car) "setCar" "setCdr") + (lisp-object-arg-types 1) + nil) + (when target + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + +(defun compile-declare (form target representation) + (declare (ignore form representation)) + (when target + (emit-push-nil) + (emit-move-from-stack target))) + +(defun compile-and-write-to-file (class-file compiland) + (with-class-file class-file + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland)))))) + +(defun set-compiland-and-write-class-file (class-file compiland) + (setf (compiland-class-file compiland) class-file) + (compile-and-write-to-file class-file compiland)) + + +(defun emit-make-compiled-closure-for-flet/labels + (local-function compiland declaration) + (emit 'getstatic *this-class* declaration +lisp-object+) + (let ((parent (compiland-parent compiland))) + (when (compiland-closure-register parent) + (dformat t "(compiland-closure-register parent) = ~S~%" + (compiland-closure-register parent)) + (emit 'checkcast +lisp-ctf-class+) + (aload (compiland-closure-register parent)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))) + (emit-move-to-variable (local-function-variable local-function))) + +(defmacro with-temp-class-file (pathname class-file lambda-list &body body) + `(let* ((,pathname (make-temp-file)) + (,class-file (make-class-file :pathname ,pathname + :lambda-list ,lambda-list))) + (unwind-protect + (progn , at body) + (delete-file pathname)))) + +(defun verify-class-file-loadable (pathname) + (let ((*load-truename* (pathname pathname))) + (unless (ignore-errors (load-compiled-function pathname)) + (error "Unable to load ~S." pathname)))) + +(defknown p2-flet-process-compiland (t) t) +(defun p2-flet-process-compiland (local-function) + (let* ((compiland (local-function-compiland local-function)) + (lambda-list (cadr (compiland-lambda-expression compiland)))) + (cond (*compile-file-truename* + (let* ((pathname (sys::next-classfile-name)) + (class-file (make-class-file :pathname pathname + :lambda-list lambda-list))) + (set-compiland-and-write-class-file class-file compiland) + (verify-class-file-loadable pathname) + (setf (local-function-class-file local-function) class-file)) + (when (local-function-variable local-function) + (let ((g (declare-local-function local-function))) + (emit-make-compiled-closure-for-flet/labels + local-function compiland g)))) + (t + (with-temp-class-file + pathname class-file lambda-list + (set-compiland-and-write-class-file class-file compiland) + (setf (local-function-class-file local-function) class-file) + (setf (local-function-function local-function) (load-compiled-function pathname)) + (when (local-function-variable local-function) + (let ((g (declare-object (load-compiled-function pathname)))) + (emit-make-compiled-closure-for-flet/labels + local-function compiland g)))))))) + +(defknown p2-labels-process-compiland (t) t) +(defun p2-labels-process-compiland (local-function) + (let* ((compiland (local-function-compiland local-function)) + (lambda-list (cadr (compiland-lambda-expression compiland)))) + (cond (*compile-file-truename* + (let* ((pathname (sys::next-classfile-name)) + (class-file (make-class-file :pathname pathname + :lambda-list lambda-list))) + (set-compiland-and-write-class-file class-file compiland) + (verify-class-file-loadable pathname) + (setf (local-function-class-file local-function) class-file) + (let ((g (declare-local-function local-function))) + (emit-make-compiled-closure-for-flet/labels + local-function compiland g)))) + (t + (with-temp-class-file + pathname class-file lambda-list + (set-compiland-and-write-class-file class-file compiland) + (setf (local-function-class-file local-function) class-file) + (let ((g (declare-object (load-compiled-function pathname)))) + (emit-make-compiled-closure-for-flet/labels + local-function compiland g))))))) + +(defknown p2-flet (t t t) t) +(defun p2-flet (form target representation) + ;; FIXME What if we're called with a non-NIL representation? + (declare (ignore representation)) + (let ((*local-functions* *local-functions*) + (*visible-variables* *visible-variables*) + (local-functions (cadr form)) + (body (cddr form))) + (dolist (local-function local-functions) + (let ((variable (local-function-variable local-function))) + (when variable + (aver (null (variable-register variable))) + (unless (variable-closure-index variable) + (setf (variable-register variable) (allocate-register)))))) + (dolist (local-function local-functions) + (p2-flet-process-compiland local-function)) + (dolist (local-function local-functions) + (push local-function *local-functions*) + (let ((variable (local-function-variable local-function))) + (when variable + (push variable *visible-variables*)))) + (do ((forms body (cdr forms))) + ((null forms)) + (compile-form (car forms) (if (cdr forms) nil target) nil)))) + +(defknown p2-labels (t t t) t) +(defun p2-labels (form target representation) + (let ((*local-functions* *local-functions*) + (*visible-variables* *visible-variables*) + (local-functions (cadr form)) + (body (cddr form))) + (dolist (local-function local-functions) + (push local-function *local-functions*) + (push (local-function-variable local-function) *visible-variables*)) + (dolist (local-function local-functions) + (let ((variable (local-function-variable local-function))) + (aver (null (variable-register variable))) + (unless (variable-closure-index variable) + (setf (variable-register variable) (allocate-register))))) + (dolist (local-function local-functions) + (p2-labels-process-compiland local-function)) + (do ((forms body (cdr forms))) + ((null forms)) + (compile-form (car forms) (if (cdr forms) nil 'stack) nil)) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + +(defun p2-lambda (compiland target) + (let* ((lambda-list (cadr (compiland-lambda-expression compiland)))) + (aver (null (compiland-class-file compiland))) + (cond (*compile-file-truename* + (setf (compiland-class-file compiland) + (make-class-file :pathname (sys::next-classfile-name) + :lambda-list lambda-list)) + (let ((class-file (compiland-class-file compiland))) + (compile-and-write-to-file class-file compiland) + (emit 'getstatic *this-class* + (declare-local-function (make-local-function :class-file class-file)) + +lisp-object+))) + (t + (let ((pathname (make-temp-file))) + (setf (compiland-class-file compiland) + (make-class-file :pathname pathname + :lambda-list lambda-list)) + (unwind-protect + (progn + (compile-and-write-to-file (compiland-class-file compiland) compiland) + (emit 'getstatic *this-class* + (declare-object (load-compiled-function pathname)) + +lisp-object+)) + (delete-file pathname))))) + (cond ((null *closure-variables*)) ; Nothing to do. + ((compiland-closure-register *current-compiland*) + (aload (compiland-closure-register *current-compiland*)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+) + (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure + (t + (aver nil))) ;; Shouldn't happen. + (emit-move-from-stack target))) + +(defknown p2-function (t t t) t) +(defun p2-function (form target representation) + ;; FIXME What if we're called with a non-NIL representation? + (declare (ignore representation)) + (let ((name (second form)) + local-function) + (cond ((symbolp name) + (dformat t "p2-function case 1~%") + (cond ((setf local-function (find-local-function name)) + (dformat t "p2-function 1~%") + (cond ((local-function-variable local-function) + (dformat t "p2-function 2 emitting var-ref~%") +;; (emit 'var-ref (local-function-variable local-function) 'stack) + (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil) + ) + (t + (let ((g (if *compile-file-truename* + (declare-local-function local-function) + (declare-object (local-function-function local-function))))) + (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function + + (when (compiland-closure-register *current-compiland*) + (emit 'checkcast +lisp-ctf-class+) + (aload (compiland-closure-register *current-compiland*)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))))) + (emit-move-from-stack target)) + ((inline-ok name) + (emit 'getstatic *this-class* + (declare-function name) +lisp-object+) + (emit-move-from-stack target)) + (t + (emit 'getstatic *this-class* + (declare-symbol name) +lisp-symbol+) + (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" + nil +lisp-object+) + (emit-move-from-stack target)))) + ((and (consp name) (eq (%car name) 'SETF)) + (dformat t "p2-function case 2~%") + ; FIXME Need to check for NOTINLINE declaration! + (cond ((setf local-function (find-local-function name)) + (dformat t "p2-function 1~%") + (when (eq (local-function-compiland local-function) *current-compiland*) + (aload 0) ; this + (emit-move-from-stack target) + (return-from p2-function)) + (cond ((local-function-variable local-function) + (dformat t "p2-function 2~%") +;; (emit 'var-ref (local-function-variable local-function) 'stack) + (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil) + ) + (t + (let ((g (if *compile-file-truename* + (declare-local-function local-function) + (declare-object (local-function-function local-function))))) + (emit 'getstatic *this-class* + g +lisp-object+))))) ; Stack: template-function + ((member name *functions-defined-in-current-file* :test #'equal) + (emit 'getstatic *this-class* + (declare-setf-function name) +lisp-object+) + (emit-move-from-stack target)) + ((and (null *compile-file-truename*) + (fboundp name) + (fdefinition name)) + (emit 'getstatic *this-class* + (declare-object (fdefinition name)) +lisp-object+) + (emit-move-from-stack target)) + (t + (emit 'getstatic *this-class* + (declare-symbol (cadr name)) +lisp-symbol+) + (emit-invokevirtual +lisp-symbol-class+ + "getSymbolSetfFunctionOrDie" + nil +lisp-object+) + (emit-move-from-stack target)))) + ((compiland-p name) + (dformat t "p2-function case 3~%") + (p2-lambda name target)) + (t + (compiler-unsupported "p2-function: unsupported case: ~S" form))))) + +(defknown p2-ash (t t t) t) +(define-inlined-function p2-ash (form target representation) + ((check-arg-count form 2)) + (let* ((args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2)) + (low2 (and (fixnum-type-p type2) (integer-type-low type2))) + (high2 (and (fixnum-type-p type2) (integer-type-high type2))) + (constant-shift (fixnum-constant-value type2)) + (result-type (derive-compiler-type form))) +;; (format t "~&p2-ash type1 = ~S~%" type1) +;; (format t "p2-ash type2 = ~S~%" type2) +;; (format t "p2-ash result-type = ~S~%" result-type) +;; (format t "p2-ash representation = ~S~%" representation) + (cond ((and (integerp arg1) (integerp arg2)) + (compile-constant (ash arg1 arg2) target representation)) + ((and constant-shift + ;; ishl/ishr only use the low five bits of the mask. + (<= -31 constant-shift 31) + (fixnum-type-p type1) + (fixnum-type-p result-type)) + (compile-form arg1 'stack :int) + (cond ((plusp constant-shift) + (compile-form arg2 'stack :int) + (maybe-emit-clear-values arg1 arg2) + (emit 'ishl)) + ((minusp constant-shift) + (cond ((fixnump arg2) + (emit-push-constant-int (- arg2))) + (t + (compile-form arg2 'stack :int) + (emit 'ineg))) + (maybe-emit-clear-values arg1 arg2) + (emit 'ishr)) + ((zerop constant-shift) + (compile-form arg2 nil nil))) ; for effect + (convert-representation :int representation) + (emit-move-from-stack target representation)) + ((and constant-shift + ;; lshl/lshr only use the low six bits of the mask. + (<= -63 constant-shift 63) + (java-long-type-p type1) + (java-long-type-p result-type)) + (compile-form arg1 'stack :long) + (cond ((plusp constant-shift) + (compile-form arg2 'stack :int) + (maybe-emit-clear-values arg1 arg2) + (emit 'lshl)) + ((minusp constant-shift) + (cond ((fixnump arg2) + (emit-push-constant-int (- arg2))) + (t + (compile-form arg2 'stack :int) + (emit 'ineg))) + (maybe-emit-clear-values arg1 arg2) + (emit 'lshr)) + ((zerop constant-shift) + (compile-form arg2 nil nil))) ; for effect + (convert-representation :long representation) + (emit-move-from-stack target representation)) + ((and (fixnum-type-p type1) + low2 high2 (<= -31 low2 high2 0)) ; Negative shift. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit 'ineg) + (emit 'ishr) + (convert-representation :int representation) + (emit-move-from-stack target representation)) + ((fixnum-type-p type2) + (cond ((and low2 high2 (<= 0 low2 high2 63) ; Non-negative shift. + (java-long-type-p type1) + (java-long-type-p result-type)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :int) + (emit 'lshl) + (convert-representation :long representation)) + ((and low2 high2 (<= -63 low2 high2 0) ; Negative shift. + (java-long-type-p type1) + (java-long-type-p result-type)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :int) + (emit 'ineg) + (emit 'lshr) + (convert-representation :long representation)) + (t +;; (format t "p2-ash call to LispObject.ash(int)~%") +;; (format t "p2-ash type1 = ~S type2 = ~S~%" type1 type2) +;; (format t "p2-ash result-type = ~S~%" result-type) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) + (fix-boxing representation result-type))) + (emit-move-from-stack target representation)) + (t +;; (format t "p2-ash full call~%") + (compile-function-call form target representation))))) + +(defknown p2-logand (t t t) t) +(defun p2-logand (form target representation) + (let* ((args (cdr form)) +;; (len (length args)) + ) +;; (cond ((= len 2) + (case (length args) + (2 + (let* ((arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2)) + (result-type (derive-compiler-type form))) + ;; (let ((*print-structure* nil)) + ;; (format t "~&p2-logand arg1 = ~S~%" arg1) + ;; (format t "p2-logand arg2 = ~S~%" arg2)) + ;; (format t "~&p2-logand type1 = ~S~%" type1) + ;; (format t "p2-logand type2 = ~S~%" type2) + ;; (format t "p2-logand result-type = ~S~%" result-type) + ;; (format t "p2-logand representation = ~S~%" representation) + (cond ((and (integerp arg1) (integerp arg2)) + (compile-constant (logand arg1 arg2) target representation)) + ((and (integer-type-p type1) (eql arg2 0)) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil) + (compile-constant 0 target representation)) + ((eql (fixnum-constant-value type1) -1) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 target representation)) + ((eql (fixnum-constant-value type2) -1) + (compile-forms-and-maybe-emit-clear-values arg1 target representation + arg2 nil nil)) + ((and (fixnum-type-p type1) (fixnum-type-p type2)) + ;; (format t "p2-logand fixnum case~%") + ;; Both arguments are fixnums. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit 'iand) + (convert-representation :int representation) + (emit-move-from-stack target representation)) + ((or (and (fixnum-type-p type1) + (compiler-subtypep type1 'unsigned-byte)) + (and (fixnum-type-p type2) + (compiler-subtypep type2 'unsigned-byte))) + ;; One of the arguments is a positive fixnum. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit 'iand) + (convert-representation :int representation) + (emit-move-from-stack target representation)) + ((and (java-long-type-p type1) (java-long-type-p type2)) + ;; Both arguments are longs. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) + (emit 'land) + (convert-representation :long representation) + (emit-move-from-stack target representation)) + ((or (and (java-long-type-p type1) + (compiler-subtypep type1 'unsigned-byte)) + (and (java-long-type-p type2) + (compiler-subtypep type2 'unsigned-byte))) + ;; One of the arguments is a positive long. + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) + (emit 'land) + (convert-representation :long representation) + (emit-move-from-stack target representation)) + ((fixnum-type-p type2) + ;; (format t "p2-logand LispObject.LOGAND(int) 1~%") + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + ((fixnum-type-p type1) + ;; (format t "p2-logand LispObject.LOGAND(int) 2~%") + ;; arg1 is a fixnum, but arg2 is not + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + ;; swap args + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + (t + ;; (format t "p2-logand LispObject.LOGAND(LispObject)~%") + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "LOGAND" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation))))) + (t + (compile-function-call form target representation))))) + +(defknown p2-logior (t t t) t) +(defun p2-logior (form target representation) + (let ((args (cdr form))) + (case (length args) + (0 + (compile-constant 0 target representation)) + (1 + (let ((arg (%car args))) + (compile-forms-and-maybe-emit-clear-values arg target representation))) + (2 + (let* ((arg1 (%car args)) + (arg2 (%cadr args)) + type1 type2 result-type) + (when (and (integerp arg1) (integerp arg2)) + (compile-constant (logior arg1 arg2) target representation) + (return-from p2-logior t)) + (when (integerp arg1) + (setf arg1 (%cadr args) + arg2 (%car args))) + (setf type1 (derive-compiler-type arg1) + type2 (derive-compiler-type arg2) + result-type (derive-compiler-type form)) + (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2)) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 nil nil) + (compile-constant (logior (fixnum-constant-value type1) + (fixnum-constant-value type2)) + target representation)) + ((and (fixnum-type-p type1) (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit 'ior) + (convert-representation :int representation) + (emit-move-from-stack target representation)) + ((and (eql (fixnum-constant-value type1) 0) (< *safety* 3)) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 target representation)) + ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3)) + (compile-forms-and-maybe-emit-clear-values arg1 target representation + arg2 nil nil)) + ((or (eq representation :long) + (and (java-long-type-p type1) (java-long-type-p type2))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) + (emit 'lor) + (convert-representation :long representation) + (emit-move-from-stack target representation)) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + ((fixnum-type-p type1) + ;; arg1 is of fixnum type, but arg2 is not + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + ;; swap args + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "LOGIOR" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation))))) + (t + ;; (logior a b c d ...) => (logior a (logior b c d ...)) + (let ((new-form `(logior ,(car args) (logior ,@(cdr args))))) + (p2-logior new-form target representation)))))) + +(defknown p2-logxor (t t t) t) +(defun p2-logxor (form target representation) + (let* ((args (cdr form)) + (len (length args))) + (case len + (0 + (compile-constant 0 target representation)) + (1 + (let ((arg (%car args))) + (compile-forms-and-maybe-emit-clear-values arg target representation))) + (2 + (let* ((arg1 (%car args)) + (arg2 (%cadr args)) + type1 type2 result-type) + (when (and (integerp arg1) (integerp arg2)) + (compile-constant (logxor arg1 arg2) target representation) + (return-from p2-logxor)) + (when (integerp arg1) + (setf arg1 (%cadr args) + arg2 (%car args))) + (setf type1 (derive-compiler-type arg1) + type2 (derive-compiler-type arg2) + result-type (derive-compiler-type form)) + (cond ((eq representation :int) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit 'ixor)) + ((and (fixnum-type-p type1) (fixnum-type-p type2)) +;; (format t "p2-logxor case 2~%") + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit 'ixor) + (convert-representation :int representation)) + ((and (java-long-type-p type1) (java-long-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :long + arg2 'stack :long) + (emit 'lxor) + (convert-representation :long representation)) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "LOGXOR" '("I") +lisp-object+) + (fix-boxing representation result-type)) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "LOGXOR" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation result-type))) + (emit-move-from-stack target representation))) + (t + ;; (logxor a b c d ...) => (logxor a (logxor b c d ...)) + (let ((new-form `(logxor ,(car args) (logxor ,@(cdr args))))) + (p2-logxor new-form target representation)))))) + +(defknown p2-lognot (t t t) t) +(define-inlined-function p2-lognot (form target representation) + ((check-arg-count form 1)) + (cond ((and (fixnum-type-p (derive-compiler-type form))) + (let ((arg (%cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + (emit 'iconst_m1) + (emit 'ixor) + (convert-representation :int representation) + (emit-move-from-stack target representation))) + (t + (let ((arg (%cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil)) + (emit-invokevirtual +lisp-object-class+ "LOGNOT" nil +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + +;; %ldb size position integer => byte +(defknown p2-%ldb (t t t) t) +(define-inlined-function p2-%ldb (form target representation) + ((check-arg-count form 3)) + (let* ((args (cdr form)) + (size-arg (%car args)) + (position-arg (%cadr args)) + (arg3 (%caddr args)) + (size-type (derive-compiler-type size-arg)) + (position-type (derive-compiler-type position-arg)) + (size (fixnum-constant-value size-type)) + (position (fixnum-constant-value position-type))) + ;; FIXME Inline the case where all args are of fixnum type. + ;; FIXME Add LispObject.ldb(), returning a Java int, for the case where we + ;; need an unboxed fixnum result. + (cond ((eql size 0) + (compile-forms-and-maybe-emit-clear-values size-arg nil nil + position-arg nil nil + arg3 nil nil) + (compile-constant 0 target representation)) + ((and size position) + (cond ((<= (+ position size) 31) + (compile-forms-and-maybe-emit-clear-values size-arg nil nil + position-arg nil nil + arg3 'stack :int) + (unless (zerop position) + (emit-push-constant-int position) + (emit 'ishr)) + (emit-push-constant-int (1- (expt 2 size))) ; mask + (emit 'iand) + (convert-representation :int representation) + (emit-move-from-stack target representation)) + ((<= (+ position size) 63) + (compile-forms-and-maybe-emit-clear-values size-arg nil nil + position-arg nil nil + arg3 'stack :long) + (unless (zerop position) + (emit-push-constant-int position) + (emit 'lshr)) + (cond ((<= size 31) + (emit 'l2i) + (emit-push-constant-int (1- (expt 2 size))) + (emit 'iand) + (convert-representation :int representation)) + (t + (emit-push-constant-long (1- (expt 2 size))) ; mask + (emit 'land) + (convert-representation :long representation))) + (emit-move-from-stack target representation)) + (t + (compile-forms-and-maybe-emit-clear-values arg3 'stack nil) + (emit-push-constant-int size) + (emit-push-constant-int position) + (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + ((and (fixnum-type-p size-type) + (fixnum-type-p position-type)) + (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int + position-arg 'stack :int + arg3 'stack nil) + (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved + (emit 'pop) + (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defknown p2-mod (t t t) t) +(define-inlined-function p2-mod (form target representation) + ((check-arg-count form 2)) + (let* ((args (cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (eq representation :int) + (fixnum-type-p type1) + (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack :int) + (emit-invokestatic +lisp-class+ "mod" '("I" "I") "I") + (emit-move-from-stack target representation)) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "MOD" '("I") +lisp-object+) + (fix-boxing representation nil) ; FIXME use derived result type + (emit-move-from-stack target representation)) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "MOD" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) ; FIXME use derived result type + (emit-move-from-stack target representation))))) + +;; (defknown p2-integerp (t t t) t) +;; (defun p2-integerp (form target representation) +;; (unless (check-arg-count form 1) +;; (compile-function-call form target representation) +;; (return-from p2-integerp)) +;; (let ((arg (cadr form))) +;; (compile-form arg 'stack nil) +;; (maybe-emit-clear-values arg) +;; (case representation +;; (:boolean +;; (emit-invokevirtual +lisp-object-class+ "integerp" nil "Z")) +;; (t +;; (emit-invokevirtual +lisp-object-class+ "INTEGERP" nil +lisp-object+))) +;; (emit-move-from-stack target representation))) + +;; (defknown p2-listp (t t t) t) +;; (defun p2-listp (form target representation) +;; (unless (check-arg-count form 1) +;; (compile-function-call form target representation) +;; (return-from p2-listp)) +;; (let ((arg (cadr form))) +;; (compile-form arg 'stack nil) +;; (maybe-emit-clear-values arg) +;; (case representation +;; (:boolean +;; (emit-invokevirtual +lisp-object-class+ "listp" nil "Z")) +;; (t +;; (emit-invokevirtual +lisp-object-class+ "LISTP" nil +lisp-object+))) +;; (emit-move-from-stack target representation))) + +(defknown p2-zerop (t t t) t) +(define-inlined-function p2-zerop (form target representation) + ((aver (or (null representation) (eq representation :boolean))) + (check-arg-count form 1)) + (let* ((arg (cadr form)) + (type (derive-compiler-type arg))) + (cond ((fixnum-type-p type) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'ifne LABEL1) + (ecase representation + (:boolean + (emit 'iconst_1)) + ((nil) + (emit-push-t))) + (emit 'goto LABEL2) + (label LABEL1) + (ecase representation + (:boolean + (emit 'iconst_0)) + ((nil) + (emit-push-nil))) + (label LABEL2) + (emit-move-from-stack target representation))) + ((java-long-type-p type) + (compile-forms-and-maybe-emit-clear-values arg 'stack :long) + (emit 'lconst_0) + (emit 'lcmp) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'ifne LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2) + (emit-move-from-stack target representation))) + (t + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invoke-method "ZEROP" target representation))))) + +;; find-class symbol &optional errorp environment => class +(defknown p2-find-class (t t t) t) +(defun p2-find-class (form target representation) + (let* ((args (cdr form)) + (arg-count (length args)) + (arg1 (first args)) + class) + (when (and (<= 1 arg-count 2) ; no environment arg + (consp arg1) + (= (length arg1) 2) + (eq (first arg1) 'QUOTE) + (symbolp (second arg1)) + (eq (symbol-package (second arg1)) (find-package "CL")) + (setf class (find-class (second arg1) nil))) + (compile-constant class target representation) + (return-from p2-find-class)) + (case arg-count + (1 + ;; errorp is true + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit-push-constant-int 1) ; errorp + (emit-invokestatic +lisp-class-class+ "findClass" + (list +lisp-object+ "Z") +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (2 + (let ((arg2 (second args))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :boolean) + (emit-invokestatic +lisp-class-class+ "findClass" + (list +lisp-object+ "Z") +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation))))) + +;; vector-push-extend new-element vector &optional extension => new-index +(defun p2-vector-push-extend (form target representation) + (let* ((args (cdr form)) + (arg-count (length args)) + (arg1 (first args)) + (arg2 (second args))) + (case arg-count + (2 + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit 'swap) + (cond (target + (emit-invokevirtual +lisp-object-class+ "VECTOR_PUSH_EXTEND" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (emit-invokevirtual +lisp-object-class+ "vectorPushExtend" + (lisp-object-arg-types 1) nil)))) + (t + (compile-function-call form target representation))))) + +(defknown p2-std-slot-value (t t t) t) +(define-inlined-function p2-std-slot-value (form target representation) + ((check-arg-count form 2)) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "SLOT_VALUE" + (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + +;; set-std-slot-value instance slot-name new-value => new-value +(defknown p2-set-std-slot-value (t t t) t) +(define-inlined-function p2-set-std-slot-value (form target representation) + ((check-arg-count form 3)) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (arg3 (third args)) + (*register* *register*) + (value-register (when target (allocate-register)))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack nil + arg3 'stack nil) + (when value-register + (emit 'dup) + (astore value-register)) + (emit-invokevirtual +lisp-object-class+ "setSlotValue" + (lisp-object-arg-types 2) nil) + (when value-register + (aload value-register) + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + +(defun p2-make-array (form target representation) + ;; In safe code, we want to make sure the requested length does not exceed + ;; ARRAY-DIMENSION-LIMIT. + (cond ((and (< *safety* 3) + (= (length form) 2) + (fixnum-type-p (derive-compiler-type (second form))) + (null representation)) + (let ((arg (second form))) + (emit 'new +lisp-simple-vector-class+) + (emit 'dup) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + (emit-invokespecial-init +lisp-simple-vector-class+ '("I")) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +;; make-sequence result-type size &key initial-element => sequence +(define-inlined-function p2-make-sequence (form target representation) + ;; In safe code, we want to make sure the requested length does not exceed + ;; ARRAY-DIMENSION-LIMIT. + ((and (< *safety* 3) + (= (length form) 3) + (null representation))) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args))) + (when (and (consp arg1) + (= (length arg1) 2) + (eq (first arg1) 'QUOTE)) + (let* ((result-type (second arg1)) + (class + (case result-type + ((STRING SIMPLE-STRING) + (setf class +lisp-simple-string-class+)) + ((VECTOR SIMPLE-VECTOR) + (setf class +lisp-simple-vector-class+))))) + (when class + (emit 'new class) + (emit 'dup) + (compile-forms-and-maybe-emit-clear-values arg2 'stack :int) + (emit-invokespecial-init class '("I")) + (emit-move-from-stack target representation) + (return-from p2-make-sequence))))) + (compile-function-call form target representation)) + +(defun p2-make-string (form target representation) + ;; In safe code, we want to make sure the requested length does not exceed + ;; ARRAY-DIMENSION-LIMIT. + (cond ((and (< *safety* 3) + (= (length form) 2) + (null representation)) + (let ((arg (second form))) + (emit 'new +lisp-simple-string-class+) + (emit 'dup) + (compile-forms-and-maybe-emit-clear-values arg 'stack :int) + (emit-invokespecial-init +lisp-simple-string-class+ '("I")) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +(defun p2-%make-structure (form target representation) + (cond ((and (check-arg-count form 2) + (eq (derive-type (%cadr form)) 'SYMBOL)) + (emit 'new +lisp-structure-object-class+) + (emit 'dup) + (compile-form (%cadr form) 'stack nil) + (emit 'checkcast +lisp-symbol-class+) + (compile-form (%caddr form) 'stack nil) + (maybe-emit-clear-values (%cadr form) (%caddr form)) + (emit-invokevirtual +lisp-object-class+ "copyToArray" + nil +lisp-object-array+) + (emit-invokespecial-init +lisp-structure-object-class+ + (list +lisp-symbol+ +lisp-object-array+)) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation)))) + +(defun p2-make-structure (form target representation) + (let* ((args (cdr form)) + (slot-forms (cdr args)) + (slot-count (length slot-forms))) + (cond ((and (<= 1 slot-count 6) + (eq (derive-type (%car args)) 'SYMBOL)) + (emit 'new +lisp-structure-object-class+) + (emit 'dup) + (compile-form (%car args) 'stack nil) + (emit 'checkcast +lisp-symbol-class+) + (dolist (slot-form slot-forms) + (compile-form slot-form 'stack nil)) + (apply 'maybe-emit-clear-values args) + (emit-invokespecial-init +lisp-structure-object-class+ + (append (list +lisp-symbol+) + (make-list slot-count :initial-element +lisp-object+))) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defun p2-make-hash-table (form target representation) + (cond ((= (length form) 1) ; no args + (emit 'new +lisp-eql-hash-table-class+) + (emit 'dup) + (emit-invokespecial-init +lisp-eql-hash-table-class+ nil) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation)))) + +(defknown p2-stream-element-type (t t t) t) +(define-inlined-function p2-stream-element-type (form target representation) + ((check-arg-count form 1)) + (let ((arg (%cadr form))) + (cond ((eq (derive-compiler-type arg) 'STREAM) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit 'checkcast +lisp-stream-class+) + (emit-invokevirtual +lisp-stream-class+ "getElementType" + nil +lisp-object+) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +;; write-8-bits byte stream => nil +(defknown p2-write-8-bits (t t t) t) +(define-inlined-function p2-write-8-bits (form target representation) + ((check-arg-count form 2)) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (compiler-subtypep type1 '(UNSIGNED-BYTE 8)) + (eq type2 'STREAM)) + (compile-form arg1 'stack :int) + (compile-form arg2 'stack nil) + (emit 'checkcast +lisp-stream-class+) + (maybe-emit-clear-values arg1 arg2) + (emit 'swap) + (emit-invokevirtual +lisp-stream-class+ "_writeByte" '("I") nil) + (when target + (emit-push-nil) + (emit-move-from-stack target))) + ((fixnum-type-p type1) + (compile-form arg1 'stack :int) + (compile-form arg2 'stack nil) + (maybe-emit-clear-values arg1 arg2) + (emit-invokestatic +lisp-class+ "writeByte" + (list "I" +lisp-object+) nil) + (when target + (emit-push-nil) + (emit-move-from-stack target))) + (t + (compile-function-call form target representation))))) + +(defun p2-read-line (form target representation) +;; (format t "p2-read-line~%") + (let* ((args (cdr form)) + (len (length args))) + (case len + (1 + (let* ((arg1 (%car args)) + (type1 (derive-compiler-type arg1))) + (cond ((compiler-subtypep type1 'stream) +;; (format t "p2-read-line optimized case 1~%") + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit 'checkcast +lisp-stream-class+) + (emit-push-constant-int 1) + (emit-push-nil) + (emit-invokevirtual +lisp-stream-class+ "readLine" + (list "Z" +lisp-object+) +lisp-object+) + (when target + (emit-move-from-stack target))) + (t + (compile-function-call form target representation))))) + (2 + (let* ((arg1 (%car args)) + (type1 (derive-compiler-type arg1)) + (arg2 (%cadr args))) + (cond ((and (compiler-subtypep type1 'stream) (null arg2)) +;; (format t "p2-read-line optimized case 2~%") + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit 'checkcast +lisp-stream-class+) + (emit-push-constant-int 0) + (emit-push-nil) + (emit-invokevirtual +lisp-stream-class+ "readLine" + (list "Z" +lisp-object+) +lisp-object+) + (when target + (emit-move-from-stack target)) + ) + (t + (compile-function-call form target representation))))) + (t + (compile-function-call form target representation))))) + +(defmacro define-derive-type-handler (op lambda-list &body body) + (let ((name (intern (concatenate 'string "DERIVE-TYPE-" (symbol-name op))))) + `(progn + (defknown ,name (t) t) + (defun ,name ,lambda-list , at body) + (setf (get ',op 'derive-type-handler) ',name)))) + +(define-derive-type-handler aref (form) + (let* ((args (cdr form)) + (array-arg (car args)) + (array-type (normalize-type (derive-type array-arg))) + (result-type t)) + (cond ((and (consp array-type) + (memq (%car array-type) '(ARRAY SIMPLE-ARRAY VECTOR))) + (let ((element-type (second array-type))) + (unless (eq element-type '*) + (setf result-type element-type)))) + ((and (consp array-type) + (memq (%car array-type) '(STRING SIMPLE-STRING))) + (setf result-type 'CHARACTER))) + result-type)) + +(define-derive-type-handler fixnump (form) + (if (fixnum-type-p (derive-compiler-type (cadr form))) + +true-type+ + 'BOOLEAN)) + +(define-derive-type-handler setq (form) + (if (= (length form) 3) + (derive-compiler-type (third form)) + t)) + +(defknown derive-type-logior/logxor (t) t) +(defun derive-type-logior/logxor (form) + (let ((op (car form)) + (args (cdr form)) + (result-type +integer-type+)) + (case (length args) + (0 + (setf result-type (make-integer-type '(INTEGER 0 0)))) + (1 + (setf result-type (derive-compiler-type (car args)))) + (2 + (let ((type1 (derive-compiler-type (%car args))) + (type2 (derive-compiler-type (%cadr args)))) + (cond ((and (compiler-subtypep type1 'unsigned-byte) + (compiler-subtypep type2 'unsigned-byte)) + (let ((high1 (integer-type-high type1)) + (high2 (integer-type-high type2))) + (cond ((and high1 high2) + (let ((length (integer-length (max high1 high2)))) + (setf result-type + (make-compiler-type (list 'INTEGER 0 + (1- (expt 2 length))))))) + (t + (setf result-type (make-compiler-type 'unsigned-byte)))))) + ((and (fixnum-type-p type1) + (fixnum-type-p type2)) + (setf result-type (make-compiler-type 'fixnum)))))) + (t + (setf result-type (derive-type-logior/logxor + `(,op ,(car args) (,op ,@(cdr args))))))) + result-type)) + +(defknown derive-type-logand (t) t) +(defun derive-type-logand (form) + (let ((args (cdr form))) + (case (length args) + (0 + (make-integer-type '(INTEGER -1 -1))) + (1 + (let ((type (derive-compiler-type (%car args)))) + (if (integer-type-p type) + type + (make-integer-type 'INTEGER)))) + (2 + (dformat t "derive-type-logand 2-arg case~%") + (let* ((type1 (derive-compiler-type (%car args))) + (type2 (derive-compiler-type (%cadr args))) + low1 high1 low2 high2 result-low result-high result-type) + (when (integer-type-p type1) + (setf low1 (integer-type-low type1) + high1 (integer-type-high type1))) + (when (integer-type-p type2) + (setf low2 (integer-type-low type2) + high2 (integer-type-high type2))) + (cond ((and low1 low2 (>= low1 0) (>= low2 0)) + ;; Both arguments are non-negative. + (dformat t "both args are non-negative~%") + (setf result-low 0) + (setf result-high (if (and high1 high2) + (min high1 high2) + (or high1 high2))) +;; (setf result-type (make-integer-type (list 'INTEGER result-low result-high))) + ) + ((and low1 (>= low1 0)) + ;; arg1 is non-negative + (dformat t "arg1 is non-negative~%") + (setf result-low 0) + (setf result-high high1) +;; (setf result-type (make-integer-type (list 'INTEGER 0 high1))) + ) + ((and low2 (>= low2 0)) + ;; arg2 is non-negative + (dformat t "arg2 is non-negative~%") + (setf result-low 0) + (setf result-high high2) +;; (setf result-type (make-integer-type (list 'INTEGER 0 high2))) + )) + (dformat t "result-low = ~S~%" result-low) + (dformat t "result-high = ~S~%" result-high) + (setf result-type (make-integer-type (list 'INTEGER result-low result-high))) + (dformat t "result-type = ~S~%" result-type) + result-type)) + (t + (make-integer-type 'INTEGER))))) + +(declaim (ftype (function (t) t) derive-type-lognot)) +(defun derive-type-lognot (form) + (let (arg-type) + (if (and (= (length form) 2) + (fixnum-type-p (setf arg-type (derive-compiler-type (%cadr form))))) + (let* ((arg-low (integer-type-low arg-type)) + (arg-high (integer-type-high arg-type)) + (result-low (if arg-high (lognot arg-high) nil)) + (result-high (if arg-low (lognot arg-low) nil))) + (make-integer-type (list 'INTEGER result-low result-high))) + +integer-type+))) + +;; mod number divisor +(declaim (ftype (function (t) t) derive-type-mod)) +(defun derive-type-mod (form) + (if (= (length form) 3) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (integer-type-p type1) (fixnum-type-p type2)) + 'FIXNUM) + (t + t))) + t)) + +(defknown derive-type-coerce (t) t) +(defun derive-type-coerce (form) + (if (= (length form) 3) + (let ((type-form (%caddr form))) + (if (and (consp type-form) (eq (%car type-form) 'QUOTE) (= (length type-form) 2)) + (%cadr type-form) + t)) + t)) + +(defknown derive-type-copy-seq (t) t) +(defun derive-type-copy-seq (form) + (if (= (length form) 2) + (let ((type (derive-compiler-type (second form)))) + (case type + ((STRING SIMPLE-STRING) + (make-compiler-type type)) + (t + t))) + t)) + +(defknown derive-type-integer-length (t) t) +(defun derive-type-integer-length (form) + (when (= (length form) 2) + (let ((type (make-integer-type (derive-type (%cadr form))))) + (when type + (let ((low (integer-type-low type)) + (high (integer-type-high type))) + (when (and (integerp low) (integerp high)) + (return-from derive-type-integer-length + (list 'INTEGER 0 + (max (integer-length low) (integer-length high))))))))) + (list 'INTEGER 0 '*)) + +(defknown derive-type-%ldb (t) t) +(defun derive-type-%ldb (form) + (when (= (length form) 4) + (let* ((args (cdr form)) + (size-arg (first args))) + (when (fixnump size-arg) + (return-from derive-type-%ldb (list 'INTEGER 0 (1- (expt 2 size-arg))))))) + (list 'INTEGER 0 '*)) + + +(defmacro define-int-bounds-derivation (name (low1 high1 low2 high2) + &body body) + "Associates an integer-bounds calculation function with a numeric +operator `name', assuming 2 integer arguments." + `(setf (get ',name 'int-bounds) + #'(lambda (,low1 ,high1 ,low2 ,high2) + (declare (ignorable ,low1 ,high1 ,low2 ,high2)) + , at body))) + +(defun derive-integer-type (op type1 type2) + "Derives the composed integer type of operation `op' given integer +types `type1' and `type2'." + (let ((low1 (integer-type-low type1)) + (high1 (integer-type-high type1)) + (low2 (integer-type-low type2)) + (high2 (integer-type-high type2)) + (op-fn (get op 'int-bounds))) + (assert op-fn) + (multiple-value-bind + (low high non-int-p) + (funcall op-fn low1 high1 low2 high2) + (if non-int-p + non-int-p + (%make-integer-type low high))))) + +(defvar numeric-op-type-derivation + `(((+ - *) + (integer integer ,#'derive-integer-type) + (integer single-float single-float) + (integer double-float double-float) + (single-float integer single-float) + (single-float double-float double-float) + (double-float integer double-float) + (double-float single-float double-float)) + ((/) + (integer single-float single-float) + (integer double-float double-float) + (single-float integer single-float) + (single-float double-float double-float) + (double-float integer double-float) + (double-float single-float double-float)) + ((ash) + (integer integer ,#'derive-integer-type)) + ((min max) + (integer integer ,#'derive-integer-type) + (integer single-float single-float) + (integer double-float double-float) + (single-float double-float double-float) + (double-float single-float double-float))) + "Table used to derive the return type of a numeric operation, +based on the types of the arguments.") + +(defun derive-type-numeric-op (op &rest types) + "Returns the result type of the numeric operation `op' and the types +of the operation arguments given in `types'." + (let ((types-table + (cdr (assoc op numeric-op-type-derivation :test #'member)))) + (assert types-table) + (flet ((match (type1 type2) + (do* ((remaining-types types-table (cdr remaining-types))) + ((endp remaining-types) + ;; when we don't find a matching type, return T + T) + (destructuring-bind + (t1 t2 result-type) + (car remaining-types) + (when (and (or (subtypep type1 t1) + (compiler-subtypep type1 t1)) + (or (subtypep type2 t2) + (compiler-subtypep type2 t2))) + (return-from match + (if (functionp result-type) + (funcall result-type op type1 type2) + result-type))))))) + (let ((type1 (car types)) + (type2 (cadr types))) + (when (and (eq type1 type2) + (memq type1 '(SINGLE-FLOAT DOUBLE-FLOAT))) + (return-from derive-type-numeric-op type1)) + (match type1 type2))))) + +(defvar zero-integer-type (%make-integer-type 0 0) + "Integer type representing the 0 (zero) +value for use with derive-type-minus and derive-type-plus.") + +(define-int-bounds-derivation - (low1 high1 low2 high2) + (values (and low1 low2 (- low1 low2)) + (and high1 high2 (- high1 high2)))) + +(defknown derive-type-minus (t) t) +(defun derive-type-minus (form) + (let ((op (car form)) + (args (cdr form))) + (case (length args) + (1 (derive-type-numeric-op (car form) + zero-integer-type + (derive-compiler-type (%car args)))) + (2 (flet ((combine (x y) + (derive-type-numeric-op op x y))) + (reduce #'combine (cdr args) :key #'derive-compiler-type + :initial-value (derive-compiler-type (car args)))))))) + + +(define-int-bounds-derivation + (low1 high1 low2 high2) + (values (and low1 low2 (+ low1 low2)) + (and high1 high2 (+ high1 high2)))) + +(defknown derive-type-plus (t) t) +(defun derive-type-plus (form) + (let ((op (car form)) + (args (cdr form))) + (if (null args) + zero-integer-type + (flet ((combine (x y) + (derive-type-numeric-op op x y))) + (reduce #'combine (cdr args) :key #'derive-compiler-type + :initial-value (derive-compiler-type (car args))))))) + +(define-int-bounds-derivation * (low1 high1 low2 high2) + (cond ((or (null low1) (null low2)) + (values nil nil)) + ((or (null high1) (null high2)) + (values (if (or (minusp low1) (minusp low2)) + (- (* (abs low1) (abs low2))) + (* low1 low2)) + nil)) + ((or (minusp low1) (minusp low2)) + (let ((max (* (max (abs low1) (abs high1)) + (max (abs low2) (abs high2))))) + (values (- max) max))) + (t + (values (* low1 low2) (* high1 high2))))) + +(defvar one-integer-type (%make-integer-type 1 1) + "Integer type representing the value 1 (one) +for use with derive-type-times.") + +(defun derive-type-times (form) + (let ((op (car form)) + (args (cdr form))) + (if (null args) + one-integer-type + (flet ((combine (x y) + (derive-type-numeric-op op x y))) + (reduce #'combine (cdr args) :key #'derive-compiler-type + :initial-value (derive-compiler-type (car args))))))) + +(define-int-bounds-derivation max (low1 low2 high1 high2) + (values (or (when (and low1 low2) (max low1 low2)) low1 low2) + (or (when (and high1 high2) (max high1 high2)) high1 high2))) + +(declaim (ftype (function (t) t) derive-type-max)) +(defun derive-type-max (form) + (let ((op (car form)) + (args (cdr form))) + (flet ((combine (x y) + (derive-type-numeric-op op x y))) + (reduce #'combine (cdr args) :key #'derive-compiler-type + :initial-value (derive-compiler-type (car args)))))) + +(define-int-bounds-derivation min (low1 high1 low2 high2) + (values (or (when (and low1 low2) (min low1 low2)) low1 low2) + (or (when (and high1 high2) (min high1 high2)) high1 hig2))) + +(defknown derive-type-min (t) t) +(defun derive-type-min (form) + (let ((op (car form)) + (args (cdr form))) + (flet ((combine (x y) + (derive-type-numeric-op op x y))) + (reduce #'combine (cdr args) :key #'derive-compiler-type + :initial-value (derive-compiler-type (car args)))))) + +;; read-char &optional input-stream eof-error-p eof-value recursive-p => char +(declaim (ftype (function (t) t) derive-type-read-char)) +(defun derive-type-read-char (form) + (if (< (length form) 3) ; no EOF-ERROR-P arg + 'CHARACTER + t)) + + +(define-int-bounds-derivation ash (low1 high1 low2 high2) + (when (and low1 high1 low2 high2) + (cond + ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0)) + ;; Everything is non-negative. + (values (ash low1 low2) + (unless (<= 64 high2) + (ash high1 high2)))) + ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0)) + ;; Negative (or zero) second argument. + (values (ash low1 low2) + (ash high1 high2)))))) + +;; ash integer count => shifted-integer +(defknown derive-type-ash (t) t) +(defun derive-type-ash (form) + (derive-type-numeric-op (car form) + (derive-compiler-type (cadr form)) + (derive-compiler-type (caddr form)))) + +(defknown derive-type (t) t) +(defun derive-type (form) + (cond ((consp form) + (let* ((op (%car form)) + (handler (and (symbolp op) (get op 'derive-type-handler)))) + (if handler + (funcall handler form) + (case op + (ASH + (derive-type-ash form)) + ((CHAR SCHAR) + 'CHARACTER) + (COERCE + (derive-type-coerce form)) + (COPY-SEQ + (derive-type-copy-seq form)) + (INTEGER-LENGTH + (derive-type-integer-length form)) + (%LDB + (derive-type-%ldb form)) + (LENGTH + '(INTEGER 0 #.(1- most-positive-fixnum))) + (LOGAND + (derive-type-logand form)) + (LOGNOT + (derive-type-lognot form)) + ((LOGIOR LOGXOR) + (derive-type-logior/logxor form)) + (MOD + (derive-type-mod form)) + (- + (derive-type-minus form)) + (1- + (derive-type-minus (list '- (cadr form) 1))) + (+ + (derive-type-plus form)) + (1+ + (derive-type-plus (list '+ (cadr form) 1))) + (* + (derive-type-times form)) + (MAX + (derive-type-max form)) + (MIN + (derive-type-min form)) + (READ-CHAR + (derive-type-read-char form)) +;; (SETQ +;; (if (= (length form) 3) +;; (derive-type (third form)) +;; t)) + ((THE TRULY-THE) + (second form)) + (t + (let ((type (or (function-result-type op) + (ftype-result-type (proclaimed-ftype op))))) + (if (eq type '*) + t + type))))))) + ((null form) + 'NULL) + ((integerp form) + (list 'INTEGER form form)) + ((typep form 'single-float) + 'SINGLE-FLOAT) + ((typep form 'double-float) + 'DOUBLE-FLOAT) + ((characterp form) + 'CHARACTER) + ((stringp form) + 'STRING) + ((arrayp form) + (type-of form)) + ((variable-p form) + (cond ((neq (variable-declared-type form) :none) + (variable-declared-type form)) + ((neq (variable-derived-type form) :none) + (variable-derived-type form)) + (t + t))) + ((var-ref-p form) + (cond ((var-ref-constant-p form) + (derive-type (var-ref-constant-value form))) + (t + (let ((variable (var-ref-variable form))) + (cond ((variable-special-p variable) + (or (proclaimed-type (variable-name variable)) + t)) + ((neq (variable-declared-type variable) :none) + (variable-declared-type variable)) + ((neq (variable-derived-type variable) :none) + (variable-derived-type variable)) + (t + t)))))) + ((symbolp form) + (cond ((keywordp form) + 'SYMBOL) + ((eq form t) + t) + ((and (special-variable-p form) + (constantp form)) + (derive-type (symbol-value form))) + (t + (let ((variable (find-visible-variable form))) + (if variable + (derive-type variable) + t))))) + ((block-node-p form) + (let ((result t)) + (cond ((equal (block-name form) '(LET)) + ;; (format t "derive-type LET/LET* node case~%") + (let* ((forms (cddr (block-form form))) + (last-form (car (last forms))) + (derived-type (derive-compiler-type last-form))) + ;; (unless (eq derived-type t) + ;; (let ((*print-structure* nil)) + ;; (format t "last-form = ~S~%" last-form)) + ;; (format t "derived-type = ~S~%" derived-type) + ;; ) + (setf result derived-type))) + ((symbolp (block-name form)) + (unless (block-return-p form) + (let* ((forms (cddr (block-form form))) + (last-form (car (last forms))) + (derived-type (derive-compiler-type last-form))) +;; (unless (eq derived-type t) +;; (let ((*print-structure* nil)) +;; (format t "last-form = ~S~%" last-form)) +;; (format t "derived-type = ~S~%" derived-type) +;; ) + (setf result derived-type))))) + result)) + (t + t))) + +(defun derive-compiler-type (form) + (make-compiler-type (derive-type form))) + +;; delete item sequence &key from-end test test-not start end count key +(defknown p2-delete (t t t) t) +(defun p2-delete (form target representation) + (unless (notinline-p 'delete) + (when (= (length form) 3) + ;; No keyword arguments. + (let* ((args (cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-type arg1)) + (type2 (derive-type arg2)) + (test (if (memq type1 '(SYMBOL NULL)) 'eq 'eql))) + (cond ((subtypep type2 'VECTOR) + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil) + (emit 'checkcast +lisp-abstract-vector-class+) + (maybe-emit-clear-values arg1 arg2) + (emit 'swap) + (emit-invokevirtual +lisp-abstract-vector-class+ + (if (eq test 'eq) "deleteEq" "deleteEql") + (lisp-object-arg-types 1) +lisp-object+) + (emit-move-from-stack target) + (return-from p2-delete t)) + (t + (setf (car form) (if (eq test 'eq) 'delete-eq 'delete-eql))))))) + (compile-function-call form target representation)) + +(define-inlined-function p2-length (form target representation) + ((check-arg-count form 1)) + (let ((arg (cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (ecase representation + (:int + (emit-invokevirtual +lisp-object-class+ "length" nil "I")) + ((:long :float :double) + (emit-invokevirtual +lisp-object-class+ "length" nil "I") + (convert-representation :int representation)) + (:boolean + ;; FIXME We could optimize this all away in unsafe calls. + (emit-invokevirtual +lisp-object-class+ "length" nil "I") + (emit 'pop) + (emit 'iconst_1)) + (:char + (sys::%format t "p2-length: :char case~%") + (aver nil)) + ((nil) + (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) + (emit-move-from-stack target representation))) + +(defun p2-list (form target representation) + (let* ((args (cdr form)) + (len (length args))) + (cond ((> len 9) ; list1() through list9() are defined in Lisp.java. + (compile-function-call form target representation)) + (t + (cond ((zerop len) + (emit-push-nil)) + ((= len 1) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form (first args) 'stack nil) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1))) + ((and (>= *speed* *space*) + (< len 4)) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form (first args) 'stack nil) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form (second args) 'stack nil) + (when (= len 3) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form (third args) 'stack nil)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 1)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (when (= len 3) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)))) + (t + (dolist (arg args) + (compile-form arg 'stack nil)) + (let ((s (copy-seq "list "))) + (setf (schar s 4) (code-char (+ (char-code #\0) len))) + (emit-invokestatic +lisp-class+ s + (make-list len :initial-element +lisp-object+) + +lisp-cons+)))) + (unless (every 'single-valued-p args) + (emit-clear-values)) + (emit-move-from-stack target))))) + +(defun p2-list* (form target representation) + (let* ((args (cdr form)) + (length (length args))) + (cond ((= length 1) + (compile-forms-and-maybe-emit-clear-values (first args) 'stack nil) + (emit-move-from-stack target representation)) + ((= length 2) + (let ((arg1 (first args)) + (arg2 (second args))) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (maybe-emit-clear-values arg1 arg2) + (emit-move-from-stack target representation))) + ((= length 3) + (let ((arg1 (first args)) + (arg2 (second args)) + (arg3 (third args))) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form arg1 'stack nil) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form arg2 'stack nil) + (compile-form arg3 'stack nil) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (maybe-emit-clear-values arg1 arg2 arg3) + (emit-move-from-stack target representation))) + ((= length 4) + (let ((arg1 (first args)) + (arg2 (second args)) + (arg3 (third args)) + (arg4 (fourth args))) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form arg1 'stack nil) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form arg2 'stack nil) + (emit 'new +lisp-cons-class+) + (emit 'dup) + (compile-form arg3 'stack nil) + (compile-form arg4 'stack nil) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2)) + (maybe-emit-clear-values arg1 arg2 arg3 arg4) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation))))) + +(define-inlined-function compile-nth (form target representation) + ((check-arg-count form 2)) + (let ((index-form (second form)) + (list-form (third form))) + (compile-forms-and-maybe-emit-clear-values index-form 'stack :int + list-form 'stack nil) + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "NTH" '("I") +lisp-object+) + (fix-boxing representation nil) ; FIXME use derived result type + (emit-move-from-stack target representation))) + +(defun p2-times (form target representation) + (case (length form) + (1 (compile-constant 1 target representation)) + (2 (compile-form (cadr form) target representation)) + (3 + (let* ((args (cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + result-type result-rep value) + (when (fixnump arg1) + (rotatef arg1 arg2)) + (setf result-type (derive-compiler-type form) + result-rep (type-representation result-type)) + (cond ((and (numberp arg1) (numberp arg2)) + (dformat t "p2-times case 1~%") + (compile-constant (* arg1 arg2) target representation)) + ((setf value (fixnum-constant-value result-type)) + (dformat t "p2-times case 1a~%") + (compile-constant value target representation)) + (result-rep + (compile-forms-and-maybe-emit-clear-values + arg1 'stack result-rep + arg2 'stack result-rep) + (emit (case result-rep + (:int 'imul) + (:long 'lmul) + (:float 'fmul) + (:double 'dmul) + (t + (sys::format t "p2-times: unsupported rep case")))) + (convert-representation result-rep representation) + (emit-move-from-stack target representation)) + ((fixnump arg2) +;; (format t "p2-times case 3~%") + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit-push-int arg2) + (emit-invokevirtual +lisp-object-class+ "multiplyBy" '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + (t + (dformat t "p2-times case 4~%") + (compile-binary-operation "multiplyBy" args target representation))))) + (t + (dformat t "p2-times case 5~%") + (p2-times `(,(car form) (,(car form) ,(second form) ,(third form)) + ,@(nthcdr 3 form)) target representation)))) + +(defknown p2-min/max (t t t) t) +(defun p2-min/max (form target representation) + (case (length form) + (1 (error 'program-error "Wrong number of arguments for ~A." (car form))) + (2 (compile-form (cadr form) target representation)) + (3 (let* ((op (%car form)) + (args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args))) + (when (null target) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 nil nil) + (return-from p2-min/max)) + (when (notinline-p op) + (compile-function-call form target representation) + (return-from p2-min/max)) + (let ((type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (java-long-type-p type1) (java-long-type-p type2)) + (let ((common-rep (if (and (fixnum-type-p type1) + (fixnum-type-p type2)) + :int :long)) + (LABEL1 (gensym))) + (compile-form arg1 'stack common-rep) + (emit-dup common-rep) + (compile-form arg2 'stack common-rep) + (emit-dup common-rep :past common-rep) + (emit-numeric-comparison (if (eq op 'max) '<= '>=) + common-rep LABEL1) + (emit-swap common-rep common-rep) + (label LABEL1) + (emit-move-from-stack nil common-rep) + (convert-representation common-rep representation) + (emit-move-from-stack target representation))) + (t + (compile-form arg1 'stack nil) + (emit-dup nil) + (compile-form arg2 'stack nil) + (emit-dup nil :past nil) + (emit-invokevirtual +lisp-object-class+ + (if (eq op 'max) + "isLessThanOrEqualTo" + "isGreaterThanOrEqualTo") + (lisp-object-arg-types 1) "Z") + (let ((LABEL1 (gensym))) + (emit 'ifeq LABEL1) + (emit 'swap) + (label LABEL1) + (emit 'pop)) + (fix-boxing representation nil) + (emit-move-from-stack target representation)))))) + (t + (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form)) + ,@(nthcdr 3 form)) target representation)))) + +(defun p2-plus (form target representation) + (case (length form) + (1 + (compile-constant 0 target representation)) + (2 + (compile-form (cadr form) target representation)) + (3 + (let* ((args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2)) + (result-type (derive-compiler-type form)) + (result-rep (type-representation result-type))) +;; (let ((*print-structure* nil)) +;; (format t "~&p2-plus arg1 = ~S~%" arg1) +;; (format t "p2-plus arg2 = ~S~%" arg2)) +;; (format t "~&p2-plus type1 = ~S~%" type1) +;; (format t "p2-plus type2 = ~S~%" type2) +;; (format t "p2-plus result-type = ~S~%" result-type) +;; (format t "p2-plus result-rep = ~S~%" result-rep) +;; (format t "p2-plus representation = ~S~%" representation) + (cond ((and (numberp arg1) (numberp arg2)) + (compile-constant (+ arg1 arg2) target representation)) + ((and (numberp arg1) (eql arg1 0)) + (compile-forms-and-maybe-emit-clear-values arg1 nil nil + arg2 'stack representation) + (emit-move-from-stack target representation)) + ((and (numberp arg2) (eql arg2 0)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack representation + arg2 nil nil) + (emit-move-from-stack target representation)) + (result-rep + (compile-forms-and-maybe-emit-clear-values + arg1 'stack result-rep + arg2 'stack result-rep) + (emit (case result-rep + (:int 'iadd) + (:long 'ladd) + (:float 'fadd) + (:double 'dadd) + (t + (sys::format + t "p2-plus: Unexpected result-rep ~S for form ~S." + result-rep form) + (assert nil)))) + (convert-representation result-rep representation) + (emit-move-from-stack target representation)) + ((eql arg2 1) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit-invoke-method "incr" target representation)) + ((eql arg1 1) + (compile-forms-and-maybe-emit-clear-values arg2 'stack nil) + (emit-invoke-method "incr" target representation)) + ((or (fixnum-type-p type1) (fixnum-type-p type2)) + (compile-forms-and-maybe-emit-clear-values + arg1 'stack (when (fixnum-type-p type1) :int) + arg2 'stack (when (null (fixnum-type-p type1)) :int)) + (when (fixnum-type-p type1) + (emit 'swap)) + (emit-invokevirtual +lisp-object-class+ "add" + '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + (t + (compile-binary-operation "add" args target representation))))) + (t + ;; (+ a b c) => (+ (+ a b) c) + (let ((new-form `(+ (+ ,(second form) ,(third form)) ,@(nthcdr 3 form)))) + (p2-plus new-form target representation))))) + +(defun p2-minus (form target representation) + (case (length form) + (1 + ;; generates "Insufficient arguments" error + (compile-function-call form target representation)) + (2 + (let* ((arg (%cadr form)) + (type (derive-compiler-type form)) + (type-rep (type-representation type))) + (cond ((numberp arg) + (compile-constant (- arg) 'stack representation) + (emit-move-from-stack target representation)) + (type-rep + (compile-form arg 'stack type-rep) + (emit (case type-rep + (:int 'ineg) + (:long 'lneg) + (:float 'fneg) + (:double 'dneg) + (t + (sys::format t + "p2-minus: unsupported rep (~S) for '~S'~%" + type-rep form) + (assert nil)))) + (convert-representation type-rep representation) + (emit-move-from-stack target representation)) + (t + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invokevirtual +lisp-object-class+ "negate" + nil +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))))) + (3 + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (type2 (derive-compiler-type arg2)) + (result-type (derive-compiler-type form)) + (result-rep (type-representation result-type))) + (cond ((and (numberp arg1) (numberp arg2)) + (compile-constant (- arg1 arg2) target representation)) + (result-rep + (compile-forms-and-maybe-emit-clear-values + arg1 'stack result-rep + arg2 'stack result-rep) + (emit (case result-rep + (:int 'isub) + (:long 'lsub) + (:float 'fsub) + (:double 'dsub) + (t + (sys::%format t "p2-minus sub-instruction (rep: ~S); form: ~S~%" + result-rep form) + (assert nil)))) + (convert-representation result-rep representation) + (emit-move-from-stack target representation)) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values + arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ + "subtract" + '("I") +lisp-object+) + (fix-boxing representation result-type) + (emit-move-from-stack target representation)) + (t + (compile-binary-operation "subtract" args target representation))))) + (t + (let ((new-form `(- (- ,(second form) ,(third form)) ,@(nthcdr 3 form)))) + (p2-minus new-form target representation))))) + +;; char/schar string index => character +(defknown p2-char/schar (t t t) t) +(define-inlined-function p2-char/schar (form target representation) + ((check-arg-count form 2)) + (let* ((op (%car form)) + (args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2))) + (cond ((and (eq representation :char) + (zerop *safety*)) + (compile-form arg1 'stack nil) + (emit 'checkcast +lisp-abstract-string-class+) + (compile-form arg2 'stack :int) + (maybe-emit-clear-values arg1 arg2) + (emit-invokevirtual +lisp-abstract-string-class+ "charAt" + '("I") "C") + (emit-move-from-stack target representation)) + ((and (eq representation :char) + (or (eq op 'CHAR) (< *safety* 3)) + (compiler-subtypep type1 'STRING) + (fixnum-type-p type2)) + (compile-form arg1 'stack nil) + (emit 'checkcast +lisp-abstract-string-class+) + (compile-form arg2 'stack :int) + (maybe-emit-clear-values arg1 arg2) + (emit-invokevirtual +lisp-abstract-string-class+ "charAt" + '("I") "C") + (emit-move-from-stack target representation)) + ((fixnum-type-p type2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ + (symbol-name op) ;; "CHAR" or "SCHAR" + '("I") +lisp-object+) + (when (eq representation :char) + (emit-unbox-character)) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +;; set-char/schar string index character => character +(defknown p2-set-char/schar (t t t) t) +(define-inlined-function p2-set-char/schar (form target representation) + ((check-arg-count form 3)) + (let* ((op (%car form)) + (args (%cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (arg3 (third args)) + (type1 (derive-compiler-type arg1)) + (type2 (derive-compiler-type arg2)) + (type3 (derive-compiler-type arg3))) +;; (format t "p2-set-char/schar type1 = ~S~%" type1) +;; (format t "p2-set-char/schar type2 = ~S~%" type2) +;; (format t "p2-set-char/schar type3 = ~S~%" type3) + (cond ((and (< *safety* 3) + (or (null representation) (eq representation :char)) + (compiler-subtypep type1 'STRING) + (fixnum-type-p type2) + (compiler-subtypep type3 'CHARACTER)) + (let* ((*register* *register*) + (value-register (when target (allocate-register))) + (class (if (eq op 'SCHAR) + +lisp-simple-string-class+ + +lisp-abstract-string-class+))) + (compile-form arg1 'stack nil) + (emit 'checkcast class) + (compile-form arg2 'stack :int) + (compile-form arg3 'stack :char) + (when target + (emit 'dup) + (emit-move-from-stack value-register :char)) + (maybe-emit-clear-values arg1 arg2 arg3) + (emit-invokevirtual class "setCharAt" '("I" "C") nil) + (when target + (emit 'iload value-register) + (convert-representation :char representation) + (emit-move-from-stack target representation)))) + (t +;; (format t "p2-set-char/schar not optimized~%") + (compile-function-call form target representation))))) + + +(defun p2-svref (form target representation) + (cond ((and (check-arg-count form 2) + (neq representation :char)) ; FIXME + (let ((arg1 (%cadr form)) + (arg2 (%caddr form))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "SVREF" '("I") +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +(defun p2-svset (form target representation) + (cond ((check-arg-count form 3) + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (arg3 (fourth form)) + (*register* *register*) + (value-register (when target (allocate-register)))) + (compile-form arg1 'stack nil) ;; vector + (compile-form arg2 'stack :int) ;; index + (compile-form arg3 'stack nil) ;; new value + (when value-register + (emit 'dup) + (emit-move-from-stack value-register nil)) + (maybe-emit-clear-values arg1 arg2 arg3) + (emit-invokevirtual +lisp-object-class+ "svset" (list "I" +lisp-object+) nil) + (when value-register + (aload value-register) + (emit-move-from-stack target nil)))) + (t + (compile-function-call form target representation)))) + +(defun p2-truncate (form target representation) + (let ((args (cdr form)) + arg1 + arg2) + (case (length args) + (1 + (setf arg1 (%car args) + arg2 1)) + (2 + (setf arg1 (%car args) + arg2 (%cadr args))) + (t + (compiler-warn "Wrong number of arguments for ~A (expected 1 or 2, but received ~D)." + 'truncate (length args)) + (compile-function-call form target representation) + (return-from p2-truncate))) + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil) + (emit-invokevirtual +lisp-object-class+ "truncate" (lisp-object-arg-types 1) +lisp-object+) + (fix-boxing representation nil) ; FIXME use derived result type + (emit-move-from-stack target representation))) + +(defun p2-elt (form target representation) + (cond ((and (check-arg-count form 2) + (fixnum-type-p (derive-compiler-type (third form))) + (neq representation :char)) ; FIXME + (compile-form (second form) 'stack nil) + (compile-form (third form) 'stack :int) + (emit-invokevirtual +lisp-object-class+ "elt" '("I") +lisp-object+) + (fix-boxing representation nil) ; FIXME use derived result type + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation)))) + +(defun p2-aref (form target representation) + ;; We only optimize the 2-arg case. + (case (length form) + (3 + (let* ((arg1 (%cadr form)) + (arg2 (%caddr form)) + (type1 (derive-compiler-type arg1))) + (ecase representation + (:int + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "aref" '("I") "I")) + (:long + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "aref_long" '("I") "J")) + (:char + (cond ((compiler-subtypep type1 'string) + (compile-form arg1 'stack nil) ; array + (emit 'checkcast +lisp-abstract-string-class+) + (compile-form arg2 'stack :int) ; index + (maybe-emit-clear-values arg1 arg2) + (emit-invokevirtual +lisp-abstract-string-class+ + "charAt" '("I") "C")) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+) + (emit-unbox-character)))) + ((nil :float :double :boolean) + ;;###FIXME for float and double, we probably want + ;; separate java methods to retrieve the values. + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg2 'stack :int) + (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+) + (convert-representation nil representation))) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +(defun p2-aset (form target representation) + ;; We only optimize the 3-arg case. + (cond ((= (length form) 4) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (arg3 (third args)) + (type3 (derive-compiler-type arg3)) + (*register* *register*) + (value-register (unless (null target) (allocate-register))) +;; (array-derived-type t) + ) + +;; (format t "p2-aset type3 = ~S~%" type3) + +;; (when (symbolp arg1) +;; (let ((variable (find-visible-variable (second form)))) +;; (when variable +;; (setf array-derived-type (derive-type variable))))) + ;; array + (compile-form arg1 'stack nil) + ;; index + (compile-form arg2 'stack :int) + ;; value +;; (cond ((subtypep array-derived-type '(array (unsigned-byte 8))) +;; (compile-form (fourth form) 'stack :int) +;; (when value-register +;; (emit 'dup) +;; (emit-move-from-stack value-register :int))) +;; (t +;; (compile-form (fourth form) 'stack nil) +;; (when value-register +;; (emit 'dup) +;; (emit-move-from-stack value-register nil)))) + (cond ((fixnum-type-p type3) + (compile-form arg3 'stack :int) + (when value-register + (emit 'dup) + (emit-move-from-stack value-register :int))) + (t + (compile-form arg3 'stack nil) + (when value-register + (emit 'dup) + (emit-move-from-stack value-register nil)))) + +;; (unless (and (single-valued-p (second form)) +;; (single-valued-p (third form)) +;; (single-valued-p (fourth form))) +;; (emit-clear-values)) + (maybe-emit-clear-values arg1 arg2 arg3) + + (cond (;;(subtypep array-derived-type '(array (unsigned-byte 8))) + (fixnum-type-p type3) + (emit-invokevirtual +lisp-object-class+ "aset" '("I" "I") nil)) + (t + (emit-invokevirtual +lisp-object-class+ "aset" (list "I" +lisp-object+) nil))) + (when value-register + (cond ((fixnum-type-p type3) + (emit 'iload value-register) + (convert-representation :int representation)) + (t + (aload value-register) + (fix-boxing representation type3))) + (emit-move-from-stack target representation)))) + (t + (compile-function-call form target representation)))) + +(defknown p2-structure-ref (t t t) t) +(define-inlined-function p2-structure-ref (form target representation) + ((check-arg-count form 2)) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args))) + (cond ((and (fixnump arg2) + (null representation)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (case arg2 + (0 + (emit-invokevirtual +lisp-object-class+ "getSlotValue_0" + nil +lisp-object+)) + (1 + (emit-invokevirtual +lisp-object-class+ "getSlotValue_1" + nil +lisp-object+)) + (2 + (emit-invokevirtual +lisp-object-class+ "getSlotValue_2" + nil +lisp-object+)) + (3 + (emit-invokevirtual +lisp-object-class+ "getSlotValue_3" + nil +lisp-object+)) + (t + (emit-push-constant-int arg2) + (emit-invokevirtual +lisp-object-class+ "getSlotValue" + '("I") +lisp-object+))) + (emit-move-from-stack target representation)) + ((fixnump arg2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit-push-constant-int arg2) + (ecase representation + (:int + (emit-invokevirtual +lisp-object-class+ "getFixnumSlotValue" + '("I") "I")) + ((nil :char :long :float :double) + (emit-invokevirtual +lisp-object-class+ "getSlotValue" + '("I") +lisp-object+) + ;; (convert-representation NIL NIL) is a no-op + (convert-representation nil representation)) + (:boolean + (emit-invokevirtual +lisp-object-class+ "getSlotValueAsBoolean" + '("I") "Z"))) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defknown p2-structure-set (t t t) t) +(define-inlined-function p2-structure-set (form target representation) + ((check-arg-count form 3)) + (let* ((args (cdr form)) + (arg1 (first args)) + (arg2 (second args)) + (arg3 (third args))) + (cond ((and (fixnump arg2) + (<= 0 arg2 3)) + (let* ((*register* *register*) + (value-register (when target (allocate-register)))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil + arg3 'stack nil) + (when value-register + (emit 'dup) + (astore value-register)) + (emit-invokevirtual +lisp-object-class+ + (format nil "setSlotValue_~D" arg2) + (lisp-object-arg-types 1) nil) + (when value-register + (aload value-register) + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + ((fixnump arg2) + (let* ((*register* *register*) + (value-register (when target (allocate-register)))) + (compile-form arg1 'stack nil) + (emit-push-constant-int arg2) + (compile-form arg3 'stack nil) + (maybe-emit-clear-values arg1 arg3) + (when value-register + (emit 'dup) + (astore value-register)) + (emit-invokevirtual +lisp-object-class+ "setSlotValue" + (list "I" +lisp-object+) nil) + (when value-register + (aload value-register) + (fix-boxing representation nil) + (emit-move-from-stack target representation)))) + (t + (compile-function-call form target representation))))) + + +(define-inlined-function p2-not/null (form target representation) + ((aver (or (null representation) (eq representation :boolean))) + (check-arg-count form 1)) + (let ((arg (second form))) + (cond ((null arg) + (emit-push-true representation)) + ((node-constant-p arg) + (emit-push-false representation)) + ((and (consp arg) + (memq (%car arg) '(NOT NULL))) + (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil) + (emit-push-nil) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'if_acmpeq LABEL1) + (emit-push-true representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-false representation) + (label LABEL2))) + ((eq representation :boolean) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (emit 'iconst_1) + (emit 'ixor)) + ((eq (derive-compiler-type arg) 'BOOLEAN) + (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'ifeq LABEL1) + (emit-push-nil) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-t) + (label LABEL2))) + (t + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit-push-nil) + (emit 'if_acmpeq LABEL1) + (emit-push-nil) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-t) + (label LABEL2))))) + (emit-move-from-stack target representation)) + +(define-inlined-function p2-nthcdr (form target representation) + ((check-arg-count form 2)) + (let* ((args (%cdr form)) + (arg1 (%car args)) + (arg2 (%cadr args))) + (cond ((fixnum-type-p (derive-compiler-type arg1)) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :int + arg2 'stack nil) + (emit 'swap) + (emit-invokevirtual +lisp-object-class+ "nthcdr" '("I") +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defun p2-and (form target representation) + (aver (or (null representation) (eq representation :boolean))) + (let ((args (cdr form))) + (case (length args) + (0 + (emit-push-true representation) + (emit-move-from-stack target representation)) + (1 + (compile-form (%car args) target representation)) + (2 + (let ((arg1 (%car args)) + (arg2 (%cadr args)) + (FAIL (gensym)) + (DONE (gensym))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :boolean) + (emit 'ifeq FAIL) + (ecase representation + (:boolean + (compile-forms-and-maybe-emit-clear-values arg2 'stack :boolean) + (emit 'goto DONE) + (label FAIL) + (emit 'iconst_0)) + ((nil) + (compile-form arg2 'stack nil) + (emit 'goto DONE) + (label FAIL) + (emit-push-nil))) + (label DONE) + (emit-move-from-stack target representation))) + (t + ;; (and a b c d e f) => (and a (and b c d e f)) + (let ((new-form `(and ,(%car args) (and ,@(%cdr args))))) + (p2-and new-form target representation)))))) + +(defknown p2-or (t t t) t) +(defun p2-or (form target representation) + (let ((args (cdr form))) + (case (length args) + (0 + (emit-push-false representation) + (emit-move-from-stack target representation)) + (1 + (compile-form (%car args) target representation)) + (2 + (let ((arg1 (%car args)) + (arg2 (%cadr args)) + (LABEL1 (gensym)) + (LABEL2 (gensym))) + (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) + (emit 'dup) + (emit-push-nil) + (emit 'if_acmpne LABEL1) + (emit 'pop) + (compile-form arg2 'stack representation) + (emit 'goto LABEL2) + (label LABEL1) + (fix-boxing representation nil) ; FIXME use derived result type + (label LABEL2) + (emit-move-from-stack target representation))) + (t + ;; (or a b c d e f) => (or a (or b c d e f)) + (let ((new-form `(or ,(%car args) (or ,@(%cdr args))))) + (p2-or new-form target representation)))))) + +(defun p2-values (form target representation) + (let* ((args (cdr form)) + (len (length args))) + (case len + (0 + (emit-push-current-thread) + (emit-invokevirtual +lisp-thread-class+ "setValues" nil +lisp-object+) + (emit-move-from-stack target)) + (1 + (let ((arg (%car args))) + (compile-forms-and-maybe-emit-clear-values arg target representation))) + (2 + (emit-push-current-thread) + (let ((arg1 (%car args)) + (arg2 (%cadr args))) + (cond ((and (eq arg1 t) + (eq arg2 t)) + (emit-push-t) + (emit 'dup)) + ((and (eq arg1 nil) + (eq arg2 nil)) + (emit-push-nil) + (emit 'dup)) + (t + (compile-form arg1 'stack nil) + (compile-form arg2 'stack nil)))) + (emit-invokevirtual +lisp-thread-class+ + "setValues" + (lisp-object-arg-types len) + +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target)) + ((3 4) + (emit-push-current-thread) + (dolist (arg args) + (compile-form arg 'stack nil)) + (emit-invokevirtual +lisp-thread-class+ + "setValues" + (lisp-object-arg-types len) + +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target)) + (t + (compile-function-call form target representation))))) + +(defun compile-special-reference (name target representation) + (when (constantp name) + (let ((value (symbol-value name))) + (when (or (null *compile-file-truename*) + (stringp value) + (numberp value) + (packagep value)) + (compile-constant value target representation) + (return-from compile-special-reference)))) + (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+) + (cond ((constantp name) + ;; "... a reference to a symbol declared with DEFCONSTANT always + ;; refers to its global value." + (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue" + nil +lisp-object+)) + (t + (emit-push-current-thread) + (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (list +lisp-thread+) +lisp-object+))) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + +(defknown compile-var-ref (t t t) t) +(defun compile-var-ref (ref target representation) + (when target + (if (var-ref-constant-p ref) + (compile-constant (var-ref-constant-value ref) target representation) + (let ((variable (var-ref-variable ref))) + (cond ((variable-special-p variable) + (compile-special-reference (variable-name variable) target representation)) + ((or (variable-representation variable) + (variable-register variable) + (variable-closure-index variable) + (variable-index variable)) + (emit-push-variable variable) + (convert-representation (variable-representation variable) + representation) + (emit-move-from-stack target representation)) + (t + (sys::%format t "compile-var-ref general case~%") + (aver nil))))))) + +(defun p2-set (form target representation) + (cond ((and (check-arg-count form 2) + (eq (derive-type (%cadr form)) 'SYMBOL)) + (emit-push-current-thread) + (compile-form (%cadr form) 'stack nil) + (emit 'checkcast +lisp-symbol-class+) + (compile-form (%caddr form) 'stack nil) + (maybe-emit-clear-values (%cadr form) (%caddr form)) + (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" + (list +lisp-symbol+ +lisp-object+) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation)))) + +(declaim (ftype (function (t) t) rewrite-setq)) +(defun rewrite-setq (form) + (let ((expr (%caddr form))) + (if (unsafe-p expr) + (let ((sym (gensym))) + (list 'LET (list (list sym expr)) (list 'SETQ (%cadr form) sym))) + form))) + +(defknown p2-setq (t t t) t) +(defun p2-setq (form target representation) + (unless (= (length form) 3) + (return-from p2-setq (compile-form (precompiler::precompile-setq form) + target representation))) + (let ((expansion (macroexpand (%cadr form) *compile-file-environment*))) + (unless (eq expansion (%cadr form)) + (compile-form (list 'SETF expansion (%caddr form)) target representation) + (return-from p2-setq))) + (let* ((name (%cadr form)) + (variable (find-visible-variable name)) + (value-form (%caddr form))) + (when (or (null variable) + (variable-special-p variable)) + (let ((new-form (rewrite-setq form))) + (when (neq new-form form) + (return-from p2-setq (compile-form (p1 new-form) target representation)))) + ;; We're setting a special variable. + (emit-push-current-thread) + (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+) +;; (let ((*print-structure* nil)) +;; (format t "p2-setq name = ~S value-form = ~S~%" name value-form)) + (cond ((and (consp value-form) + (eq (first value-form) 'CONS) + (= (length value-form) 3) + (var-ref-p (third value-form)) + (eq (variable-name (var-ref-variable (third value-form))) name)) + ;; (push thing *special*) => (setq *special* (cons thing *special*)) +;; (format t "compiling pushSpecial~%") + (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) + (emit-invokevirtual +lisp-thread-class+ "pushSpecial" + (list +lisp-symbol+ +lisp-object+) +lisp-object+)) + (t + (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) + (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" + (list +lisp-symbol+ +lisp-object+) +lisp-object+))) + (fix-boxing representation nil) + (emit-move-from-stack target representation) + (return-from p2-setq)) + + (when (zerop (variable-reads variable)) + ;; If we never read the variable, we don't have to set it. + (cond (target + (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-form value-form nil nil))) + (return-from p2-setq)) + + ;; Optimize the (INCF X) case. + (let ((incf-p nil)) + (when (and (eq (variable-representation variable) :int) + (consp value-form)) + (let ((op (car value-form)) + (len (length value-form))) + (case op + (1+ + (when (= len 2) + (let ((arg (cadr value-form))) + (when (and (var-ref-p arg) (eq (var-ref-variable arg) variable)) + (setf incf-p t))))) + (+ + (when (= len 3) + (let ((arg1 (second value-form)) + (arg2 (third value-form))) + (when (eql arg1 1) + (setf arg1 arg2 arg2 1)) ;; (+ 1 X) => (+ X 1) + (when (eql arg2 1) + (when (and (var-ref-p arg1) (eq (var-ref-variable arg1) variable)) + (setf incf-p t))))))))) + (when incf-p + (aver (variable-register variable)) + (emit 'iinc (variable-register variable) 1) + (when target + (emit 'iload (variable-register variable)) + (convert-representation :int representation) + (emit-move-from-stack target representation)) + (return-from p2-setq))) + + (cond ((and (eq (variable-representation variable) :int) + (or (equal value-form (list '1+ (variable-name variable))) + (equal value-form (list '+ (variable-name variable) 1)) + (equal value-form (list '+ 1 (variable-name variable))))) + ;; FIXME This is the old (INCF X) case. We should be able to remove + ;; this case once the new code is stable. + (emit 'iinc (variable-register variable) 1) + (when target + (convert-representation :int representation) + (emit-move-from-stack target representation))) + ((and (eq (variable-representation variable) :int) + (or (equal value-form (list '1- (variable-name variable))) + (equal value-form (list '- (variable-name variable) 1)))) + (dformat t "p2-setq decf :int case~%") + (emit 'iinc (variable-register variable) -1) + (when target + (convert-representation :int representation) + (emit-move-from-stack target representation))) + (t + (let ((rep (variable-representation variable))) + (dformat t "p2-setq ~A case value-form = ~S~%" rep value-form) + (compile-forms-and-maybe-emit-clear-values value-form 'stack rep) + (when target + (emit-dup rep)) + (emit-move-to-variable variable) + (when target + (convert-representation rep representation) + (emit-move-from-stack target representation))))))) + +(defun p2-sxhash (form target representation) + (cond ((check-arg-count form 1) + (let ((arg (%cadr form))) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit-invokevirtual +lisp-object-class+ "sxhash" nil "I") + (convert-representation :int representation) + (emit-move-from-stack target representation))) + (t + (compile-function-call form target representation)))) + +(defknown p2-symbol-name (t t t) t) +(define-inlined-function p2-symbol-name (form target representation) + ((check-arg-count form 1)) + (let ((arg (%cadr form))) + (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit 'checkcast +lisp-symbol-class+) + (emit 'getfield +lisp-symbol-class+ "name" +lisp-simple-string+) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defknown p2-symbol-package (t t t) t) +(define-inlined-function p2-symbol-package (form target representation) + ((check-arg-count form 1)) + (let ((arg (%cadr form))) + (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3)) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit 'checkcast +lisp-symbol-class+) + (emit-invokevirtual +lisp-symbol-class+ "getPackage" + nil +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defknown p2-symbol-value (t t t) t) +(defun p2-symbol-value (form target representation) + (when (check-arg-count form 1) + (let ((arg (%cadr form))) + (when (eq (derive-compiler-type arg) 'SYMBOL) + (compile-forms-and-maybe-emit-clear-values arg 'stack nil) + (emit 'checkcast +lisp-symbol-class+) + (emit-push-current-thread) + (emit-invokevirtual +lisp-symbol-class+ "symbolValue" + (list +lisp-thread+) +lisp-object+) + (fix-boxing representation nil) + (emit-move-from-stack target representation) + (return-from p2-symbol-value)))) + ;; Otherwise... + (compile-function-call form target representation)) + +(defknown generate-instanceof-type-check-for-value (t) t) +(defun generate-instanceof-type-check-for-value (expected-type) + ;; The value to be checked is on the stack. + (declare (type symbol expected-type)) + (let ((instanceof-class (ecase expected-type + (SYMBOL +lisp-symbol-class+) + (CHARACTER +lisp-character-class+) + (CONS +lisp-cons-class+) + (HASH-TABLE +lisp-hash-table-class+) + (FIXNUM +lisp-fixnum-class+) + (STREAM +lisp-stream-class+) + (STRING +lisp-abstract-string-class+) + (VECTOR +lisp-abstract-vector-class+))) + (expected-type-java-symbol-name (case expected-type + (HASH-TABLE "HASH_TABLE") + (t + (symbol-name expected-type)))) + (LABEL1 (gensym))) + (emit 'dup) + (emit 'instanceof instanceof-class) + (emit 'ifne LABEL1) + (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+) + (emit-invokestatic +lisp-class+ "type_error" + (lisp-object-arg-types 2) +lisp-object+) + (label LABEL1)) + t) + +(declaim (ftype (function (t) t) generate-type-check-for-value)) +(defun generate-type-check-for-value (declared-type) + (let ((type-to-use (find-type-for-type-check declared-type))) + (when type-to-use + (generate-instanceof-type-check-for-value type-to-use)))) + +(defun p2-the (form target representation) + (let ((type-form (second form)) + (value-form (third form))) +;; (let ((*print-structure* nil)) +;; (format t "p2-the type-form = ~S value-form = ~S~%" type-form value-form)) + (cond ((and (subtypep type-form 'FIXNUM) + (consp value-form) + (eq (car value-form) 'structure-ref)) + ;; Special case for structure slot references: getFixnumSlotValue() + ;; signals an error if the slot's value is not a fixnum. + (compile-form value-form target representation)) + ((and (> *safety* 0) + (not (compiler-subtypep (derive-type value-form) type-form))) + (compile-form value-form 'stack nil) + (generate-type-check-for-value type-form) + ;; The value is left on the stack here if the type check succeeded. + (fix-boxing representation nil) + (emit-move-from-stack target representation)) + (t + (compile-form value-form target representation))))) + +(defun p2-truly-the (form target representation) + (compile-form (third form) target representation)) + +(defknown p2-char-code (t t t) t) +(define-inlined-function p2-char-code (form target representation) + ((check-arg-count form 1)) + (let ((arg (second form))) + (cond ((characterp arg) + (compile-constant (char-code arg) target representation)) + ((and (< *safety* 3) + (eq (derive-compiler-type arg) 'character)) + (compile-form arg 'stack :char) + ;; we change the representation between the above and here + ;; ON PURPOSE! + (convert-representation :int representation) + (emit-move-from-stack target representation)) + (t + (compile-function-call form target representation))))) + +(defknown p2-java-jclass (t t t) t) +(define-inlined-function p2-java-jclass (form target representation) + ((and (= 2 (length form)) + (stringp (cadr form)))) + (let ((c (ignore-errors (java:jclass (cadr form))))) + (if c (compile-constant c target representation) + ;; delay resolving the method to run-time; it's unavailable now + (compile-function-call form target representation)))) + +(defknown p2-java-jconstructor (t t t) t) +(define-inlined-function p2-java-jconstructor (form target representation) + ((and (< 1 (length form)) + (every #'stringp (cdr form)))) + (let ((c (ignore-errors (apply #'java:jconstructor (cdr form))))) + (if c (compile-constant c target representation) + ;; delay resolving the method to run-time; it's unavailable now + (compile-function-call form target representation)))) + +(defknown p2-java-jmethod (t t t) t) +(define-inlined-function p2-java-jmethod (form target representation) + ((and (< 1 (length form)) + (every #'stringp (cdr form)))) + (let ((m (ignore-errors (apply #'java:jmethod (cdr form))))) + (if m (compile-constant m target representation) + ;; 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) + (let* ((args (cdr form)) + (numargs (length args))) + (when (= numargs 0) + (compiler-warn "Wrong number of arguments for ~A." (car form)) + (compile-function-call form target representation) + (return-from p2-char=)) + (unless (= numargs 2) + (compile-function-call form target representation) + (return-from p2-char=)) + (let ((arg1 (%car args)) + (arg2 (%cadr args))) + (when (and (characterp arg1) (characterp arg2)) + (cond ((eql arg1 arg2) + (emit-push-true representation)) + (t + (emit-push-false representation))) + (emit-move-from-stack target representation) + (return-from p2-char=)) + (cond ((characterp arg1) + (emit-push-constant-int (char-code arg1)) + (compile-forms-and-maybe-emit-clear-values arg2 'stack :char)) + ((characterp arg2) + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char) + (emit-push-constant-int (char-code arg2))) + (t + (compile-forms-and-maybe-emit-clear-values arg1 'stack :char + arg2 'stack :char))) + (let ((LABEL1 (gensym)) + (LABEL2 (gensym))) + (emit 'if_icmpeq LABEL1) + (emit-push-false representation) + (emit 'goto LABEL2) + (label LABEL1) + (emit-push-true representation) + (label LABEL2) + (emit-move-from-stack target representation))))) + +(defknown p2-catch-node (t t) t) +(defun p2-catch-node (block target) + (let ((form (block-form block))) + (when (= (length form) 2) ; (catch 'foo) + (when target + (emit-push-nil) + (emit-move-from-stack target)) + (return-from p2-catch-node)) + (let* ((*register* *register*) + (tag-register (allocate-register)) + (BEGIN-PROTECTED-RANGE (gensym)) + (END-PROTECTED-RANGE (gensym)) + (THROW-HANDLER (gensym)) + (DEFAULT-HANDLER (gensym)) + (EXIT (gensym))) + (compile-form (second form) tag-register nil) ; Tag. + (emit-push-current-thread) + (aload tag-register) + (emit-invokevirtual +lisp-thread-class+ "pushCatchTag" + (lisp-object-arg-types 1) nil) + ; Stack depth is 0. + (label BEGIN-PROTECTED-RANGE) ; Start of protected range. + (compile-progn-body (cddr form) target) ; Implicit PROGN. + (label END-PROTECTED-RANGE) ; End of protected range. + (emit 'goto EXIT) ; Jump over handlers. + (label THROW-HANDLER) ; Start of handler for THROW. + ;; The Throw object is on the runtime stack. Stack depth is 1. + (emit 'dup) ; Stack depth is 2. + (emit 'getfield +lisp-throw-class+ "tag" +lisp-object+) ; Still 2. + (aload tag-register) ; Stack depth is 3. + ;; If it's not the tag we're looking for, we branch to the start of the + ;; catch-all handler, which will do a re-throw. + (emit 'if_acmpne DEFAULT-HANDLER) ; Stack depth is 1. + (aload *thread*) + (emit-invokevirtual +lisp-throw-class+ "getResult" + (list +lisp-thread+) +lisp-object+) + (emit-move-from-stack target) ; Stack depth is 0. + (emit 'goto EXIT) + (label DEFAULT-HANDLER) ; Start of handler for all other Throwables. + ;; A Throwable object is on the runtime stack here. Stack depth is 1. + (aload *thread*) + (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) + (emit 'athrow) ; Re-throw. + (label EXIT) + ;; Finally... + (aload *thread*) + (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil) + (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE + :to END-PROTECTED-RANGE + :code THROW-HANDLER + :catch-type (pool-class +lisp-throw-class+))) + (handler2 (make-handler :from BEGIN-PROTECTED-RANGE + :to END-PROTECTED-RANGE + :code DEFAULT-HANDLER + :catch-type 0))) + (push handler1 *handlers*) + (push handler2 *handlers*)))) + t) + +(defun p2-throw (form target representation) + ;; FIXME What if we're called with a non-NIL representation? + (declare (ignore representation)) + (emit-push-current-thread) + (compile-form (second form) 'stack nil) ; Tag. + (emit-clear-values) ; Do this unconditionally! (MISC.503) + (compile-form (third form) 'stack nil) ; Result. + (emit-invokevirtual +lisp-thread-class+ "throwToTag" + (lisp-object-arg-types 2) nil) + ;; Following code will not be reached. + (when target + (emit-push-nil) + (emit-move-from-stack target))) + +(defun p2-unwind-protect-node (block target) + (let ((form (block-form block))) + (when (= (length form) 2) ; No cleanup form. + (compile-form (second form) target nil) + (return-from p2-unwind-protect-node)) + (let* ((protected-form (cadr form)) + (cleanup-forms (cddr form)) + (*register* *register*) + (exception-register (allocate-register)) + (result-register (allocate-register)) + (values-register (allocate-register)) + (return-address-register (allocate-register)) + (BEGIN-PROTECTED-RANGE (gensym)) + (END-PROTECTED-RANGE (gensym)) + (HANDLER (gensym)) + (EXIT (gensym)) + (CLEANUP (gensym))) + ;; Make sure there are no leftover multiple return values from previous calls. + (emit-clear-values) + + (let* ((*blocks* (cons block *blocks*))) + (label BEGIN-PROTECTED-RANGE) + (compile-form protected-form result-register nil) + (emit-push-current-thread) + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) + (astore values-register) + (label END-PROTECTED-RANGE)) + (emit 'jsr CLEANUP) + (emit 'goto EXIT) ; Jump over handler. + (label HANDLER) ; Start of exception handler. + ;; The Throwable object is on the runtime stack. Stack depth is 1. + (astore exception-register) + (emit 'jsr CLEANUP) ; Call cleanup forms. + (emit-clear-values) + (aload exception-register) + (emit 'athrow) ; Re-throw exception. + (label CLEANUP) ; Cleanup forms. + ;; Return address is on stack here. + (astore return-address-register) + (dolist (subform cleanup-forms) + (compile-form subform nil nil)) + (emit 'ret return-address-register) + (label EXIT) + ;; Restore multiple values returned by protected form. + (emit-push-current-thread) + (aload values-register) + (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) + ;; Result. + (aload result-register) + (emit-move-from-stack target) + (let ((handler (make-handler :from BEGIN-PROTECTED-RANGE + :to END-PROTECTED-RANGE + :code HANDLER + :catch-type 0))) + (push handler *handlers*))))) + +(defknown compile-form (t t t) t) +(defun compile-form (form target representation) + (cond ((consp form) + (let* ((op (%car form)) + (handler (and (symbolp op) (get op 'p2-handler)))) + (cond (handler + (funcall handler form target representation)) + ((symbolp op) + (cond ((macro-function op *compile-file-environment*) + (compile-form (macroexpand form *compile-file-environment*) + target representation)) + ((special-operator-p op) + (dformat t "form = ~S~%" form) + (compiler-unsupported + "COMPILE-FORM: unsupported special operator ~S" op)) + (t + (compile-function-call form target representation)))) + ((and (consp op) (eq (%car op) 'LAMBDA)) + (aver (progn 'unexpected-lambda nil)) + (let ((new-form (list* 'FUNCALL form))) + (compile-form new-form target representation))) + (t + (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))))) + ((symbolp form) + (cond ((null form) + (emit-push-false representation) + (emit-move-from-stack target representation)) + ((eq form t) + (emit-push-true representation) + (emit-move-from-stack target representation)) + ((keywordp form) + (ecase representation + (:boolean + (emit 'iconst_1)) + ((nil) + (let ((name (lookup-known-keyword form))) + (if name + (emit 'getstatic "org/armedbear/lisp/Keyword" name +lisp-symbol+) + (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+))))) + (emit-move-from-stack target representation)) + (t + ;; Shouldn't happen. + (aver nil)))) + ((var-ref-p form) + (compile-var-ref form target representation)) + ((block-node-p form) + (cond ((equal (block-name form) '(TAGBODY)) + (p2-tagbody-node form target) + (fix-boxing representation nil) + ) + ((equal (block-name form) '(LET)) + (p2-let/let*-node form target representation) +;; (fix-boxing representation nil) + ) + ((equal (block-name form) '(MULTIPLE-VALUE-BIND)) + (p2-m-v-b-node form target) + (fix-boxing representation nil) + ) + ((equal (block-name form) '(UNWIND-PROTECT)) + (p2-unwind-protect-node form target) + (fix-boxing representation nil) + ) + ((equal (block-name form) '(CATCH)) + (p2-catch-node form target) + (fix-boxing representation nil) + ) + (t + (p2-block-node form target representation) +;; (fix-boxing representation nil) + )) +;; (fix-boxing representation nil) + ) + ((constantp form) + (compile-constant form target representation)) + (t + (compiler-unsupported "COMPILE-FORM unhandled case ~S" form))) + t) + + + +;; Returns descriptor. +(defun analyze-args (compiland) + (let* ((args (cadr (compiland-p1-result compiland))) + (arg-count (length args))) + (dformat t "analyze-args args = ~S~%" args) + (aver (not (memq '&AUX args))) + + (when *child-p* + (when (or (memq '&KEY args) + (memq '&OPTIONAL args) + (memq '&REST args)) + (setf *using-arg-array* t) + (setf *hairy-arglist-p* t) + (return-from analyze-args + (if *closure-variables* + (get-descriptor (list +lisp-object-array+ +lisp-object-array+) + +lisp-object+) + (get-descriptor (list +lisp-object-array+) + +lisp-object+)))) + (cond (*closure-variables* + (return-from analyze-args + (cond ((<= arg-count call-registers-limit) + (get-descriptor (list* +lisp-object-array+ + (lisp-object-arg-types arg-count)) + +lisp-object+)) + (t (setf *using-arg-array* t) + (setf (compiland-arity compiland) arg-count) + (get-descriptor (list +lisp-object-array+ +lisp-object-array+) ;; FIXME + +lisp-object+))))) + (t + (return-from analyze-args + (cond ((<= arg-count call-registers-limit) + (get-descriptor (lisp-object-arg-types arg-count) + +lisp-object+)) + (t (setf *using-arg-array* t) + (setf (compiland-arity compiland) arg-count) + (get-descriptor (list +lisp-object-array+) + +lisp-object+))))))) ;; FIXME + (when (or (memq '&KEY args) + (memq '&OPTIONAL args) + (memq '&REST args)) + (setf *using-arg-array* t) + (setf *hairy-arglist-p* t) + (return-from analyze-args + (get-descriptor (list +lisp-object-array+) +lisp-object+))) + (cond ((<= arg-count call-registers-limit) + (get-descriptor (lisp-object-arg-types (length args)) + +lisp-object+)) + (t + (setf *using-arg-array* t) + (setf (compiland-arity compiland) arg-count) + (get-descriptor (list +lisp-object-array+) +lisp-object+))))) + +(defun write-class-file (class-file) + (let* ((super (class-file-superclass class-file)) + (this-index (pool-class (class-file-class class-file))) + (super-index (pool-class super)) + (constructor (make-constructor super + (class-file-lambda-name class-file) + (class-file-lambda-list class-file)))) + (pool-name "Code") ; Must be in pool! + + (when *compile-file-truename* + (pool-name "SourceFile") ; Must be in pool! + (pool-name (file-namestring *compile-file-truename*))) + (when (and (boundp '*source-line-number*) + (fixnump *source-line-number*)) + (pool-name "LineNumberTable")) ; Must be in pool! + + ;; Write out the class file. + (with-open-file (stream (class-file-pathname class-file) + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (write-u4 #xCAFEBABE stream) + (write-u2 3 stream) + (write-u2 45 stream) + (write-constant-pool stream) + ;; access flags + (write-u2 #x21 stream) + (write-u2 this-index stream) + (write-u2 super-index stream) + ;; interfaces count + (write-u2 0 stream) + ;; fields count + (write-u2 (length *fields*) stream) + ;; fields + (dolist (field *fields*) + (write-field field stream)) + ;; methods count + (write-u2 (1+ (length (class-file-methods class-file))) stream) + ;; methods + (dolist (method (class-file-methods class-file)) + (write-method method stream)) + (write-method constructor stream) + ;; attributes count + (cond (*compile-file-truename* + ;; attributes count + (write-u2 1 stream) + ;; attributes table + (write-source-file-attr (file-namestring *compile-file-truename*) + stream)) + (t + ;; attributes count + (write-u2 0 stream)))))) + +(defun compile-xep (xep) + (declare (type compiland xep)) + (let ((*all-variables* ()) + (*closure-variables* ()) + (*current-compiland* xep) + (*speed* 3) + (*safety* 0) + (*debug* 0)) + + (aver (not (null (compiland-class-file xep)))) + + ;; Pass 1. + (p1-compiland xep) +;; (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*)) + (setf *closure-variables* + (remove-if-not #'variable-used-non-locally-p *all-variables*)) + (setf *closure-variables* + (remove-if #'variable-special-p *closure-variables*)) +;; (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*)) + + (when *closure-variables* + (let ((i 0)) + (dolist (var (reverse *closure-variables*)) + (setf (variable-closure-index var) i) + (dformat t "var = ~S closure index = ~S~%" (variable-name var) + (variable-closure-index var)) + (incf i)))) + + ;; Pass 2. + (with-class-file (compiland-class-file xep) + (p2-compiland xep)))) + + +(defun p2-%call-internal (form target representation) + (dformat t "p2-%call-internal~%") + (aload 0) ; this + (let ((args (cdr form)) + (must-clear-values nil)) + (dformat t "args = ~S~%" args) + (dolist (arg args) + (compile-form arg 'stack nil) + (unless must-clear-values + (unless (single-valued-p arg) + (setf must-clear-values t)))) + (let ((arg-types (lisp-object-arg-types (length args))) + (return-type +lisp-object+)) + (emit-invokevirtual *this-class* "_execute" arg-types return-type)) + (emit-move-from-stack target representation))) + +(defknown p2-compiland-process-type-declarations (list) t) +(defun p2-compiland-process-type-declarations (body) + (flet ((process-declaration (name type) + (let ((variable (find-visible-variable name))) + (when variable + (setf (variable-declared-type variable) type))))) + (dolist (subform body) + (unless (and (consp subform) (eq (%car subform) 'DECLARE)) + (return)) + (let ((decls (%cdr subform))) + (dolist (decl decls) + (case (car decl) + (TYPE + (let ((type (make-compiler-type (cadr decl)))) + (dolist (name (cddr decl)) + (process-declaration name type)))) + ((IGNORE IGNORABLE) + (process-ignore/ignorable (%car decl) (%cdr decl) *visible-variables*)) + ((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE SPECIAL) + ;; Nothing to do here. + ) + (t + (let ((type (make-compiler-type (car decl)))) + (dolist (name (cdr decl)) + (process-declaration name type))))))))) + t) + +(defknown p2-compiland-unbox-variable (variable) t) +(defun p2-compiland-unbox-variable (variable) + (let ((register (variable-register variable))) + (when (and register + (not (variable-special-p variable)) + (not (variable-used-non-locally-p variable)) + (zerop (compiland-children *current-compiland*))) + (when (memq (type-representation (variable-declared-type variable)) + '(:int :long)) + (emit-push-variable variable) +;; (sys::%format t "declared type: ~S~%" (variable-declared-type variable)) + (derive-variable-representation variable nil) +;; (sys::%format t "representation: ~S~%" (variable-representation variable)) + (when (< 1 (representation-size (variable-representation variable))) + (allocate-variable-register variable)) + (convert-representation nil (variable-representation variable)) + (emit-move-to-variable variable)))) + t) + +(defknown p2-compiland (t) t) +(defun p2-compiland (compiland) +;; (format t "p2-compiland name = ~S~%" (compiland-name compiland)) + (let* ((p1-result (compiland-p1-result compiland)) + (class-file (compiland-class-file compiland)) + (*this-class* (class-file-class class-file)) + (args (cadr p1-result)) + (body (cddr p1-result)) + (*using-arg-array* nil) + (*hairy-arglist-p* nil) + + (*child-p* (not (null (compiland-parent compiland)))) + + (descriptor (analyze-args compiland)) + (execute-method-name (if (eq (compiland-kind compiland) :external) + "execute" "_execute")) + (execute-method (make-method :name execute-method-name + :descriptor descriptor)) + (*code* ()) + (*register* 0) + (*registers-allocated* 0) + (*handlers* ()) + (*visible-variables* *visible-variables*) + + (parameters ()) + + (*thread* nil) + (*initialize-thread-var* nil) + (super nil)) + + (unless *child-p* + (when (memq '&REST args) + (unless (or (memq '&OPTIONAL args) (memq '&KEY args)) + (let ((arg-count (length args))) + (when + (cond ((and (= arg-count 2) (eq (%car args) '&REST)) + (setf descriptor (get-descriptor + (lisp-object-arg-types 1) + +lisp-object+) + super "org/armedbear/lisp/Primitive0R" + args (cdr args))) + ((and (= arg-count 3) (eq (%cadr args) '&REST)) + (setf descriptor (get-descriptor + (lisp-object-arg-types 2) + +lisp-object+) + super "org/armedbear/lisp/Primitive1R" + args (list (first args) (third args)))) + ((and (= arg-count 4) (eq (%caddr args) '&REST)) + (setf descriptor (get-descriptor + (list +lisp-object+ + +lisp-object+ +lisp-object+) + +lisp-object+) + super "org/armedbear/lisp/Primitive2R" + args (list (first args) + (second args) (fourth args))))) + (setf *using-arg-array* nil + *hairy-arglist-p* nil + (compiland-kind compiland) :internal + execute-method-name "_execute" + execute-method (make-method + :name execute-method-name + :descriptor descriptor))))))) + + (dolist (var (compiland-arg-vars compiland)) + (push var *visible-variables*)) + + (setf (method-name-index execute-method) + (pool-name (method-name execute-method))) + (setf (method-descriptor-index execute-method) + (pool-name (method-descriptor execute-method))) + (cond (*hairy-arglist-p* + (let* ((closure (make-closure p1-result nil)) + (parameter-names (sys::varlist closure)) + (index 0)) + (dolist (name parameter-names) + (let ((variable (find-visible-variable name))) + (unless variable + (format t "1: unable to find variable ~S~%" name) + (aver nil)) + (aver (null (variable-register variable))) + (aver (null (variable-index variable))) + (setf (variable-index variable) index) + (push variable parameters) + (incf index))))) + (t + (let ((register (if (and *closure-variables* *child-p*) + 2 ; Reg 1 is reserved for closure variables array. + 1)) + (index 0)) + (dolist (arg args) + (let ((variable (find-visible-variable arg))) + (when (null variable) + (format t "2: unable to find variable ~S~%" arg) + (aver nil)) + (aver (null (variable-register variable))) + (setf (variable-register variable) (if *using-arg-array* nil register)) + (aver (null (variable-index variable))) + (if *using-arg-array* + (setf (variable-index variable) index)) + (push variable parameters) + (incf register) + (incf index)))))) + + (let ((specials (process-special-declarations body))) + (dolist (name specials) + (dformat t "recognizing ~S as special~%" name) + (let ((variable (find-visible-variable name))) + (cond ((null variable) + (setf variable (make-variable :name name + :special-p t)) + (push variable *visible-variables*)) + (t + (setf (variable-special-p variable) t)))))) + + (p2-compiland-process-type-declarations body) + + (allocate-register) ;; register 0: "this" pointer + (when (and *closure-variables* *child-p*) + (setf (compiland-closure-register compiland) (allocate-register)) ;; register 1 + (dformat t "p2-compiland 1 closure register = ~S~%" (compiland-closure-register compiland))) + (cond (*using-arg-array* + ;; One slot for arg array. + (setf (compiland-argument-register compiland) (allocate-register)) + + (unless (or *closure-variables* *child-p*) + ;; Reserve a register for each parameter. + (dolist (variable (reverse parameters)) + (aver (null (variable-register variable))) + (aver (null (variable-reserved-register variable))) + (unless (variable-special-p variable) + (setf (variable-reserved-register variable) (allocate-register)))))) + (t + ;; Otherwise, one register for each argument. + (dolist (arg args) + (declare (ignore arg)) + (allocate-register)))) + (when (and *closure-variables* (not *child-p*)) + (setf (compiland-closure-register compiland) (allocate-register)) + (dformat t "p2-compiland 2 closure register = ~S~%" (compiland-closure-register compiland))) + ;; Reserve the next available slot for the thread register. + (setf *thread* (allocate-register)) + + ;; Move args from their original registers to the closure variables array, + ;; if applicable. + (when *closure-variables* + (dformat t "~S moving arguments to closure array (if applicable)~%" + (compiland-name compiland)) + (cond (*child-p* + (aver (eql (compiland-closure-register compiland) 1)) + (when (some #'variable-closure-index parameters) + (aload (compiland-closure-register compiland)))) + (t + (emit-push-constant-int (length *closure-variables*)) + (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland)) + (emit 'anewarray "org/armedbear/lisp/LispObject"))) + (dolist (variable parameters) + (dformat t "considering ~S ...~%" (variable-name variable)) + (when (variable-closure-index variable) + (dformat t "moving variable ~S~%" (variable-name variable)) + (cond ((variable-register variable) + (when (eql (variable-register variable) + (compiland-closure-register compiland)) + (error "ERROR! compiland closure register = ~S var ~S register = ~S~%" + (compiland-closure-register compiland) + (variable-name variable) + (variable-register variable))) + (emit 'dup) ; array + (emit-push-constant-int (variable-closure-index variable)) + (aload (variable-register variable)) + (emit 'aastore) + (setf (variable-register variable) nil)) ; The variable has moved. + ((variable-index variable) + (emit 'dup) ; array + (emit-push-constant-int (variable-closure-index variable)) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (emit 'aastore) + (setf (variable-index variable) nil))))) ; The variable has moved. + (aver (not (null (compiland-closure-register compiland)))) + (cond (*child-p* + (when (some #'variable-closure-index parameters) + (emit 'pop))) + (t + (astore (compiland-closure-register compiland)))) + (dformat t "~S done moving arguments to closure array~%" + (compiland-name compiland))) + + ;; If applicable, move args from arg array to registers. + (when *using-arg-array* + (unless (or *closure-variables* *child-p*) + (dolist (variable (reverse parameters)) + (when (variable-reserved-register variable) + (aver (not (variable-special-p variable))) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (astore (variable-reserved-register variable)) + (setf (variable-register variable) (variable-reserved-register variable)) + (setf (variable-index variable) nil))))) + + (generate-type-checks-for-variables (reverse parameters)) + + ;; Unbox variables. + (dolist (variable (reverse parameters)) + (p2-compiland-unbox-variable variable)) + + ;; Establish dynamic bindings for any variables declared special. + (dolist (variable parameters) + (when (variable-special-p variable) + (cond ((variable-register variable) + (emit-push-current-thread) + (emit-push-variable-name variable) + (aload (variable-register variable)) + (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) nil) + (setf (variable-register variable) nil)) + ((variable-index variable) + (emit-push-current-thread) + (emit-push-variable-name variable) + (aload (compiland-argument-register compiland)) + (emit-push-constant-int (variable-index variable)) + (emit 'aaload) + (emit-invokevirtual +lisp-thread-class+ "bindSpecial" + (list +lisp-symbol+ +lisp-object+) nil) + (setf (variable-index variable) nil))))) + + (compile-progn-body body 'stack) + + (unless *code* + (emit-push-nil)) + + (emit 'areturn) + + ;; Warn if any unused args. (Is this the right place?) + (check-for-unused-variables (compiland-arg-vars compiland)) + + ;; Go back and fill in prologue. + (let ((code *code*)) + (setf *code* ()) + (let ((arity (compiland-arity compiland))) + (when arity + (generate-arg-count-check arity))) + + (when *hairy-arglist-p* + (aload 0) ; this + (aver (not (null (compiland-argument-register compiland)))) + (aload (compiland-argument-register compiland)) ; arg vector + (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) + (ensure-thread-var-initialized) + (maybe-initialize-thread-var) + (aload *thread*) + (emit-invokevirtual *this-class* "processArgs" + (list +lisp-object-array+ +lisp-thread+) + +lisp-object-array+)) + (t + (emit-invokevirtual *this-class* "fastProcessArgs" + (list +lisp-object-array+) + +lisp-object-array+))) + (astore (compiland-argument-register compiland))) + + (maybe-initialize-thread-var) + (setf *code* (nconc code *code*))) + + (finalize-code) + (optimize-code) + + (setf *code* (resolve-instructions *code*)) + (setf (method-max-stack execute-method) (analyze-stack)) + (setf (method-code execute-method) (code-bytes *code*)) + + ;; Remove handler if its protected range is empty. + (setf *handlers* + (delete-if (lambda (handler) (eql (symbol-value (handler-from handler)) + (symbol-value (handler-to handler)))) + *handlers*)) + + (setf (method-max-locals execute-method) *registers-allocated*) + (setf (method-handlers execute-method) (nreverse *handlers*)) + + (setf (class-file-superclass class-file) + (cond (super + super) + (*child-p* + (if *closure-variables* + (progn + (setf execute-method-name + (setf (method-name execute-method) "_execute")) + (setf (method-name-index execute-method) + (pool-name (method-name execute-method))) + (setf (method-descriptor-index execute-method) + (pool-name (method-descriptor execute-method))) + +lisp-ctf-class+) + (if *hairy-arglist-p* + +lisp-compiled-function-class+ + +lisp-primitive-class+))) + (*hairy-arglist-p* + +lisp-compiled-function-class+) + (t + +lisp-primitive-class+))) + + (setf (class-file-lambda-list class-file) args) + + (push execute-method (class-file-methods class-file))) + t) + +(defun compile-1 (compiland) + (let ((*all-variables* nil) + (*closure-variables* nil) + (*undefined-variables* nil) + (*local-functions* nil) + (*current-compiland* compiland)) + (with-saved-compiler-policy + ;; Pass 1. + (p1-compiland compiland) + (setf *closure-variables* + (remove-if-not #'variable-used-non-locally-p *all-variables*)) + (when *closure-variables* + (setf *closure-variables* + (remove-if #'variable-special-p *closure-variables*)) + (when *closure-variables* + (let ((i 0)) + (dolist (var (reverse *closure-variables*)) + (setf (variable-closure-index var) i) + (dformat t "var = ~S closure index = ~S~%" (variable-name var) + (variable-closure-index var)) + (incf i))))) + ;; Pass 2. + (with-class-file (compiland-class-file compiland) + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))) + (class-file-pathname (compiland-class-file compiland))))) + +(defvar *compiler-error-bailout*) + +(defun make-compiler-error-form (form) + `(lambda ,(cadr form) + (error 'program-error :format-control "Execution of a form compiled with errors."))) + +(defun compile-defun (name form environment filespec) + (aver (eq (car form) 'LAMBDA)) + (unless (or (null environment) (empty-environment-p environment)) + (compiler-unsupported "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment.")) + (catch 'compile-defun-abort + (let* ((class-file (make-class-file :pathname filespec + :lambda-name name + :lambda-list (cadr form))) + (*compiler-error-bailout* + `(lambda () + (compile-1 (make-compiland :name ',name + :lambda-expression (make-compiler-error-form ',form) + :class-file + (make-class-file :pathname ,filespec + :lambda-name ',name + :lambda-list (cadr ',form))))))) + (compile-1 (make-compiland :name name + :lambda-expression (precompile-form form t) + :class-file class-file))))) + +(defvar *catch-errors* t) + +(defvar *in-compilation-unit* nil) + +(defmacro with-compilation-unit (options &body body) + `(%with-compilation-unit (lambda () , at body) , at options)) + +(defun %with-compilation-unit (fn &key override) + (handler-bind ((style-warning 'handle-style-warning) + (warning 'handle-warning) + (compiler-error 'handle-compiler-error)) + (if (and *in-compilation-unit* (not override)) + (funcall fn) + (let ((*style-warnings* 0) + (*warnings* 0) + (*errors* 0) + (*defined-functions* nil) + (*undefined-functions* nil) + (*in-compilation-unit* t)) + (unwind-protect + (funcall fn) + (unless (or (and *suppress-compiler-warnings* (zerop *errors*)) + (and (zerop (+ *errors* *warnings* *style-warnings*)) + (null *undefined-functions*))) + (format *error-output* "~%; Compilation unit finished~%") + (unless (zerop *errors*) + (format *error-output* "; Caught ~D ERROR condition~P~%" + *errors* *errors*)) + (unless *suppress-compiler-warnings* + (unless (zerop *warnings*) + (format *error-output* "; Caught ~D WARNING condition~P~%" + *warnings* *warnings*)) + (unless (zerop *style-warnings*) + (format *error-output* "; Caught ~D STYLE-WARNING condition~P~%" + *style-warnings* *style-warnings*)) + (when *undefined-functions* + (format *error-output* "; The following functions were used but not defined:~%") + (dolist (name *undefined-functions*) + (format *error-output* "; ~S~%" name)))) + (terpri *error-output*))))))) + +(defun get-lambda-to-compile (thing) + (if (and (consp thing) + (eq (%car thing) 'LAMBDA)) + thing + (multiple-value-bind (lambda-expression environment) + (function-lambda-expression (if (typep thing 'standard-generic-function) + (mop::funcallable-instance-function thing) + thing)) + (unless lambda-expression + (error "Can't find a definition for ~S." thing)) + (values lambda-expression environment)))) + +(defun %jvm-compile (name definition) + (unless definition + (resolve name) + (setf definition (fdefinition name))) + (when (compiled-function-p definition) + (return-from %jvm-compile (values name nil nil))) + (multiple-value-bind (expr env) + (get-lambda-to-compile definition) + (let* ((*package* (if (and name (symbol-package name)) + (symbol-package name) + *package*)) + compiled-function + (warnings-p t) + (failure-p t)) + (with-compilation-unit () + (with-saved-compiler-policy + (let* ((tempfile (make-temp-file))) + (unwind-protect + (setf compiled-function + (load-compiled-function (compile-defun name expr env tempfile))) + (delete-file tempfile)))) + (when (and name (functionp compiled-function)) + (sys::%set-lambda-name compiled-function name) + (sys:set-call-count compiled-function (sys:call-count definition)) + (sys::%set-arglist compiled-function (sys::arglist definition)) + (let ((*warn-on-redefinition* nil)) + (cond ((typep definition 'standard-generic-function) + (mop:set-funcallable-instance-function definition compiled-function)) + (t + (setf (fdefinition name) + (if (macro-function name) + (make-macro name compiled-function) + compiled-function)))))) + (cond ((zerop (+ *errors* *warnings* *style-warnings*)) + (setf warnings-p nil failure-p nil)) + ((zerop (+ *errors* *warnings*)) + (setf failure-p nil)))) + (values (or name compiled-function) warnings-p failure-p)))) + +(defun jvm-compile (name &optional definition) + (if *catch-errors* + (handler-case + (%jvm-compile name definition) + (compiler-unsupported-feature-error + (c) + (fresh-line) + (sys::%format t "; UNSUPPORTED FEATURE: ~A~%" c) + (if name + (sys::%format t "; Unable to compile ~S.~%" name) + (sys::%format t "; Unable to compile top-level form.~%")) + (precompiler::precompile name definition))) + (%jvm-compile name definition))) + +(defun jvm-compile-package (package-designator) + (let ((pkg (if (packagep package-designator) + package-designator + (find-package package-designator)))) + (dolist (sym (sys::package-symbols pkg)) + (when (fboundp sym) + (unless (or (special-operator-p sym) (macro-function sym)) + ;; Force autoload to be resolved. + (resolve sym) + (let ((f (fdefinition sym))) + (unless (compiled-function-p f) + (jvm-compile sym))))))) + t) + +(defun initialize-p2-handlers () + (mapc #'install-p2-handler '(declare + multiple-value-call + multiple-value-list + multiple-value-prog1 + nth + progn)) + (install-p2-handler '%call-internal 'p2-%call-internal) + (install-p2-handler '%ldb 'p2-%ldb) + (install-p2-handler '%make-structure 'p2-%make-structure) + (install-p2-handler '* 'p2-times) + (install-p2-handler '+ 'p2-plus) + (install-p2-handler '- 'p2-minus) + (install-p2-handler '< 'p2-numeric-comparison) + (install-p2-handler '<= 'p2-numeric-comparison) + (install-p2-handler '= 'p2-numeric-comparison) + (install-p2-handler '> 'p2-numeric-comparison) + (install-p2-handler '>= 'p2-numeric-comparison) + (install-p2-handler 'and 'p2-and) + (install-p2-handler 'aref 'p2-aref) + (install-p2-handler 'aset 'p2-aset) + (install-p2-handler 'ash 'p2-ash) + (install-p2-handler 'atom 'p2-atom) + (install-p2-handler 'bit-vector-p 'p2-bit-vector-p) + (install-p2-handler 'car 'p2-car) + (install-p2-handler 'cdr 'p2-cdr) + (install-p2-handler 'char 'p2-char/schar) + (install-p2-handler 'char-code 'p2-char-code) + (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 'char= 'p2-char=) + (install-p2-handler 'characterp 'p2-characterp) + (install-p2-handler 'classp 'p2-classp) + (install-p2-handler 'coerce-to-function 'p2-coerce-to-function) + (install-p2-handler 'cons 'p2-cons) + (install-p2-handler 'sys::backq-cons 'p2-cons) + (install-p2-handler 'consp 'p2-consp) + (install-p2-handler 'delete 'p2-delete) + (install-p2-handler 'elt 'p2-elt) + (install-p2-handler 'eq 'p2-eq/neq) + (install-p2-handler 'eql 'p2-eql) + (install-p2-handler 'eval-when 'p2-eval-when) + (install-p2-handler 'find-class 'p2-find-class) + (install-p2-handler 'fixnump 'p2-fixnump) + (install-p2-handler 'flet 'p2-flet) + (install-p2-handler 'funcall 'p2-funcall) + (install-p2-handler 'function 'p2-function) + (install-p2-handler 'gensym 'p2-gensym) + (install-p2-handler 'get 'p2-get) + (install-p2-handler 'getf 'p2-getf) + (install-p2-handler 'gethash 'p2-gethash) + (install-p2-handler 'gethash1 'p2-gethash) + (install-p2-handler 'go 'p2-go) + (install-p2-handler 'if 'p2-if) + (install-p2-handler 'labels 'p2-labels) + (install-p2-handler 'length 'p2-length) + (install-p2-handler 'list 'p2-list) + (install-p2-handler 'sys::backq-list 'p2-list) + (install-p2-handler 'list* 'p2-list*) + (install-p2-handler 'sys::backq-list* 'p2-list*) + (install-p2-handler 'load-time-value 'p2-load-time-value) + (install-p2-handler 'locally 'p2-locally) + (install-p2-handler 'logand 'p2-logand) + (install-p2-handler 'logior 'p2-logior) + (install-p2-handler 'lognot 'p2-lognot) + (install-p2-handler 'logxor 'p2-logxor) + (install-p2-handler 'make-array 'p2-make-array) + (install-p2-handler 'make-hash-table 'p2-make-hash-table) + (install-p2-handler 'make-sequence 'p2-make-sequence) + (install-p2-handler 'make-string 'p2-make-string) + (install-p2-handler 'make-structure 'p2-make-structure) + (install-p2-handler 'max 'p2-min/max) + (install-p2-handler 'memq 'p2-memq) + (install-p2-handler 'memql 'p2-memql) + (install-p2-handler 'min 'p2-min/max) + (install-p2-handler 'mod 'p2-mod) + (install-p2-handler 'neq 'p2-eq/neq) + (install-p2-handler 'not 'p2-not/null) + (install-p2-handler 'nthcdr 'p2-nthcdr) + (install-p2-handler 'null 'p2-not/null) + (install-p2-handler 'or 'p2-or) + (install-p2-handler 'packagep 'p2-packagep) + (install-p2-handler 'progv 'p2-progv) + (install-p2-handler 'puthash 'p2-puthash) + (install-p2-handler 'quote 'p2-quote) + (install-p2-handler 'read-line 'p2-read-line) + (install-p2-handler 'readtablep 'p2-readtablep) + (install-p2-handler 'return-from 'p2-return-from) + (install-p2-handler 'rplacd 'p2-rplacd) + (install-p2-handler 'schar 'p2-char/schar) + (install-p2-handler 'set 'p2-set) + (install-p2-handler 'set-car 'p2-set-car/cdr) + (install-p2-handler 'set-cdr 'p2-set-car/cdr) + (install-p2-handler 'set-char 'p2-set-char/schar) + (install-p2-handler 'set-schar 'p2-set-char/schar) + (install-p2-handler 'set-std-slot-value 'p2-set-std-slot-value) + (install-p2-handler 'setq 'p2-setq) + (install-p2-handler 'simple-vector-p 'p2-simple-vector-p) + (install-p2-handler 'std-slot-value 'p2-std-slot-value) + (install-p2-handler 'stream-element-type 'p2-stream-element-type) + (install-p2-handler 'stringp 'p2-stringp) + (install-p2-handler 'structure-ref 'p2-structure-ref) + (install-p2-handler 'structure-set 'p2-structure-set) + (install-p2-handler 'svref 'p2-svref) + (install-p2-handler 'svset 'p2-svset) + (install-p2-handler 'sxhash 'p2-sxhash) + (install-p2-handler 'symbol-name 'p2-symbol-name) + (install-p2-handler 'symbol-package 'p2-symbol-package) + (install-p2-handler 'symbol-value 'p2-symbol-value) + (install-p2-handler 'symbolp 'p2-symbolp) + (install-p2-handler 'the 'p2-the) + (install-p2-handler 'throw 'p2-throw) + (install-p2-handler 'truly-the 'p2-truly-the) + (install-p2-handler 'truncate 'p2-truncate) + (install-p2-handler 'values 'p2-values) + (install-p2-handler 'vectorp 'p2-vectorp) + (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) + t) + +(initialize-p2-handlers) + + +(provide "COMPILER-PASS2") Added: branches/save-image/src/org/armedbear/lisp/compiler-types.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/compiler-types.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,259 @@ +;;; compiler-types.lisp +;;; +;;; Copyright (C) 2005-2006 Peter Graves +;;; $Id: compiler-types.lisp 11591 2009-01-26 19:29:53Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Type information that matters to the compiler. + +(in-package #:system) + +(export '(+true-type+ + +false-type+ + integer-type-low + integer-type-high + integer-type-p + %make-integer-type + make-integer-type + +fixnum-type+ + +integer-type+ + fixnum-type-p + fixnum-constant-value + integer-constant-value + java-long-type-p + make-compiler-type + compiler-subtypep + function-result-type + defknown)) + +(defstruct constant-type value) + +(defconst +true-type+ (make-constant-type :value t)) + +(defconst +false-type+ (make-constant-type :value nil)) + +(defstruct (integer-type (:constructor %make-integer-type (low high))) + low + high) + +(defconstant +fixnum-type+ (%make-integer-type most-negative-fixnum + most-positive-fixnum)) + +(defconstant +integer-type+ (%make-integer-type nil nil)) + +(declaim (ftype (function (t) t) make-integer-type)) +(defun make-integer-type (type) + (if (integer-type-p type) + type + (cond ((eq type 'FIXNUM) + +fixnum-type+) + ((eq type 'INTEGER) + +integer-type+) + (t + (setf type (normalize-type type)) + (when (and (consp type) (eq (%car type) 'INTEGER)) + (let ((low (second type)) + (high (third type))) + (if (eq low '*) + (setf low nil) + (when (and (consp low) (integerp (%car low))) + (setf low (1+ (%car low))))) + (if (eq high '*) + (setf high nil) + (when (and (consp high) (integerp (%car high))) + (setf high (1- (%car high))))) + (%make-integer-type low high))))))) + +(declaim (ftype (function (t) t) fixnum-type-p)) +(defun fixnum-type-p (compiler-type) + (and (integer-type-p compiler-type) + (fixnump (integer-type-low compiler-type)) + (fixnump (integer-type-high compiler-type)))) + +(declaim (ftype (function (t) t) fixnum-constant-value)) +(defun fixnum-constant-value (compiler-type) + (when (and compiler-type (integer-type-p compiler-type)) + (let ((low (integer-type-low compiler-type)) + high) + (when (fixnump low) + (setf high (integer-type-high compiler-type)) + (when (and (fixnump high) (= high low)) + high))))) + +(declaim (ftype (function (t) t) integer-constant-value)) +(defun integer-constant-value (compiler-type) + (when (and compiler-type (integer-type-p compiler-type)) + (let ((low (integer-type-low compiler-type)) + high) + (when (integerp low) + (setf high (integer-type-high compiler-type)) + (when (and (integerp high) (= high low)) + high))))) + +(declaim (ftype (function (t) t) java-long-type-p)) +(defun java-long-type-p (compiler-type) + (and (integer-type-p compiler-type) + (typep (integer-type-low compiler-type) + (list 'INTEGER most-negative-java-long most-positive-java-long)) + (typep (integer-type-high compiler-type) + (list 'INTEGER most-negative-java-long most-positive-java-long)))) + + +(declaim (ftype (function (t t) t) make-union-type)) +(defun make-union-type (type1 type2) + (cond ((and (integer-type-p type1) + (integer-type-p type2)) + (let ((low1 (integer-type-low type1)) + (low2 (integer-type-low type2)) + (high1 (integer-type-high type1)) + (high2 (integer-type-high type2))) + (if (and low1 low2 high1 high2) + (%make-integer-type (min low1 low2) (max high1 high2)) + +integer-type+))) + (t + t))) + +(declaim (ftype (function (t) t) make-compiler-type)) +(defun make-compiler-type (typespec) + (cond ((integer-type-p typespec) + typespec) + ((constant-type-p typespec) + typespec) + ((eq typespec 'SINGLE-FLOAT) + 'SINGLE-FLOAT) + ((eq typespec 'DOUBLE-FLOAT) + 'DOUBLE-FLOAT) + ((and (consp typespec) + (eq (%car typespec) 'SINGLE-FLOAT)) + 'SINGLE-FLOAT) + ((and (consp typespec) + (eq (%car typespec) 'DOUBLE-FLOAT)) + 'DOUBLE-FLOAT) + (t + (let ((type (normalize-type typespec))) + (cond ((consp type) + (let ((car (%car type))) + (cond ((eq car 'INTEGER) + (make-integer-type type)) + ((eq car 'SINGLE-FLOAT) + 'SINGLE-FLOAT) + ((eq car 'DOUBLE-FLOAT) + 'DOUBLE-FLOAT) + ((memq car '(STRING SIMPLE-STRING LIST)) + car) + ((memq car '(VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY)) + type) + ((eq car 'OR) + (case (length (cdr type)) + (1 + (make-compiler-type (second type))) + (2 + (make-union-type (make-compiler-type (second type)) + (make-compiler-type (third type)))) + (t + t))) + ((subtypep type 'FIXNUM) + +fixnum-type+) + (t + t)))) + ((memq type '(BOOLEAN CHARACTER HASH-TABLE STREAM SYMBOL)) + type) + ((eq type 'INTEGER) + (%make-integer-type nil nil)) + (t + t)))))) + +(defun integer-type-subtypep (type1 typespec) + (if (eq typespec 'INTEGER) + t + (let ((type2 (make-integer-type typespec))) + (when type2 + (let ((low1 (integer-type-low type1)) + (high1 (integer-type-high type1)) + (low2 (integer-type-low type2)) + (high2 (integer-type-high type2))) + (cond ((and low1 low2 high1 high2) + (and (>= low1 low2) (<= high1 high2))) + ((and low1 low2 (< low1 low2)) + nil) + ((and high1 high2) (> high1 high2) + nil) + ((and (null low1) low2) + nil) + ((and (null high1) high2) + nil) + (t + t))))))) + +(declaim (ftype (function (t t) t) compiler-subtypep)) +(defun compiler-subtypep (compiler-type typespec) + (cond ((eq typespec t) + t) + ((eq compiler-type t) + nil) + ((eq compiler-type typespec) + t) + ((eq typespec 'STRING) + (eq compiler-type 'SIMPLE-STRING)) + ((integer-type-p compiler-type) + (integer-type-subtypep compiler-type typespec)) + (t + (values (subtypep compiler-type typespec))))) + +(declaim (type hash-table *function-result-types*)) +(defconst *function-result-types* (make-hash-table :test 'equal)) + +(declaim (ftype (function (t) t) function-result-type)) +(defun function-result-type (name) + (if (symbolp name) + (get name 'function-result-type) + (gethash1 name *function-result-types*))) + +(declaim (ftype (function (t t) t) set-function-result-type)) +(defun set-function-result-type (name result-type) + (if (symbolp name) + (setf (get name 'function-result-type) result-type) + (setf (gethash name *function-result-types*) result-type))) + +(defun %defknown (name-or-names argument-types result-type) + (let ((ftype `(function ,argument-types ,result-type)) + (result-type (make-compiler-type result-type))) + (cond ((or (symbolp name-or-names) (setf-function-name-p name-or-names)) + (proclaim-ftype-1 ftype name-or-names) + (set-function-result-type name-or-names result-type)) + (t + (proclaim-ftype ftype name-or-names) + (dolist (name name-or-names) + (set-function-result-type name result-type))))) + name-or-names) + +(defmacro defknown (name-or-names argument-types result-type) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%defknown ',name-or-names ',argument-types ',result-type))) + +(provide '#:compiler-types) Added: branches/save-image/src/org/armedbear/lisp/concatenate.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/concatenate.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,71 @@ +;;; concatenate.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: concatenate.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun concatenate-to-string (sequences) + (declare (optimize speed (safety 0))) + (let ((length 0)) + (declare (type fixnum length)) + (dolist (seq sequences) + (incf length (length seq))) + (let ((result (make-string length)) + (i 0)) + (declare (type index i)) + (dolist (seq sequences result) + (if (stringp seq) + (dotimes (j (length seq)) + (declare (type index j)) + (setf (schar result i) (char (truly-the string seq) j)) + (incf i)) + (dotimes (j (length seq)) + (declare (type index j)) + (setf (schar result i) (elt seq j)) + (incf i))))))) + +(defun concatenate (result-type &rest sequences) + (case result-type + (LIST + (let ((result ())) + (dolist (seq sequences (nreverse result)) + (dotimes (i (length seq)) + (push (elt seq i) result))))) + ((STRING SIMPLE-STRING) + (concatenate-to-string sequences)) + (t + (let* ((length (apply '+ (mapcar 'length sequences))) + (result (make-sequence result-type length)) + (i 0)) + (declare (type index i)) + (dolist (seq sequences result) + (dotimes (j (length seq)) + (setf (elt result i) (elt seq j)) + (incf i))))))) Added: branches/save-image/src/org/armedbear/lisp/cond.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/cond.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +;;; cond.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: cond.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defmacro cond (&rest clauses) + (if (endp clauses) + nil + (let ((clause (first clauses))) + (when (atom clause) + (error "COND clause is not a list: ~S" clause)) + (let ((test (first clause)) + (forms (rest clause))) + (if (endp forms) + (let ((n-result (gensym))) + `(let ((,n-result ,test)) + (if ,n-result + ,n-result + (cond ,@(rest clauses))))) + `(if ,test + (progn , at forms) + (cond ,@(rest clauses)))))))) Added: branches/save-image/src/org/armedbear/lisp/copy-seq.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/copy-seq.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +;;; copy-seq.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: copy-seq.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;; From CMUCL. + +(defmacro vector-copy-seq (sequence type) + `(let ((length (length ,sequence))) + (do ((index 0 (1+ index)) + (copy (make-sequence-of-type ,type length))) + ((= index length) copy) + (aset copy index (aref ,sequence index))))) + +(defmacro list-copy-seq (list) + `(if (atom ,list) '() + (let ((result (cons (car ,list) '()) )) + (do ((x (cdr ,list) (cdr x)) + (splice result + (cdr (rplacd splice (cons (car x) '() ))) )) + ((atom x) (unless (null x) + (rplacd splice x)) + result))))) + +(defun copy-seq (sequence) + (if (listp sequence) + (list-copy-seq sequence) + (vector-copy-seq sequence (type-of sequence)))) Added: branches/save-image/src/org/armedbear/lisp/copy-symbol.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/copy-symbol.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,45 @@ +;;; copy-symbol.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: copy-symbol.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; From CMUCL. + +(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol) + (declare (type symbol symbol)) + (setq new-symbol (make-symbol (symbol-name symbol))) + (when copy-props + (when (boundp symbol) + (set new-symbol (symbol-value symbol))) + (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol))) + (when (fboundp symbol) + (setf (symbol-function new-symbol) (symbol-function symbol)))) + new-symbol) Added: branches/save-image/src/org/armedbear/lisp/copy_list.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/copy_list.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,65 @@ +/* + * copy_list.java + * + * Copyright (C) 2005 Peter Graves + * $Id: copy_list.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### copy-list list => copy +public final class copy_list extends Primitive +{ + private copy_list() + { + super(Symbol.COPY_LIST, "list"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == NIL) + return NIL; + Cons result = new Cons(arg.car()); + Cons splice = result; + arg = arg.cdr(); + while (arg instanceof Cons) + { + Cons cons = (Cons) arg; + Cons temp = new Cons(cons.car); + splice.cdr = temp; + splice = temp; + arg = cons.cdr; + } + splice.cdr = arg; + return result; + } + + private static final Primitive COPY_LIST = new copy_list(); +}; Added: branches/save-image/src/org/armedbear/lisp/count.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/count.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,98 @@ +;;; count.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: count.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "COMMON-LISP") + +;;; From CMUCL. + +(defmacro vector-count-if (not-p from-end-p predicate sequence) + (let ((next-index (if from-end-p '(1- index) '(1+ index))) + (pred `(funcall ,predicate (sys::apply-key key (aref ,sequence index))))) + `(let ((%start ,(if from-end-p '(1- end) 'start)) + (%end ,(if from-end-p '(1- start) 'end))) + (do ((index %start ,next-index) + (count 0)) + ((= index %end) count) + (,(if not-p 'unless 'when) ,pred + (setq count (1+ count))))))) + +(defmacro list-count-if (not-p from-end-p predicate sequence) + (let ((pred `(funcall ,predicate (sys::apply-key key (pop sequence))))) + `(let ((%start ,(if from-end-p '(- length end) 'start)) + (%end ,(if from-end-p '(- length start) 'end)) + (sequence ,(if from-end-p '(reverse sequence) 'sequence))) + (do ((sequence (nthcdr %start ,sequence)) + (index %start (1+ index)) + (count 0)) + ((or (= index %end) (null sequence)) count) + (,(if not-p 'unless 'when) ,pred + (setq count (1+ count))))))) + +(defun count (item sequence &key from-end (test #'eql test-p) (test-not nil test-not-p) + (start 0) end key) + (when (and test-p test-not-p) + (error "test and test-not both supplied")) + (let* ((length (length sequence)) + (end (or end length))) + (let ((%test (if test-not-p + (lambda (x) + (not (funcall test-not item x))) + (lambda (x) + (funcall test item x))))) + (if (listp sequence) + (if from-end + (list-count-if nil t %test sequence) + (list-count-if nil nil %test sequence)) + (if from-end + (vector-count-if nil t %test sequence) + (vector-count-if nil nil %test sequence)))))) + +(defun count-if (test sequence &key from-end (start 0) end key) + (let* ((length (length sequence)) + (end (or end length))) + (if (listp sequence) + (if from-end + (list-count-if nil t test sequence) + (list-count-if nil nil test sequence)) + (if from-end + (vector-count-if nil t test sequence) + (vector-count-if nil nil test sequence))))) + +(defun count-if-not (test sequence &key from-end (start 0) end key) + (let* ((length (length sequence)) + (end (or end length))) + (if (listp sequence) + (if from-end + (list-count-if t t test sequence) + (list-count-if t nil test sequence)) + (if from-end + (vector-count-if t t test sequence) + (vector-count-if t nil test sequence))))) Added: branches/save-image/src/org/armedbear/lisp/create_new_file.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/create_new_file.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +/* + * create_new_file.java + * + * Copyright (C) 2004-2006 Peter Graves + * $Id: create_new_file.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.IOException; + +// ### create-new-file +public final class create_new_file extends Primitive +{ + private create_new_file() + { + super("create-new-file", PACKAGE_SYS, true, "namestring"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final String namestring = arg.getStringValue(); + try { + return new File(namestring).createNewFile() ? T : NIL; + } + catch (IOException e) { + return error(new StreamError(null, e)); + } + } + + private static final Primitive CREATE_NEW_FILE = new create_new_file(); +} Added: branches/save-image/src/org/armedbear/lisp/cxr.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/cxr.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,253 @@ +/* + * cxr.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: cxr.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class cxr extends Lisp +{ + // ### set-car + private static final Primitive SET_CAR = + new Primitive("set-car", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + first.setCar(second); + return second; + } + }; + + // ### set-cdr + private static final Primitive SET_CDR = + new Primitive("set-cdr", PACKAGE_SYS, true) + { + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + first.setCdr(second); + return second; + } + }; + + // ### car + private static final Primitive CAR = new Primitive(Symbol.CAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car(); + } + }; + + // ### cdr + private static final Primitive CDR = new Primitive(Symbol.CDR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr(); + } + }; + + // ### caar + private static final Primitive CAAR = new Primitive(Symbol.CAAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car().car(); + } + }; + + // ### cadr + private static final Primitive CADR = new Primitive(Symbol.CADR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cadr(); + } + }; + + // ### cdar + private static final Primitive CDAR = new Primitive(Symbol.CDAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car().cdr(); + } + }; + + // ### cddr + private static final Primitive CDDR = new Primitive(Symbol.CDDR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr().cdr(); + } + }; + + // ### caddr + private static final Primitive CADDR = new Primitive(Symbol.CADDR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.caddr(); + } + }; + + // ### caadr + private static final Primitive CAADR = new Primitive(Symbol.CAADR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr().car().car(); + } + }; + + // ### caaar + private static final Primitive CAAAR = new Primitive(Symbol.CAAAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car().car().car(); + } + }; + + // ### cdaar + private static final Primitive CDAAR = new Primitive(Symbol.CDAAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car().car().cdr(); + } + }; + + // ### cddar + private static final Primitive CDDAR = new Primitive(Symbol.CDDAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car().cdr().cdr(); + } + }; + + // ### cdddr + private static final Primitive CDDDR = new Primitive(Symbol.CDDDR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr().cdr().cdr(); + } + }; + + // ### cadar + private static final Primitive CADAR = new Primitive(Symbol.CADAR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car().cdr().car(); + } + }; + + // ### cdadr + private static final Primitive CDADR = new Primitive(Symbol.CDADR, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr().car().cdr(); + } + }; + + // ### first + private static final Primitive FIRST = new Primitive(Symbol.FIRST, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.car(); + } + }; + + // ### second + private static final Primitive SECOND = new Primitive(Symbol.SECOND, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cadr(); + } + }; + + // ### third + private static final Primitive THIRD = new Primitive(Symbol.THIRD, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.caddr(); + } + }; + + // ### fourth + private static final Primitive FOURTH = new Primitive(Symbol.FOURTH, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr().cdr().cadr(); + } + }; + + // ### rest + private static final Primitive REST = new Primitive(Symbol.REST, "list") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.cdr(); + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/debug.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/debug.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,131 @@ +;;; debug.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: debug.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:extensions) + +(export '(*debug-condition* *debug-level* show-restarts)) + +(defvar *debug-condition* nil) + +(defvar *debug-level* 0) + +(in-package #:system) + +(defun show-restarts (restarts stream) + (when restarts + (fresh-line stream) + (%format stream "Restarts:~%") + (let ((max-name-len 0)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + (when name + (let ((len (length (princ-to-string name)))) + (when (> len max-name-len) + (setf max-name-len len)))))) + (let ((count 0)) + (dolist (restart restarts) + (let ((name (restart-name restart)) + (report-function (restart-report-function restart))) + (%format stream " ~D: ~A" count name) + (when (functionp report-function) + (dotimes (i (1+ (- max-name-len (length (princ-to-string name))))) + (write-char #\space stream)) + (funcall report-function stream)) + (terpri stream)) + (incf count)))))) + +(defun internal-debug () + (if (fboundp 'tpl::repl) + (let* ((current-debug-io + (if (typep *debug-io* 'synonym-stream) + (symbol-value (synonym-stream-symbol *debug-io*)) + *debug-io*)) + (in (two-way-stream-input-stream current-debug-io)) + (out (two-way-stream-output-stream current-debug-io))) + (loop + (tpl::repl in out))) + (quit))) + +(defun debug-loop () + (let ((*debug-level* (1+ *debug-level*))) + (show-restarts (compute-restarts) *debug-io*) + (internal-debug))) + +(defun invoke-debugger-report-condition (condition) + (when condition + (fresh-line *debug-io*) + (with-standard-io-syntax + (let ((*print-structure* nil)) + (when (and *load-truename* (streamp *load-stream*)) + (simple-format *debug-io* + "Error loading ~A at line ~D (offset ~D)~%" + *load-truename* + (stream-line-number *load-stream*) + (stream-offset *load-stream*))) + (simple-format *debug-io* + (if (fboundp 'tpl::repl) + "Debugger invoked on condition of type ~A:~%" + "Unhandled condition of type ~A:~%") + (type-of condition)) + (simple-format *debug-io* " ~A~%" condition))))) + +(defun invoke-debugger (condition) + (let ((*saved-backtrace* (backtrace-as-list))) + (when *debugger-hook* + (let ((hook-function *debugger-hook*) + (*debugger-hook* nil)) + (funcall hook-function condition hook-function))) + (invoke-debugger-report-condition condition) + (unless (fboundp 'tpl::repl) + (quit)) + (let ((original-package *package*)) + (with-standard-io-syntax + (let ((*package* original-package) + (*print-readably* nil) ; Top-level default. + (*print-structure* nil) + (*debug-condition* condition) + (level *debug-level*)) + (clear-input) + (if (> level 0) + (with-simple-restart (abort "Return to debug level ~D." level) + (debug-loop)) + (debug-loop))))))) + +(defun break (&optional (format-control "BREAK called") &rest format-arguments) + (let ((*debugger-hook* nil)) ; Specifically required by ANSI. + (with-simple-restart (continue "Return from BREAK.") + (invoke-debugger + (%make-condition 'simple-condition + (list :format-control format-control + :format-arguments format-arguments)))) + nil)) Added: branches/save-image/src/org/armedbear/lisp/define-modify-macro.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/define-modify-macro.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,118 @@ +;;; define-modify-macro.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: define-modify-macro.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +;; FIXME See section 5.1.3. +(defmacro define-modify-macro (name lambda-list function &optional doc-string) + "Creates a new read-modify-write macro like PUSH or INCF." + (let ((other-args nil) + (rest-arg nil) + (env (gensym)) + (reference (gensym))) + ;; Parse out the variable names and &REST arg from the lambda list. + (do ((ll lambda-list (cdr ll)) + (arg nil)) + ((null ll)) + (setq arg (car ll)) + (cond ((eq arg '&optional)) + ((eq arg '&rest) + (if (symbolp (cadr ll)) + (setq rest-arg (cadr ll)) + (error "Non-symbol &REST arg in definition of ~S." name)) + (if (null (cddr ll)) + (return nil) + (error "Illegal stuff after &REST argument in DEFINE-MODIFY-MACRO."))) + ((memq arg '(&key &allow-other-keys &aux)) + (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg)) + ((symbolp arg) + (push arg other-args)) + ((and (listp arg) (symbolp (car arg))) + (push (car arg) other-args)) + (t (error "Illegal stuff in DEFINE-MODIFY-MACRO lambda list.")))) + (setq other-args (nreverse other-args)) + `(defmacro ,name (,reference , at lambda-list &environment ,env) + ,doc-string + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion ,reference ,env) + (do ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil (cons (list (car d) (car v)) let-list))) + ((null d) + (push (list (car newval) + ,(if rest-arg + `(list* ',function getter , at other-args ,rest-arg) + `(list ',function getter , at other-args))) + let-list) + `(let* ,(nreverse let-list) + ,setter))))))) + +(define-modify-macro incf-complex (&optional (delta 1)) + + "The first argument is some location holding a number. This number is + incremented by the second argument, DELTA, which defaults to 1.") + +(define-modify-macro decf-complex (&optional (delta 1)) - + "The first argument is some location holding a number. This number is + decremented by the second argument, DELTA, which defaults to 1.") + +(defmacro incf (place &optional (delta 1)) + (cond ((symbolp place) + (cond ((constantp delta) + `(setq ,place (+ ,place ,delta))) + (t + ;; See section 5.1.3. + (let ((temp (gensym))) + `(let ((,temp ,delta)) + (setq ,place (+ ,place ,temp))))))) + ((and (consp place) (eq (car place) 'THE)) + (let ((res (gensym))) + `(let ((,res (the ,(second place) (+ ,place ,delta)))) + (setf ,(third place) ,res)))) + (t + `(incf-complex ,place ,delta)))) + +(defmacro decf (place &optional (delta 1)) + (cond ((symbolp place) + (cond ((constantp delta) + `(setq ,place (- ,place ,delta))) + (t + ;; See section 5.1.3. + (let ((temp (gensym))) + `(let ((,temp ,delta)) + (setq ,place (- ,place ,temp))))))) + ((and (consp place) (eq (car place) 'THE)) + (let ((res (gensym))) + `(let ((,res (the ,(second place) (- ,place ,delta)))) + (setf ,(third place) ,res)))) + (t + `(decf-complex ,place ,delta)))) Added: branches/save-image/src/org/armedbear/lisp/define-symbol-macro.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/define-symbol-macro.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,42 @@ +;;; define-symbol-macro.lisp +;;; +;;; Copyright (C) 2003-2004 Peter Graves +;;; $Id: define-symbol-macro.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun %define-symbol-macro (symbol expansion) + (setf (symbol-value symbol) (make-symbol-macro expansion)) + symbol) + +(defmacro define-symbol-macro (symbol expansion) + (when (special-variable-p symbol) + (error 'program-error "~S has already been defined as a global variable." symbol)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%define-symbol-macro ',symbol ',expansion))) Added: branches/save-image/src/org/armedbear/lisp/defmacro.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/defmacro.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +;;; defmacro.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: defmacro.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;;; Adapted from CMUCL/SBCL. + +(in-package #:system) + +;; Redefine DEFMACRO to use PARSE-DEFMACRO. +(defmacro defmacro (name lambda-list &rest body) + (let* ((whole (gensym "WHOLE-")) + (env (gensym "ENVIRONMENT-"))) + (multiple-value-bind (body decls) + (parse-defmacro lambda-list whole body name 'defmacro :environment env) + (let ((expander `(lambda (,whole ,env) , at decls ,body))) + `(progn + (let ((macro (make-macro ',name + (or (precompile nil ,expander) ,expander)))) + ,@(if (special-operator-p name) + `((put ',name 'macroexpand-macro macro)) + `((fset ',name macro))) + (%set-arglist macro ',lambda-list) + ',name)))))) Added: branches/save-image/src/org/armedbear/lisp/defpackage.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/defpackage.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,138 @@ +;;; defpackage.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: defpackage.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; Adapted from CMUCL. + +(defun designated-package-name (designator) + (cond ((packagep designator) + (package-name designator)) + (t + (string designator)))) + +(defun stringify-names (names) + (mapcar #'string names)) + +(defun check-disjoint (&rest args) + (let ((rest-args args)) + (dolist (arg1 args) + (let ((key1 (car arg1)) + (set1 (cdr arg1))) + (setq rest-args (cdr rest-args)) + (dolist (arg2 rest-args) + (let* ((key2 (car arg2)) + (set2 (cdr arg2)) + (common (remove-duplicates (intersection set1 set2 :test #'string=)))) + (when common + (error 'program-error + :format-control + "Parameters ~S and ~S must be disjoint, but have common elements: ~S" + :format-arguments + (list key1 key2 common))))))))) + +(defun ensure-available-symbols (symbols) + symbols) + +(defmacro defpackage (package &rest options) + (let ((nicknames nil) + (size nil) + (shadows nil) + (shadowing-imports nil) + (use nil) + (use-p nil) + (imports nil) + (interns nil) + (exports nil) + (doc nil)) + (dolist (option options) + (unless (consp option) + (error 'program-error "bad DEFPACKAGE option: ~S" option)) + (case (car option) + (:nicknames + (setq nicknames (stringify-names (cdr option)))) + (:size + (cond (size + (error 'program-error "can't specify :SIZE twice")) + ((and (consp (cdr option)) + (typep (second option) 'unsigned-byte)) + (setq size (second option))) + (t + (error 'program-error + "bad :SIZE, must be a positive integer: ~S" + (second option))))) + (:shadow + (let ((new (stringify-names (cdr option)))) + (setq shadows (append shadows new)))) + (:shadowing-import-from + (let ((package-name (designated-package-name (cadr option))) + (symbol-names (stringify-names (cddr option)))) + (let ((assoc (assoc package-name shadowing-imports + :test #'string=))) + (if assoc + (setf (cdr assoc) (append (cdr assoc) symbol-names)) + (setq shadowing-imports + (acons package-name symbol-names shadowing-imports)))))) + (:use + (let ((new (mapcar #'designated-package-name (cdr option)))) + (setq use (delete-duplicates (nconc use new) :test #'string=)) + (setq use-p t))) + (:import-from + (let ((package-name (designated-package-name (cadr option))) + (symbol-names (stringify-names (cddr option)))) + (let ((assoc (assoc package-name imports + :test #'string=))) + (if assoc + (setf (cdr assoc) (append (cdr assoc) symbol-names)) + (setq imports (acons package-name symbol-names imports)))))) + (:intern + (let ((new (stringify-names (cdr option)))) + (setq interns (append interns new)))) + (:export + (let ((new (stringify-names (cdr option)))) + (setq exports (append exports new)))) + (:documentation + (when doc + (error 'program-error "can't specify :DOCUMENTATION twice")) + (setq doc (coerce (cadr option) 'simple-string))) + (t + (error 'program-error "bad DEFPACKAGE option: ~S" option)))) + (check-disjoint `(:intern , at interns) `(:export , at exports)) + (check-disjoint `(:intern , at interns) + `(:import-from + ,@(apply #'append (mapcar #'rest imports))) + `(:shadow , at shadows) + `(:shadowing-import-from + ,@(apply #'append (mapcar #'rest shadowing-imports)))) + `(%defpackage ,(string package) ',nicknames ',size + ',shadows (ensure-available-symbols ',shadowing-imports) + ',(if use-p use nil) + (ensure-available-symbols ',imports) ',interns ',exports ',doc))) Added: branches/save-image/src/org/armedbear/lisp/defsetf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/defsetf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,87 @@ +;;; defsetf.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: defsetf.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(require '#:collect) + +(defun %defsetf (orig-access-form num-store-vars expander) + (collect ((subforms) (subform-vars) (subform-exprs) (store-vars)) + (dolist (subform (cdr orig-access-form)) + (if (constantp subform) + (subforms subform) + (let ((var (gensym))) + (subforms var) + (subform-vars var) + (subform-exprs subform)))) + (dotimes (i num-store-vars) + (store-vars (gensym))) + (values (subform-vars) + (subform-exprs) + (store-vars) + (funcall expander (cons (subforms) (store-vars))) + `(,(car orig-access-form) ,@(subforms))))) + +(defmacro defsetf (access-fn &rest rest) + (cond ((not (listp (car rest))) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (%define-setf-macro ',access-fn + nil + ',(car rest) + ,(when (and (car rest) (stringp (cadr rest))) + `',(cadr rest))))) + ((and (cdr rest) (listp (cadr rest))) + (destructuring-bind + (lambda-list (&rest store-variables) &body body) + rest + (let ((arglist-var (gensym "ARGS-")) + (access-form-var (gensym "ACCESS-FORM-")) + (env-var (gensym "ENVIRONMENT-"))) + (multiple-value-bind + (body doc) + (parse-defmacro `(,lambda-list , at store-variables) + arglist-var body access-fn 'defsetf + :anonymousp t) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (%define-setf-macro + ',access-fn + #'(lambda (,access-form-var ,env-var) + (declare (ignore ,env-var)) + (%defsetf ,access-form-var ,(length store-variables) + #'(lambda (,arglist-var) + (block ,access-fn + ,body)))) + nil + ',doc)))))) + (t + (error "Ill-formed DEFSETF for ~S" access-fn)))) Added: branches/save-image/src/org/armedbear/lisp/defstruct.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/defstruct.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,607 @@ +;;; defstruct.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: defstruct.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export 'compiler-defstruct) + +;;; DEFSTRUCT-DESCRIPTION + +(defmacro dd-name (x) `(aref ,x 0)) +(defmacro dd-conc-name (x) `(aref ,x 1)) +(defmacro dd-default-constructor (x) `(aref ,x 2)) +(defmacro dd-constructors (x) `(aref ,x 3)) +(defmacro dd-copier (x) `(aref ,x 4)) +(defmacro dd-include (x) `(aref ,x 5)) +(defmacro dd-type (x) `(aref ,x 6)) +(defmacro dd-named (x) `(aref ,x 7)) +(defmacro dd-initial-offset (x) `(aref ,x 8)) +(defmacro dd-predicate (x) `(aref ,x 9)) +(defmacro dd-print-function (x) `(aref ,x 10)) +(defmacro dd-print-object (x) `(aref ,x 11)) +(defmacro dd-direct-slots (x) `(aref ,x 12)) +(defmacro dd-slots (x) `(aref ,x 13)) + +(defun make-defstruct-description (&key name + conc-name + default-constructor + constructors + copier + include + type + named + initial-offset + predicate + print-function + print-object + direct-slots + slots) + (let ((dd (make-array 14))) + (setf (dd-name dd) name + (dd-conc-name dd) conc-name + (dd-default-constructor dd) default-constructor + (dd-constructors dd) constructors + (dd-copier dd) copier + (dd-include dd) include + (dd-type dd) type + (dd-named dd) named + (dd-initial-offset dd) initial-offset + (dd-predicate dd) predicate + (dd-print-function dd) print-function + (dd-print-object dd) print-object + (dd-direct-slots dd) direct-slots + (dd-slots dd) slots) + dd)) + +;;; DEFSTRUCT-SLOT-DESCRIPTION + +(defmacro dsd-name (x) `(aref ,x 1)) +(defmacro dsd-index (x) `(aref ,x 2)) +(defmacro dsd-reader (x) `(aref ,x 3)) +(defmacro dsd-initform (x) `(aref ,x 4)) +(defmacro dsd-type (x) `(aref ,x 5)) +(defmacro dsd-read-only (x) `(aref ,x 6)) + +(defun make-defstruct-slot-description (&key name + index + reader + initform + (type t) + read-only) + (let ((dsd (make-array 7))) + (setf (aref dsd 0) 'defstruct-slot-description + (dsd-name dsd) name + (dsd-index dsd) index + (dsd-reader dsd) reader + (dsd-initform dsd) initform + (dsd-type dsd) type + (dsd-read-only dsd) read-only) + dsd)) + +(defvar *dd-name*) +(defvar *dd-conc-name*) +(defvar *dd-default-constructor*) +(defvar *dd-constructors*) +(defvar *dd-copier*) +(defvar *dd-include*) +(defvar *dd-type*) +(defvar *dd-named*) +(defvar *dd-initial-offset*) +(defvar *dd-predicate*) +(defvar *dd-print-function*) +(defvar *dd-print-object*) +(defvar *dd-direct-slots*) +(defvar *dd-slots*) + +(defun keywordify (symbol) + (intern (symbol-name symbol) +keyword-package+)) + +(defun define-keyword-constructor (constructor) + (let* ((constructor-name (car constructor)) + (keys ()) + (values ())) + (dolist (slot *dd-slots*) + (let ((name (dsd-name slot)) + (initform (dsd-initform slot))) + (if (or name (dsd-reader slot)) + (let ((dummy (gensym))) + (push (list (list (keywordify name) dummy) initform) keys) + (push dummy values)) + (push initform values)))) + (setf keys (cons '&key (nreverse keys)) + values (nreverse values)) + (cond ((eq *dd-type* 'list) + `((defun ,constructor-name ,keys + (list , at values)))) + ((or (eq *dd-type* 'vector) + (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) + (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t))) + `((defun ,constructor-name ,keys + (make-array ,(length values) + :element-type ',element-type + :initial-contents (list , at values)))))) + ((<= 1 (length values) 6) + `((defun ,constructor-name ,keys + (make-structure (truly-the symbol ',*dd-name*) , at values)))) + (t + `((defun ,constructor-name ,keys + (%make-structure (truly-the symbol ',*dd-name*) (list , at values)))))))) + +(defun find-dsd (name) + (dolist (dsd *dd-slots*) + (when (string= name (dsd-name dsd)) + (return dsd)))) + +(defun get-slot (name) +;; (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name))) + (let ((res nil)) + (dolist (dsd *dd-slots*) + (when (string= name (dsd-name dsd)) + (setf res dsd) + (return))) + (if res + (values (dsd-type res) (dsd-initform res)) + (values t nil)))) + +(defun define-boa-constructor (constructor) + (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) + (parse-lambda-list (cadr constructor)) + (let ((arglist ()) + (vars ()) + (types ()) + (skipped-vars ())) + (dolist (arg req) + (push arg arglist) + (push arg vars) + (push (get-slot arg) types)) + (when opt + (push '&optional arglist) + (dolist (arg opt) + (cond ((consp arg) + (destructuring-bind + (name + &optional + (def (nth-value 1 (get-slot name))) + (supplied-test nil supplied-test-p)) + arg + (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist) + (push name vars) + (push (get-slot name) types))) + (t + (multiple-value-bind (type default) (get-slot arg) + (push `(,arg ,default) arglist) + (push arg vars) + (push type types)))))) + (when restp + (push '&rest arglist) + (push rest arglist) + (push rest vars) + (push 'list types)) + (when keyp + (push '&key arglist) + (dolist (key keys) + (if (consp key) + (destructuring-bind (wot + &optional + (def nil def-p) + (supplied-test nil supplied-test-p)) + key + (let ((name (if (consp wot) + (destructuring-bind (key var) wot + (declare (ignore key)) + var) + wot))) + (multiple-value-bind (type slot-def) + (get-slot name) + (push `(,wot ,(if def-p def slot-def) + ,@(if supplied-test-p `(,supplied-test) nil)) + arglist) + (push name vars) + (push type types)))) + (multiple-value-bind (type default) (get-slot key) + (push `(,key ,default) arglist) + (push key vars) + (push type types))))) + (when allowp + (push '&allow-other-keys arglist)) + (when auxp + (push '&aux arglist) + (dolist (arg aux) + (push arg arglist) + (if (and (consp arg) (eql (length arg) 2)) + (let ((var (first arg))) + (push var vars) + (push (get-slot var) types)) + (push (if (consp arg) (first arg) arg) skipped-vars)))) + (setq arglist (nreverse arglist)) + (setq vars (nreverse vars)) + (setq types (nreverse types)) + (setq skipped-vars (nreverse skipped-vars)) + (let ((values ())) + (dolist (dsd *dd-slots*) + (let ((name (dsd-name dsd)) + var) + (cond ((find name skipped-vars :test #'string=) + (push nil values)) + ((setf var (find name vars :test #'string=)) + (push var values)) + (t + (push (dsd-initform dsd) values))))) + (setf values (nreverse values)) + (let* ((constructor-name (car constructor))) + (cond ((eq *dd-type* 'list) + `((defun ,constructor-name ,arglist + (list , at values)))) + ((or (eq *dd-type* 'vector) + (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) + (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t))) + `((defun ,constructor-name ,arglist + (make-array ,(length values) + :element-type ',element-type + :initial-contents (list , at values)))))) + ((<= 1 (length values) 6) + `((declaim (inline ,constructor-name)) + (defun ,constructor-name ,arglist + (make-structure (truly-the symbol ',*dd-name*) , at values)))) + (t + `((declaim (inline ,constructor-name)) + (defun ,constructor-name ,arglist + (%make-structure (truly-the symbol ',*dd-name*) (list , at values))))))))))) + +(defun default-constructor-name () + (intern (concatenate 'string "MAKE-" (symbol-name *dd-name*)))) + +(defun define-constructors () + (if *dd-constructors* + (let ((results ())) + (dolist (constructor *dd-constructors*) + (when (car constructor) + (setf results (nconc results + (if (cadr constructor) + (define-boa-constructor constructor) + (define-keyword-constructor constructor)))))) + results) + (define-keyword-constructor (cons (default-constructor-name) nil)))) + +(defun name-index () + (dolist (dsd *dd-slots*) + (let ((name (dsd-name dsd)) + (initform (dsd-initform dsd))) + (when (and (null name) + (equal initform (list 'quote *dd-name*))) + (return-from name-index (dsd-index dsd))))) + ;; We shouldn't get here. + nil) + +(defun define-predicate () + (when (and *dd-predicate* + (or *dd-named* (null *dd-type*))) + (let ((pred (if (symbolp *dd-predicate*) + *dd-predicate* + (intern *dd-predicate*)))) + (cond ((eq *dd-type* 'list) + (let ((index (name-index))) + `((defun ,pred (object) + (and (consp object) + (> (length object) ,index) + (eq (nth ,index object) ',*dd-name*)))))) + ((or (eq *dd-type* 'vector) + (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) + (let ((index (name-index))) + `((defun ,pred (object) + (and (vectorp object) + (> (length object) ,index) + (eq (aref object ,index) ',*dd-name*)))))) + (t + `((defun ,pred (object) + (simple-typep object ',*dd-name*)))))))) + +(defun define-reader (slot) + (let ((accessor-name (if *dd-conc-name* + (intern (concatenate 'string + (symbol-name *dd-conc-name*) + (symbol-name (dsd-name slot)))) + (dsd-name slot))) + (index (dsd-index slot)) + (type (dsd-type slot))) + (cond ((eq *dd-type* 'list) + `((declaim (ftype (function * ,type) ,accessor-name)) + (defun ,accessor-name (instance) (elt instance ,index)))) + ((or (eq *dd-type* 'vector) + (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) + `((declaim (ftype (function * ,type) ,accessor-name)) + (defun ,accessor-name (instance) (aref instance ,index)))) + (t + `((declaim (ftype (function * ,type) ,accessor-name)) + (defun ,accessor-name (instance) (structure-ref instance ,index)) + (define-source-transform ,accessor-name (instance) + ,(if (eq type 't) + ``(structure-ref ,instance ,,index) + ``(the ,',type (structure-ref ,instance ,,index))))))))) + +(defun define-writer (slot) + (let ((accessor-name (if *dd-conc-name* + (intern (concatenate 'string + (symbol-name *dd-conc-name*) + (symbol-name (dsd-name slot)))) + (dsd-name slot))) + (index (dsd-index slot))) + (cond ((eq *dd-type* 'list) + `((defun (setf ,accessor-name) (value instance) + (%set-elt instance ,index value)))) + ((or (eq *dd-type* 'vector) + (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) + `((defun (setf ,accessor-name) (value instance) + (aset instance ,index value)))) + (t + `((defun (setf ,accessor-name) (value instance) + (structure-set instance ,index value)) + (define-source-transform (setf ,accessor-name) (value instance) + `(structure-set ,instance ,,index ,value))))))) + +(defun define-access-functions () + (let ((result ())) + (dolist (slot *dd-slots*) + (setf result (nconc result (define-reader slot))) + (unless (dsd-read-only slot) + (setf result (nconc result (define-writer slot))))) + result)) + +(defun define-copier () + (when *dd-copier* + (cond ((eq *dd-type* 'list) + `((setf (fdefinition ',*dd-copier*) #'copy-list))) + ((or (eq *dd-type* 'vector) + (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) + `((setf (fdefinition ',*dd-copier*) #'copy-seq))) + (t + `((setf (fdefinition ',*dd-copier*) #'copy-structure)))))) + +(defun define-print-function () + (cond (*dd-print-function* + (if (cadr *dd-print-function*) + `((defmethod print-object ((instance ,*dd-name*) stream) + (funcall (function ,(cadr *dd-print-function*)) + instance stream *current-print-level*))) + `((defmethod print-object ((instance ,*dd-name*) stream) + (write-string (%write-to-string instance) stream))))) + (*dd-print-object* + (if (cadr *dd-print-object*) + `((defmethod print-object ((instance ,*dd-name*) stream) + (funcall (function ,(cadr *dd-print-object*)) + instance stream))) + `((defmethod print-object ((instance ,*dd-name*) stream) + (write-string (%write-to-string instance) stream))))) + (t + nil))) + +(defun parse-1-option (option) + (case (car option) + (:conc-name + (setf *dd-conc-name* (if (symbolp (cadr option)) + (cadr option) + (make-symbol (string (cadr option)))))) + (:constructor + (let* ((args (cdr option)) + (numargs (length args))) + (case numargs + (0 ; Use default name. + (push (list (default-constructor-name) nil) *dd-constructors*)) + (1 + (push (list (car args) nil) *dd-constructors*)) + (2 + (push args *dd-constructors*))))) + (:copier + (when (eql (length option) 2) + (setf *dd-copier* (cadr option)))) + (:include + (setf *dd-include* (cdr option))) + (:initial-offset + (setf *dd-initial-offset* (cadr option))) + (:predicate + (when (eql (length option) 2) + (setf *dd-predicate* (cadr option)))) + (:print-function + (setf *dd-print-function* option)) + (:print-object + (setf *dd-print-object* option)) + (:type + (setf *dd-type* (cadr option))))) + +(defun parse-name-and-options (name-and-options) + (setf *dd-name* (the symbol (car name-and-options))) + (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-"))) + (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*)))) + (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P")) + (let ((options (cdr name-and-options))) + (dolist (option options) + (cond ((consp option) + (parse-1-option option)) + ((eq option :named) + (setf *dd-named* t)) + ((member option '(:constructor :copier :predicate :named :conc-name)) + (parse-1-option (list option))) + (t + (error "Unrecognized DEFSTRUCT option: ~S." option)))))) + +(defun compiler-defstruct (name &key + conc-name + default-constructor + constructors + copier + include + type + named + initial-offset + predicate + print-function + print-object + direct-slots + slots) + (setf (get name 'structure-definition) + (make-defstruct-description :name name + :conc-name conc-name + :default-constructor default-constructor + :constructors constructors + :copier copier + :include include + :type type + :named named + :initial-offset initial-offset + :predicate predicate + :print-function print-function + :print-object print-object + :direct-slots direct-slots + :slots slots)) + (when (or (null type) named) + (make-structure-class name direct-slots slots (car include))) + (when default-constructor + (proclaim `(ftype (function * t) ,default-constructor)))) + +(defmacro defstruct (name-and-options &rest slots) + (let ((*dd-name* nil) + (*dd-conc-name* nil) + (*dd-default-constructor* nil) + (*dd-constructors* nil) + (*dd-copier* nil) + (*dd-include* nil) + (*dd-type* nil) + (*dd-named* nil) + (*dd-initial-offset* nil) + (*dd-predicate* nil) + (*dd-print-function* nil) + (*dd-print-object* nil) + (*dd-direct-slots* ()) + (*dd-slots* ())) + (parse-name-and-options (if (atom name-and-options) + (list name-and-options) + name-and-options)) + (check-declaration-type *dd-name*) + (if *dd-constructors* + (dolist (constructor *dd-constructors*) + (unless (cadr constructor) + (setf *dd-default-constructor* (car constructor)) + (return))) + (setf *dd-default-constructor* (default-constructor-name))) + (when (stringp (car slots)) + (%set-documentation *dd-name* 'structure (pop slots))) + (dolist (slot slots) + (let* ((name (if (atom slot) slot (car slot))) + (reader (if *dd-conc-name* + (intern (concatenate 'string + (symbol-name *dd-conc-name*) + (symbol-name name))) + name)) + (initform (if (atom slot) nil (cadr slot))) + (dsd (apply #'make-defstruct-slot-description + :name name + :reader reader + :initform initform + (if (atom slot) nil (cddr slot))))) + (push dsd *dd-direct-slots*))) + (setf *dd-direct-slots* (nreverse *dd-direct-slots*)) + (let ((index 0)) + (when *dd-include* + (let ((dd (get (car *dd-include*) 'structure-definition))) + (unless dd + (error 'simple-error + :format-control "Class ~S is undefined." + :format-arguments (list (car *dd-include*)))) + (dolist (dsd (dd-slots dd)) + ;; MUST COPY SLOT DESCRIPTION! + (setf dsd (copy-seq dsd)) + (setf (dsd-index dsd) index) + (push dsd *dd-slots*) + (incf index))) + (when (cdr *dd-include*) + (dolist (slot (cdr *dd-include*)) + (let* ((name (if (atom slot) slot (car slot))) + (initform (if (atom slot) nil (cadr slot))) + (dsd (find-dsd name))) + (when dsd + (setf (dsd-initform dsd) initform)))))) + (when *dd-initial-offset* + (dotimes (i *dd-initial-offset*) + (push (make-defstruct-slot-description :name nil + :index index + :reader nil + :initform nil + :type t + :read-only t) + *dd-slots*) + (incf index))) + (when *dd-named* + (push (make-defstruct-slot-description :name nil + :index index + :reader nil + :initform (list 'quote *dd-name*) + :type t + :read-only t) + *dd-slots*) + (incf index)) + (dolist (dsd *dd-direct-slots*) + (setf (dsd-index dsd) index) + (push dsd *dd-slots*) + (incf index))) + (setf *dd-slots* (nreverse *dd-slots*)) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (compiler-defstruct ',*dd-name* + :conc-name ',*dd-conc-name* + :default-constructor ',*dd-default-constructor* + ,@(if *dd-constructors* `(:constructors ',*dd-constructors*)) + :copier ',*dd-copier* + ,@(if *dd-include* `(:include ',*dd-include*)) + ,@(if *dd-type* `(:type ',*dd-type*)) + ,@(if *dd-named* `(:named ,*dd-named*)) + ,@(if *dd-initial-offset* `(:initial-offset ,*dd-initial-offset*)) + :predicate ',*dd-predicate* + ,@(if *dd-print-function* `(:print-function ',*dd-print-function*)) + ,@(if *dd-print-object* `(:print-object ',*dd-print-object*)) + :direct-slots ',*dd-direct-slots* + :slots ',*dd-slots*)) + ,@(define-constructors) + ,@(define-predicate) + ,@(define-access-functions) + ,@(define-copier) + ,@(define-print-function) + ',*dd-name*))) + +(defun defstruct-default-constructor (arg) + (let ((type (cond ((symbolp arg) + arg) + ((classp arg) + (class-name arg)) + (t + (type-of arg))))) + (when type + (let ((dd (get type 'structure-definition))) + (and dd (dd-default-constructor dd)))))) Added: branches/save-image/src/org/armedbear/lisp/deftype.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/deftype.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,74 @@ +;;; deftype.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: deftype.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defmacro deftype (name lambda-list &rest body) + (when (eq (symbol-package name) +cl-package+) + (error :format-control "Attempt to define ~S, a symbol in the COMMON-LISP package, as a type specifier." + :format-arguments (list name))) + (check-declaration-type name) + ;; Optional and keyword parameters default to * rather than NIL. + (when (or (memq '&optional lambda-list) + (memq '&key lambda-list)) + (let ((new-lambda-list ()) + (state nil)) + (dolist (thing lambda-list) + (cond ((eq thing '&optional) + (setf state '&optional)) + ((eq thing '&key) + (setf state '&key)) + ((memq thing lambda-list-keywords) + (setf state nil)) + ((eq state '&optional) + (when (symbolp thing) + (setf thing (list thing ''*)))) + ((eq state '&key) + (when (symbolp thing) + (setf thing (list thing ''*))))) + (push thing new-lambda-list)) + (setf lambda-list (nreverse new-lambda-list)))) + `(progn + (setf (get ',name 'deftype-definition) + #'(lambda ,lambda-list (block ,name , at body))) + ',name)) + +(defun expand-deftype (type) + (let (tp i) + (loop + (if (consp type) + (setf tp (%car type) i (%cdr type)) + (setf tp type + i nil)) + (if (and (symbolp tp) (get tp 'deftype-definition)) + (setf type (apply (get tp 'deftype-definition) i)) + (return)))) + type) Added: branches/save-image/src/org/armedbear/lisp/delete-duplicates.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/delete-duplicates.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,88 @@ +;;; delete-duplicates.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: delete-duplicates.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; From CMUCL. + +(defun list-delete-duplicates* (list test test-not key from-end start end) + (let ((handle (cons nil list))) + (do ((current (nthcdr start list) (cdr current)) + (previous (nthcdr start handle)) + (index start (1+ index))) + ((or (and end (= index end)) (null current)) + (cdr handle)) + (if (do ((x (if from-end + (nthcdr (1+ start) handle) + (cdr current)) + (cdr x)) + (i (1+ index) (1+ i))) + ((or (null x) + (and (not from-end) end (= i end)) + (eq x current)) + nil) + (if (if test-not + (not (funcall test-not + (sys::apply-key key (car current)) + (sys::apply-key key (car x)))) + (funcall test + (sys::apply-key key (car current)) + (sys::apply-key key (car x)))) + (return t))) + (rplacd previous (cdr current)) + (setq previous (cdr previous)))))) + + +(defun vector-delete-duplicates* (vector test test-not key from-end start end + &optional (length (length vector))) + (when (null end) (setf end (length vector))) + (do ((index start (1+ index)) + (jndex start)) + ((= index end) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (shrink-vector vector jndex) + vector) + (setf (aref vector jndex) (aref vector index)))) + (setf (aref vector jndex) (aref vector index)) + (unless (position (sys::apply-key key (aref vector index)) vector :key key + :start (if from-end start (1+ index)) :test test + :end (if from-end jndex end) :test-not test-not) + (setq jndex (1+ jndex))))) + + +(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end + end key) + (if (listp sequence) + (if sequence + (list-delete-duplicates* sequence test test-not key from-end start end)) + (vector-delete-duplicates* sequence test test-not key from-end start end))) Added: branches/save-image/src/org/armedbear/lisp/delete.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/delete.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,209 @@ +;;; delete.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: delete.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; From CMUCL. + +(defmacro real-count (count) + `(cond ((null ,count) most-positive-fixnum) + ((fixnump ,count) (if (minusp ,count) 0 ,count)) + ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum)) + (t ,count))) + +(defmacro mumble-delete (pred) + `(do ((index start (1+ index)) + (jndex start) + (number-zapped 0)) + ((or (= index end) (= number-zapped count)) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (shrink-vector sequence jndex)) + (aset sequence jndex (aref sequence index)))) + (aset sequence jndex (aref sequence index)) + (if ,pred + (setq number-zapped (1+ number-zapped)) + (setq jndex (1+ jndex))))) + +(defmacro mumble-delete-from-end (pred) + `(do ((index (1- end) (1- index)) ; find the losers + (number-zapped 0) + (losers ()) + this-element + (terminus (1- start))) + ((or (= index terminus) (= number-zapped count)) + (do ((losers losers) ; delete the losers + (index start (1+ index)) + (jndex start)) + ((or (null losers) (= index end)) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (shrink-vector sequence jndex)) + (aset sequence jndex (aref sequence index)))) + (aset sequence jndex (aref sequence index)) + (if (= index (car losers)) + (pop losers) + (setq jndex (1+ jndex))))) + (setq this-element (aref sequence index)) + (when ,pred + (setq number-zapped (1+ number-zapped)) + (push index losers)))) + +(defmacro normal-mumble-delete () + `(mumble-delete + (if test-not + (not (funcall test-not item (funcall-key key (aref sequence index)))) + (funcall test item (funcall-key key (aref sequence index)))))) + +(defmacro normal-mumble-delete-from-end () + `(mumble-delete-from-end + (if test-not + (not (funcall test-not item (funcall-key key this-element))) + (funcall test item (funcall-key key this-element))))) + +(defmacro list-delete (pred) + `(let ((handle (cons nil sequence))) + (do ((current (nthcdr start sequence) (cdr current)) + (previous (nthcdr start handle)) + (index start (1+ index)) + (number-zapped 0)) + ((or (= index end) (= number-zapped count)) + (cdr handle)) + (cond (,pred + (rplacd previous (cdr current)) + (setq number-zapped (1+ number-zapped))) + (t + (setq previous (cdr previous))))))) + +(defmacro list-delete-from-end (pred) + `(let* ((reverse (nreverse sequence)) + (handle (cons nil reverse))) + (do ((current (nthcdr (- length end) reverse) + (cdr current)) + (previous (nthcdr (- length end) handle)) + (index start (1+ index)) + (number-zapped 0)) + ((or (= index end) (= number-zapped count)) + (nreverse (cdr handle))) + (cond (,pred + (rplacd previous (cdr current)) + (setq number-zapped (1+ number-zapped))) + (t + (setq previous (cdr previous))))))) + +(defmacro normal-list-delete () + '(list-delete + (if test-not + (not (funcall test-not item (funcall-key key (car current)))) + (funcall test item (funcall-key key (car current)))))) + +(defmacro normal-list-delete-from-end () + '(list-delete-from-end + (if test-not + (not (funcall test-not item (funcall-key key (car current)))) + (funcall test item (funcall-key key (car current)))))) + +(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) + end count key) + (when key + (setq key (coerce-to-function key))) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (if (listp sequence) + (if from-end + (normal-list-delete-from-end) + (normal-list-delete)) + (if from-end + (normal-mumble-delete-from-end) + (normal-mumble-delete))))) + +(defmacro if-mumble-delete () + `(mumble-delete + (funcall predicate (funcall-key key (aref sequence index))))) + +(defmacro if-mumble-delete-from-end () + `(mumble-delete-from-end + (funcall predicate (funcall-key key this-element)))) + +(defmacro if-list-delete () + '(list-delete + (funcall predicate (funcall-key key (car current))))) + +(defmacro if-list-delete-from-end () + '(list-delete-from-end + (funcall predicate (funcall-key key (car current))))) + +(defun delete-if (predicate sequence &key from-end (start 0) key end count) + (when key + (setq key (coerce-to-function key))) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (if (listp sequence) + (if from-end + (if-list-delete-from-end) + (if-list-delete)) + (if from-end + (if-mumble-delete-from-end) + (if-mumble-delete))))) + +(defmacro if-not-mumble-delete () + `(mumble-delete + (not (funcall predicate (funcall-key key (aref sequence index)))))) + +(defmacro if-not-mumble-delete-from-end () + `(mumble-delete-from-end + (not (funcall predicate (funcall-key key this-element))))) + +(defmacro if-not-list-delete () + '(list-delete + (not (funcall predicate (funcall-key key (car current)))))) + +(defmacro if-not-list-delete-from-end () + '(list-delete-from-end + (not (funcall predicate (funcall-key key (car current)))))) + +(defun delete-if-not (predicate sequence &key from-end (start 0) end key count) + (when key + (setq key (coerce-to-function key))) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (if (listp sequence) + (if from-end + (if-not-list-delete-from-end) + (if-not-list-delete)) + (if from-end + (if-not-mumble-delete-from-end) + (if-not-mumble-delete))))) Added: branches/save-image/src/org/armedbear/lisp/delete_file.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/delete_file.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,90 @@ +/* + * delete_file.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: delete_file.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.IOException; + +public final class delete_file extends Primitive +{ + private delete_file() + { + super("delete-file", "filespec"); + } + + // ### delete-file filespec => t + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + // Don't follow symlinks! We want to delete the symlink itself, not + // the linked-to file. + Pathname pathname = coerceToPathname(arg); + if (arg instanceof Stream) + ((Stream)arg)._close(); + if (pathname instanceof LogicalPathname) + pathname = LogicalPathname.translateLogicalPathname((LogicalPathname)pathname); + if (pathname.isWild()) + return error(new FileError("Bad place for a wild pathname.", + pathname)); + final Pathname defaultedPathname = + Pathname.mergePathnames(pathname, + coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()), + NIL); + final String namestring = defaultedPathname.getNamestring(); + if (namestring == null) + return error(new FileError("Pathname has no namestring: " + defaultedPathname.writeToString(), + defaultedPathname)); + final File file = new File(namestring); + if (file.exists()) { + // File exists. + for (int i = 0; i < 5; i++) { + if (file.delete()) + return T; + System.gc(); + Thread.yield(); + } + Pathname truename = new Pathname(file.getAbsolutePath()); + FastStringBuffer sb = new FastStringBuffer("Unable to delete "); + sb.append(file.isDirectory() ? "directory " : "file "); + sb.append(truename.writeToString()); + sb.append('.'); + return error(new FileError(sb.toString(), truename)); + } else { + // File does not exist. + return T; + } + } + + private static final Primitive DELETE_FILE = new delete_file(); +} Added: branches/save-image/src/org/armedbear/lisp/deposit-field.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/deposit-field.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,39 @@ +;;; deposit-field.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: deposit-field.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun deposit-field (newbyte spec integer) + (let* ((size (byte-size spec)) + (pos (byte-position spec)) + (mask (ash (ldb (byte size 0) -1) pos))) + (logior (logand newbyte mask) + (logand integer (lognot mask))))) Added: branches/save-image/src/org/armedbear/lisp/describe-compiler-policy.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/describe-compiler-policy.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,36 @@ +;;; describe-compiler-policy.lisp +;;; +;;; Copyright (C) 2008 Peter Graves +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun describe-compiler-policy () + (format t "~&; Compiler policy: safety ~D, space ~D, speed ~D, debug ~D~%" + *safety* *space* *speed* *debug*) + (values)) Added: branches/save-image/src/org/armedbear/lisp/describe.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/describe.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,150 @@ +;;; describe.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: describe.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(require '#:clos) +(require '#:format) + +(defun describe-arglist (object stream) + (multiple-value-bind + (arglist known-p) + (arglist object) + (when known-p + (format stream "~&The function's lambda list is:~% ~A~%" arglist)))) + +(defun %describe-object (object stream) + (format stream "~S is an object of type ~S.~%" object (type-of object))) + +(defun describe (object &optional stream) + (describe-object object (out-synonym-of stream)) + (values)) + +(defmethod describe-object ((object t) stream) + (let ((*print-pretty* t)) + (typecase object + (SYMBOL + (let ((package (symbol-package object))) + (if package + (multiple-value-bind + (sym status) + (find-symbol (symbol-name object) package) + (format stream "~S is an ~A symbol in the ~A package.~%" + object + (if (eq status :internal) "internal" "external") + (package-name package))) + (format stream "~S is an uninterned symbol.~%" object)) + (cond ((special-variable-p object) + (format stream "It is a ~A; " + (if (constantp object) "constant" "special variable")) + (if (boundp object) + (format stream "its value is ~S.~%" (symbol-value object)) + (format stream "it is unbound.~%"))) + ((boundp object) + (format stream "It is an undefined variable; its value is ~S.~%" + (symbol-value object))))) + (when (autoloadp object) + (resolve object)) + (let ((function (and (fboundp object) (symbol-function object)))) + (when function + (format stream "Its function binding is ~S.~%" function) + (describe-arglist function stream))) + (let ((doc (documentation object 'function))) + (when doc + (format stream "Function documentation:~% ~A~%" doc))) + (let ((plist (symbol-plist object))) + (when plist + (format stream "The symbol's property list contains these indicator/value pairs:~%") + (loop + (when (null plist) (return)) + (format stream " ~S ~S~%" (car plist) (cadr plist)) + (setf plist (cddr plist)))))) + (FUNCTION + (%describe-object object stream) + (describe-arglist object stream)) + (INTEGER + (%describe-object object stream) + (format stream "~D.~%~ + #x~X~%~ + #o~O~%~ + #b~B~%" + object object object object)) + (t + (%describe-object object stream)))) + (values)) + +(defmethod describe-object ((object pathname) stream) + (format stream "~S is an object of type ~S:~%" object (type-of object)) + (format stream " HOST ~S~%" (pathname-host object)) + (format stream " DEVICE ~S~%" (pathname-device object)) + (format stream " DIRECTORY ~S~%" (pathname-directory object)) + (format stream " NAME ~S~%" (pathname-name object)) + (format stream " TYPE ~S~%" (pathname-type object)) + (format stream " VERSION ~S~%" (pathname-version object))) + +(defmethod describe-object ((object standard-object) stream) + (let* ((class (class-of object)) + (slotds (%class-slots class)) + (max-slot-name-length 0) + (instance-slotds ()) + (class-slotds ())) + (format stream "~S is an instance of ~S.~%" object class) + (dolist (slotd slotds) + (let* ((name (%slot-definition-name slotd)) + (length (length (symbol-name name)))) + (when (> length max-slot-name-length) + (setf max-slot-name-length length))) + (case (%slot-definition-allocation slotd) + (:instance (push slotd instance-slotds)) + (:class (push slotd class-slotds)))) + (setf max-slot-name-length (min (+ max-slot-name-length 3) 30)) + (flet ((describe-slot (slot-name) + (if (slot-boundp object slot-name) + (format stream + "~& ~A~VT ~S" + slot-name max-slot-name-length (slot-value object slot-name)) + (format stream + "~& ~A~VT unbound" + slot-name max-slot-name-length)))) + (when instance-slotds + (format stream "The following slots have :INSTANCE allocation:~%") + (dolist (slotd (nreverse instance-slotds)) + (describe-slot + (%slot-definition-name slotd)))) + (when class-slotds + (format stream "The following slots have :CLASS allocation:~%") + (dolist (slotd (nreverse class-slotds)) + (describe-slot + (%slot-definition-name slotd)))))) + (values)) + +(defmethod describe-object ((object java:java-object) stream) + (java:describe-java-object object stream)) Added: branches/save-image/src/org/armedbear/lisp/destructuring-bind.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/destructuring-bind.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,377 @@ +;;; destructuring-bind.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: destructuring-bind.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;;; Adapted from CMUCL/SBCL. + +(in-package #:system) + +(export '(parse-body)) + +(defun parse-body (body &optional (doc-string-allowed t)) + (let ((decls ()) + (doc nil)) + (do ((tail body (cdr tail))) + ((endp tail) + (values tail (nreverse decls) doc)) + (let ((form (car tail))) + (cond ((and (stringp form) (cdr tail)) + (if doc-string-allowed + (setq doc form + ;; Only one doc string is allowed. + doc-string-allowed nil) + (return (values tail (nreverse decls) doc)))) + ((not (and (consp form) (symbolp (car form)))) + (return (values tail (nreverse decls) doc))) + ((eq (car form) 'declare) + (push form decls)) + (t + (return (values tail (nreverse decls) doc)))))))) + +;; We don't have DEFVAR yet... +(eval-when (:compile-toplevel :load-toplevel :execute) + (%defvar '*arg-tests* ()) + (%defvar '*system-lets* ()) + (%defvar '*user-lets* ()) + (%defvar '*ignorable-vars* ()) + (%defvar '*env-var* nil)) + +(defun arg-count-error (error-kind name arg lambda-list minimum maximum) + (declare (ignore error-kind arg lambda-list minimum maximum)) + (error 'program-error + :format-control "Wrong number of arguments for ~S." + :format-arguments (list name))) + +;;; Return, as multiple values, a body, possibly a DECLARE form to put +;;; where this code is inserted, the documentation for the parsed +;;; body, and bounds on the number of arguments. +(defun parse-defmacro (lambda-list arg-list-name body name context + &key + (anonymousp nil) + (doc-string-allowed t) + ((:environment env-arg-name)) + (error-fun 'error) + (wrap-block t)) + (multiple-value-bind (forms declarations documentation) + (parse-body body doc-string-allowed) + (let ((*arg-tests* ()) + (*user-lets* ()) + (*system-lets* ()) + (*ignorable-vars* ()) + (*env-var* nil)) + (multiple-value-bind (env-arg-used minimum maximum) + (parse-defmacro-lambda-list lambda-list arg-list-name name + context error-fun (not anonymousp) + nil) + (values `(let* (,@(when env-arg-used + `((,*env-var* ,env-arg-name))) + ,@(nreverse *system-lets*)) + ,@(when *ignorable-vars* + `((declare (ignorable ,@*ignorable-vars*)))) + ,@*arg-tests* + (let* ,(nreverse *user-lets*) + , at declarations + ,@(if wrap-block + `((block ,(fdefinition-block-name name) , at forms)) + forms))) + `(,@(when (and env-arg-name (not env-arg-used)) + `((declare (ignore ,env-arg-name))))) + documentation + minimum + maximum))))) + +(defun defmacro-error (problem name) + (error 'type-error "~S is not of type ~S~%" problem name)) + +(defun verify-keywords (key-list valid-keys allow-other-keys) + (do ((already-processed nil) + (unknown-keyword nil) + (remaining key-list (cddr remaining))) + ((null remaining) + (if (and unknown-keyword + (not allow-other-keys) + (not (lookup-keyword :allow-other-keys key-list))) + (values :unknown-keyword (list unknown-keyword valid-keys)) + (values nil nil))) + (cond ((not (and (consp remaining) (listp (cdr remaining)))) + (return (values :dotted-list key-list))) + ((null (cdr remaining)) + (return (values :odd-length key-list))) + ((or (eq (car remaining) :allow-other-keys) + (memql (car remaining) valid-keys)) + (push (car remaining) already-processed)) + (t + (setq unknown-keyword (car remaining)))))) + +(defun lookup-keyword (keyword key-list) + (do ((remaining key-list (cddr remaining))) + ((endp remaining)) + (when (eq keyword (car remaining)) + (return (cadr remaining))))) + +(defun keyword-supplied-p (keyword key-list) + (do ((remaining key-list (cddr remaining))) + ((endp remaining)) + (when (eq keyword (car remaining)) + (return t)))) + +(defun parse-defmacro-lambda-list + (lambda-list arg-list-name name error-kind error-fun + &optional top-level env-illegal ;;env-arg-name + ) + (let* ((path-0 (if top-level `(cdr ,arg-list-name) arg-list-name)) + (path path-0) + (now-processing :required) + (maximum 0) + (minimum 0) + (keys ()) + rest-name restp allow-other-keys-p env-arg-used) + ;; This really strange way to test for &WHOLE is necessary because MEMBER + ;; does not have to work on dotted lists, and dotted lists are legal + ;; in lambda lists. + (when (and (do ((list lambda-list (cdr list))) + ((atom list) nil) + (when (eq (car list) '&WHOLE) (return t))) + (not (eq (car lambda-list) '&WHOLE))) + (error "&Whole must appear first in ~S lambda-list." error-kind)) + (do ((rest-of-args lambda-list (cdr rest-of-args))) + ((atom rest-of-args) + (cond ((null rest-of-args) nil) + ;; Varlist is dotted, treat as &rest arg and exit. + (t (push-let-binding rest-of-args path nil) + (setq restp t)))) + (let ((var (car rest-of-args))) + (cond ((eq var '&whole) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setq rest-of-args (cdr rest-of-args)) + (push-let-binding (car rest-of-args) arg-list-name nil)) + ((and (cdr rest-of-args) (consp (cadr rest-of-args))) + (pop rest-of-args) + (let* ((destructuring-lambda-list (car rest-of-args)) + (sub (gensym "WHOLE-SUBLIST"))) + (push-sub-list-binding + sub arg-list-name destructuring-lambda-list + name error-kind error-fun) + (parse-defmacro-lambda-list + destructuring-lambda-list sub name error-kind error-fun))) + (t + (defmacro-error "&WHOLE" name)))) + ((eq var '&environment) + (cond (env-illegal + (error "&ENVIRONMENT is not valid with ~S." error-kind)) + ((not top-level) + (error "&ENVIRONMENT is only valid at top level of lambda list."))) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setq rest-of-args (cdr rest-of-args)) + (setq *env-var* (car rest-of-args) + env-arg-used t)) + (t + (defmacro-error "&ENVIRONMENT" error-kind name)))) + ((or (eq var '&rest) (eq var '&body)) + (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) + (setq rest-of-args (cdr rest-of-args)) + (setq restp t) + (push-let-binding (car rest-of-args) path nil)) + ((and (cdr rest-of-args) (consp (cadr rest-of-args))) + (pop rest-of-args) + (setq restp t) + (let* ((destructuring-lambda-list (car rest-of-args)) + (sub (gensym "REST-SUBLIST"))) + (push-sub-list-binding sub path destructuring-lambda-list + name error-kind error-fun) + (parse-defmacro-lambda-list + destructuring-lambda-list sub name error-kind error-fun))) + (t + (defmacro-error (symbol-name var) error-kind name)))) + ((eq var '&optional) + (setq now-processing :optionals)) + ((eq var '&key) + (setq now-processing :keywords) + (setq rest-name (gensym "KEYWORDS-")) + (push rest-name *ignorable-vars*) + (setq restp t) + (push-let-binding rest-name path t)) + ((eq var '&allow-other-keys) + (setq allow-other-keys-p t)) + ((eq var '&aux) + (setq now-processing :auxs)) + ((listp var) + (case now-processing + (:required + (let ((sub-list-name (gensym "SUBLIST-"))) + (push-sub-list-binding sub-list-name `(car ,path) var + name error-kind error-fun) + (parse-defmacro-lambda-list var sub-list-name name + error-kind error-fun)) + (setq path `(cdr ,path)) + (incf minimum) + (incf maximum)) + (:optionals + (when (> (length var) 3) + (error "more than variable, initform, and suppliedp in &optional binding ~S" + var)) + (push-optional-binding (car var) (cadr var) (caddr var) + `(not (null ,path)) `(car ,path) + name error-kind error-fun) + (setq path `(cdr ,path)) + (incf maximum)) + (:keywords + (let* ((keyword-given (consp (car var))) + (variable (if keyword-given + (cadar var) + (car var))) + (keyword (if keyword-given + (caar var) + (make-keyword variable))) + (supplied-p (caddr var))) + (push-optional-binding variable (cadr var) supplied-p + `(keyword-supplied-p ',keyword + ,rest-name) + `(lookup-keyword ',keyword + ,rest-name) + name error-kind error-fun) + (push keyword keys))) + (:auxs (push-let-binding (car var) (cadr var) nil)))) + ((symbolp var) + (case now-processing + (:required + (incf minimum) + (incf maximum) + (push-let-binding var `(car ,path) nil) + (setq path `(cdr ,path))) + (:optionals + (incf maximum) + (push-let-binding var `(car ,path) nil `(not (null ,path))) + (setq path `(cdr ,path))) + (:keywords + (let ((key (make-keyword var))) + (push-let-binding var `(lookup-keyword ,key ,rest-name) + nil) + (push key keys))) + (:auxs + (push-let-binding var nil nil)))) + (t + (error "non-symbol in lambda-list: ~S" var))))) + ;; Generate code to check the number of arguments, unless dotted + ;; in which case length will not work. + (unless restp + (push `(unless (<= ,minimum + (length ,path-0) + ,@(unless restp + (list maximum))) + ,(if (eq error-fun 'error) + `(arg-count-error ',error-kind ',name ,path-0 + ',lambda-list ,minimum + ,(unless restp maximum)) + `(,error-fun 'arg-count-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :argument ,path-0 + :lambda-list ',lambda-list + :minimum ,minimum + ,@(unless restp `(:maximum ,maximum))))) + *arg-tests*)) + (if keys + (let ((problem (gensym "KEY-PROBLEM-")) + (info (gensym "INFO-"))) + (push `(multiple-value-bind (,problem ,info) + (verify-keywords ,rest-name ',keys ',allow-other-keys-p) + (when ,problem +;; (,error-fun +;; 'defmacro-lambda-list-broken-key-list-error +;; :kind ',error-kind +;; ,@(when name `(:name ',name)) +;; :problem ,problem +;; :info ,info) + (error 'program-error "Unrecognized keyword argument ~S" (car ,info))) + ) + *arg-tests*))) + (values env-arg-used minimum (if (null restp) maximum nil)))) + + +(defun push-sub-list-binding (variable path object name error-kind error-fun) + (let ((var (gensym "TEMP-"))) + (push `(,variable + (let ((,var ,path)) + (if (listp ,var) + ,var + (,error-fun 'defmacro-bogus-sublist-error + :kind ',error-kind + ,@(when name `(:name ',name)) + :object ,var + :lambda-list ',object)))) + *system-lets*))) + +(defun push-let-binding (variable path systemp &optional condition + (init-form nil)) + (let ((let-form (if condition + `(,variable (if ,condition ,path ,init-form)) + `(,variable ,path)))) + (if systemp + (push let-form *system-lets*) + (push let-form *user-lets*)))) + +(defun push-optional-binding (value-var init-form supplied-var condition path + name error-kind error-fun) + (unless supplied-var + (setq supplied-var (gensym "SUPPLIEDP-"))) + (push-let-binding supplied-var condition t) + (cond ((consp value-var) + (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) + (push-sub-list-binding whole-thing + `(if ,supplied-var ,path ,init-form) + value-var name error-kind error-fun) + (parse-defmacro-lambda-list value-var whole-thing name + error-kind error-fun))) + ((symbolp value-var) + (push-let-binding value-var path nil supplied-var init-form)) + (t + (error "Illegal optional variable name: ~S" value-var)))) + +(defmacro destructuring-bind (lambda-list arg-list &rest body) + (let* ((arg-list-name (gensym "ARG-LIST-"))) + (multiple-value-bind (body local-decls) + (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind + :anonymousp t + :doc-string-allowed nil + :wrap-block nil) + `(let ((,arg-list-name ,arg-list)) + , at local-decls + ,body)))) + +;; Redefine SYS:MAKE-EXPANDER-FOR-MACROLET to use PARSE-DEFMACRO. +(defun make-expander-for-macrolet (definition) + (let* ((name (car definition)) + (lambda-list (cadr definition)) + (form (gensym "WHOLE-")) + (env (gensym "ENVIRONMENT-")) + (body (parse-defmacro lambda-list form (cddr definition) name 'defmacro + :environment env))) + `(lambda (,form ,env) (block ,name ,body)))) Added: branches/save-image/src/org/armedbear/lisp/directory.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/directory.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,95 @@ +;;; directory.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; Copyright (C) 2008 Ville Voutilainen +;;; $Id: directory.lisp 11616 2009-02-01 19:24:13Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun pathname-as-file (pathname) + (let ((directory (pathname-directory pathname))) + (make-pathname :host nil + :device (pathname-device pathname) + :directory (butlast directory) + :name (car (last directory)) + :type nil + :version nil))) + +(defun list-directories-with-wildcards (pathname) + (let* ((directory (pathname-directory pathname)) + (first-wild (position-if #'wild-p directory)) + (wild (when first-wild (nthcdr first-wild directory))) + (non-wild (if first-wild + (nbutlast directory + (- (length directory) first-wild)) + directory)) + (newpath (make-pathname :directory non-wild + :name nil :type nil :defaults pathname)) + (entries (list-directory newpath))) + (if (not wild) + entries (mapcan (lambda (entry) + (let* ((pathname (pathname entry)) + (directory (pathname-directory pathname)) + (rest-wild (cdr wild))) + (unless (pathname-name pathname) + (when (pathname-match-p (first (last directory)) (if (eql (car wild) :wild) "*" (car wild))) + (when rest-wild + (setf directory (nconc directory rest-wild))) + (list-directories-with-wildcards + (make-pathname :directory directory + :defaults newpath)))))) + entries)))) + + +(defun directory (pathspec &key) + (let ((pathname (merge-pathnames pathspec))) + (when (logical-pathname-p pathname) + (setq pathname (translate-logical-pathname pathname))) + (if (or (position #\* (namestring pathname)) + (wild-pathname-p pathname)) + (let ((namestring (directory-namestring pathname))) + (when (and namestring (> (length namestring) 0)) + #+windows + (let ((device (pathname-device pathname))) + (when device + (setq namestring (concatenate 'string device ":" namestring)))) + (let ((entries (list-directories-with-wildcards namestring)) + (matching-entries ())) + (dolist (entry entries) + (cond ((file-directory-p entry) + (when (pathname-match-p (file-namestring (pathname-as-file entry)) (file-namestring pathname)) + (push entry matching-entries))) + ((pathname-match-p (file-namestring entry) (file-namestring pathname)) + (push entry matching-entries)))) + matching-entries))) + ;; Not wild. + (let ((truename (probe-file pathname))) + (if truename + (list (pathname truename)) + nil))))) Added: branches/save-image/src/org/armedbear/lisp/disassemble.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/disassemble.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +;;; disassemble.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: disassemble.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(require '#:clos) + +(defun disassemble (arg) + (require-type arg '(OR FUNCTION + SYMBOL + (CONS (EQL SETF) (CONS SYMBOL NULL)) + (CONS (EQL LAMBDA) LIST))) + (let ((function (cond ((functionp arg) + arg) + ((symbolp arg) + (or (macro-function arg) (symbol-function arg)))))) + (when (typep function 'generic-function) + (setf function (mop::funcallable-instance-function function))) + (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.~%"))) Added: branches/save-image/src/org/armedbear/lisp/disassemble_class_bytes.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/disassemble_class_bytes.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,79 @@ +/* + * disassemble_class_bytes.java + * + * Copyright (C) 2005 Peter Graves + * $Id: disassemble_class_bytes.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.FileOutputStream; +import java.io.IOException; + +// ### disassemble-class-bytes +public final class disassemble_class_bytes extends Primitive +{ + private disassemble_class_bytes() + { + super("disassemble-class-bytes", PACKAGE_SYS, true, "java-object"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof JavaObject) { + byte[] bytes = (byte[]) ((JavaObject)arg).getObject(); + try { + File file = File.createTempFile("abcl", null, null); + FileOutputStream out = new FileOutputStream(file); + out.write(bytes); + out.close(); + LispObject disassembler = _DISASSEMBLER_.symbolValue(); + if (disassembler instanceof AbstractString) { + StringBuffer sb = new StringBuffer(disassembler.getStringValue()); + sb.append(' '); + sb.append(file.getPath()); + ShellCommand sc = new ShellCommand(sb.toString(), null, null); + sc.run(); + file.delete(); + return new SimpleString(sc.getOutput()); + } else + return new SimpleString("No disassembler is available."); + } + catch (IOException e) { + Debug.trace(e); + } + } + return NIL; + } + + private static final Primitive DISASSEMBLE_CLASS_BYTES = + new disassemble_class_bytes(); +} Added: branches/save-image/src/org/armedbear/lisp/do-all-symbols.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/do-all-symbols.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +;;; do-all-symbols.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: do-all-symbols.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defmacro do-all-symbols ((var &optional result-form) &body body) + (multiple-value-bind (forms decls) (parse-body body nil) + (let ((flet-name (gensym "DO-SYMBOLS-"))) + `(block nil + (flet ((,flet-name (,var) + , at decls + (tagbody , at forms))) + (dolist (package (list-all-packages)) + (flet ((iterate-over-symbols (symbols) + (dolist (symbol symbols) + (,flet-name symbol)))) + (iterate-over-symbols (package-internal-symbols package)) + (iterate-over-symbols (package-external-symbols package))))) + (let ((,var nil)) + (declare (ignorable ,var)) + , at decls + ,result-form))))) Added: branches/save-image/src/org/armedbear/lisp/do-external-symbols.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/do-external-symbols.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,35 @@ +;;; do-external-symbols.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: do-external-symbols.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defmacro do-external-symbols ((var &optional (package '*package*) (result nil)) &body body) + `(dolist (,var (sys::package-external-symbols ,package) ,result) , at body)) Added: branches/save-image/src/org/armedbear/lisp/do-symbols.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/do-symbols.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,39 @@ +;;; do-symbols.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: do-symbols.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defmacro do-symbols ((var &optional (package '*package*) (result nil)) &body body) + `(dolist (,var + (append (package-symbols ,package) + (package-inherited-symbols ,package)) + ,result) + , at body)) Added: branches/save-image/src/org/armedbear/lisp/do.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/do.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,74 @@ +;;; do.lisp +;;; +;;; Copyright (C) 2004-2006 Peter Graves +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package "SYSTEM") + +(defun do-do-body (varlist endlist decls-and-code bind step name block) + (let* ((inits ()) + (steps ()) + (L1 (gensym)) + (L2 (gensym))) + ;; Check for illegal old-style do. + (when (or (not (listp varlist)) (atom endlist)) + (error "Ill-formed ~S -- possibly illegal old style DO?" name)) + ;; Parse the varlist to get inits and steps. + (dolist (v varlist) + (cond ((symbolp v) (push v inits)) + ((listp v) + (unless (symbolp (first v)) + (error "~S step variable is not a symbol: ~S" name (first v))) + (case (length v) + (1 (push (first v) inits)) + (2 (push v inits)) + (3 (push (list (first v) (second v)) inits) + (setq steps (list* (third v) (first v) steps))) + (t (error "~S is an illegal form for a ~S varlist." v name)))) + (t (error "~S is an illegal form for a ~S varlist." v name)))) + ;; Construct the new form. + (multiple-value-bind (code decls) (parse-body decls-and-code nil) + `(block ,block + (,bind ,(nreverse inits) + , at decls + (tagbody + (go ,L2) + ,L1 + , at code + (,step ,@(nreverse steps)) + ,L2 + (unless ,(car endlist) (go ,L1)) + (return-from ,block (progn ,@(cdr endlist))))))))) + +(defmacro do (varlist endlist &rest body) + (do-do-body varlist endlist body 'let 'psetq 'do nil)) + +(defmacro do* (varlist endlist &rest body) + (do-do-body varlist endlist body 'let* 'setq 'do* nil)) Added: branches/save-image/src/org/armedbear/lisp/dolist.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dolist.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,194 @@ +/* + * dolist.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: dolist.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### dolist +public final class dolist extends SpecialOperator +{ + private dolist() + { + super(Symbol.DOLIST); + } + + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject bodyForm = args.cdr(); + args = args.car(); + Symbol var = checkSymbol(args.car()); + LispObject listForm = args.cadr(); + final LispThread thread = LispThread.currentThread(); + LispObject resultForm = args.cdr().cdr().car(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + final LispObject stack = thread.getStack(); + // Process declarations. + LispObject specials = NIL; + while (bodyForm != NIL) + { + LispObject obj = bodyForm.car(); + if (obj instanceof Cons && obj.car() == Symbol.DECLARE) + { + LispObject decls = obj.cdr(); + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) + { + LispObject vars = decl.cdr(); + while (vars != NIL) + { + specials = new Cons(vars.car(), specials); + vars = vars.cdr(); + } + } + decls = decls.cdr(); + } + bodyForm = bodyForm.cdr(); + } + else + break; + } + try + { + final Environment ext = new Environment(env); + // Implicit block. + ext.addBlock(NIL, new LispObject()); + // Evaluate the list form. + LispObject list = checkList(eval(listForm, ext, thread)); + // Look for tags. + LispObject remaining = bodyForm; + while (remaining != NIL) + { + LispObject current = remaining.car(); + remaining = remaining.cdr(); + if (current instanceof Cons) + continue; + // It's a tag. + ext.addTagBinding(current, remaining); + } + // Establish a reusable binding. + final Object binding; + if (specials != NIL && memq(var, specials)) + { + thread.bindSpecial(var, null); + binding = thread.getSpecialBinding(var); + ext.declareSpecial(var); + } + else if (var.isSpecialVariable()) + { + thread.bindSpecial(var, null); + binding = thread.getSpecialBinding(var); + } + else + { + ext.bind(var, null); + binding = ext.getBinding(var); + } + while (specials != NIL) + { + ext.declareSpecial(checkSymbol(specials.car())); + specials = specials.cdr(); + } + while (list != NIL) + { + if (binding instanceof SpecialBinding) + ((SpecialBinding)binding).value = list.car(); + else + ((Binding)binding).value = list.car(); + LispObject body = bodyForm; + while (body != NIL) + { + LispObject current = body.car(); + if (current instanceof Cons) + { + try + { + // Handle GO inline if possible. + if (current.car() == Symbol.GO) + { + LispObject tag = current.cadr(); + Binding b = ext.getTagBinding(tag); + if (b != null && b.value != null) + { + body = b.value; + continue; + } + throw new Go(tag); + } + eval(current, ext, thread); + } + catch (Go go) + { + LispObject tag = go.getTag(); + Binding b = ext.getTagBinding(tag); + if (b != null && b.value != null) + { + body = b.value; + thread.setStack(stack); + continue; + } + throw go; + } + } + body = body.cdr(); + } + list = list.cdr(); + if (interrupted) + handleInterrupt(); + } + if (binding instanceof SpecialBinding) + ((SpecialBinding)binding).value = NIL; + else + ((Binding)binding).value = NIL; + LispObject result = eval(resultForm, ext, thread); + return result; + } + catch (Return ret) + { + if (ret.getTag() == NIL) + { + thread.setStack(stack); + return ret.getResult(); + } + throw ret; + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + private static final dolist DOLIST = new dolist(); +} Added: branches/save-image/src/org/armedbear/lisp/dolist.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dolist.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +;;; dolist.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: dolist.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defmacro dolist ((var list-form &optional (result-form nil)) &body body) + ;; We repeatedly bind the var instead of setting it so that we never + ;; have to give the var an arbitrary value such as NIL (which might + ;; conflict with a declaration). If there is a result form, we + ;; introduce a gratuitous binding of the variable to NIL without the + ;; declarations, then evaluate the result form in that + ;; environment. We spuriously reference the gratuitous variable, + ;; since we don't want to use IGNORABLE on what might be a special + ;; var. + (multiple-value-bind (forms decls) + (parse-body body nil) + (let ((list (gensym "LIST-")) + (top (gensym "TOP-"))) + `(block nil + (let ((,list ,list-form)) + (tagbody + ,top + (unless (endp ,list) + (let ((,var (%car ,list))) + , at decls + (setq ,list (%cdr ,list)) + (tagbody , at forms)) + (go ,top)))) + ,(if (constantp result-form) + `,result-form + `(let ((,var nil)) + , at decls + ,var + ,result-form)))))) Added: branches/save-image/src/org/armedbear/lisp/dotimes.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dotimes.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,269 @@ +/* + * dotimes.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: dotimes.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class dotimes extends SpecialOperator +{ + private dotimes() + { + super(Symbol.DOTIMES); + } + + @Override + public LispObject execute(LispObject args, Environment env) + throws ConditionThrowable + { + LispObject bodyForm = args.cdr(); + args = args.car(); + Symbol var = checkSymbol(args.car()); + LispObject countForm = args.cadr(); + final LispThread thread = LispThread.currentThread(); + LispObject resultForm = args.cdr().cdr().car(); + SpecialBinding lastSpecialBinding = thread.lastSpecialBinding; + final LispObject stack = thread.getStack(); + // Process declarations. + LispObject specials = NIL; + while (bodyForm != NIL) + { + LispObject obj = bodyForm.car(); + if (obj instanceof Cons && obj.car() == Symbol.DECLARE) + { + LispObject decls = obj.cdr(); + while (decls != NIL) + { + LispObject decl = decls.car(); + if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) + { + LispObject vars = decl.cdr(); + while (vars != NIL) + { + specials = new Cons(vars.car(), specials); + vars = vars.cdr(); + } + } + decls = decls.cdr(); + } + bodyForm = bodyForm.cdr(); + } + else + break; + } + try + { + LispObject limit = eval(countForm, env, thread); + Environment ext = new Environment(env); + LispObject localTags = NIL; // Tags that are local to this TAGBODY. + // Look for tags. + LispObject remaining = bodyForm; + while (remaining != NIL) + { + LispObject current = remaining.car(); + remaining = remaining.cdr(); + if (current instanceof Cons) + continue; + // It's a tag. + ext.addTagBinding(current, remaining); + localTags = new Cons(current, localTags); + } + // Implicit block. + ext.addBlock(NIL, new LispObject()); + LispObject result; + // Establish a reusable binding. + final Object binding; + if (specials != NIL && memq(var, specials)) + { + thread.bindSpecial(var, null); + binding = thread.getSpecialBinding(var); + ext.declareSpecial(var); + } + else if (var.isSpecialVariable()) + { + thread.bindSpecial(var, null); + binding = thread.getSpecialBinding(var); + } + else + { + ext.bind(var, null); + binding = ext.getBinding(var); + } + while (specials != NIL) + { + ext.declareSpecial(checkSymbol(specials.car())); + specials = specials.cdr(); + } + if (limit instanceof Fixnum) + { + int count = ((Fixnum)limit).value; + int i; + for (i = 0; i < count; i++) + { + if (binding instanceof SpecialBinding) + ((SpecialBinding)binding).value = new Fixnum(i); + else + ((Binding)binding).value = new Fixnum(i); + LispObject body = bodyForm; + while (body != NIL) + { + LispObject current = body.car(); + if (current instanceof Cons) + { + try + { + // Handle GO inline if possible. + if (current.car() == Symbol.GO) + { + LispObject tag = current.cadr(); + if (memql(tag, localTags)) + { + Binding b = ext.getTagBinding(tag); + if (b != null && b.value != null) + { + body = b.value; + continue; + } + } + throw new Go(tag); + } + eval(current, ext, thread); + } + catch (Go go) + { + LispObject tag = go.getTag(); + if (memql(tag, localTags)) + { + Binding b = ext.getTagBinding(tag); + if (b != null && b.value != null) + { + body = b.value; + thread.setStack(stack); + continue; + } + } + throw go; + } + } + body = body.cdr(); + } + if (interrupted) + handleInterrupt(); + } + if (binding instanceof SpecialBinding) + ((SpecialBinding)binding).value = new Fixnum(i); + else + ((Binding)binding).value = new Fixnum(i); + result = eval(resultForm, ext, thread); + } + else if (limit instanceof Bignum) + { + LispObject i = Fixnum.ZERO; + while (i.isLessThan(limit)) + { + if (binding instanceof SpecialBinding) + ((SpecialBinding)binding).value = i; + else + ((Binding)binding).value = i; + LispObject body = bodyForm; + while (body != NIL) + { + LispObject current = body.car(); + if (current instanceof Cons) + { + try + { + // Handle GO inline if possible. + if (current.car() == Symbol.GO) + { + LispObject tag = current.cadr(); + if (memql(tag, localTags)) + { + Binding b = ext.getTagBinding(tag); + if (b != null && b.value != null) + { + body = b.value; + continue; + } + } + throw new Go(tag); + } + eval(current, ext, thread); + } + catch (Go go) + { + LispObject tag = go.getTag(); + if (memql(tag, localTags)) + { + Binding b = ext.getTagBinding(tag); + if (b != null && b.value != null) + { + body = b.value; + thread.setStack(stack); + continue; + } + } + throw go; + } + } + body = body.cdr(); + } + i = i.incr(); + if (interrupted) + handleInterrupt(); + } + if (binding instanceof SpecialBinding) + ((SpecialBinding)binding).value = i; + else + ((Binding)binding).value = i; + result = eval(resultForm, ext, thread); + } + else + return error(new TypeError(limit, Symbol.INTEGER)); + return result; + } + catch (Return ret) + { + if (ret.getTag() == NIL) + { + thread.setStack(stack); + return ret.getResult(); + } + throw ret; + } + finally + { + thread.lastSpecialBinding = lastSpecialBinding; + } + } + + private static final dotimes DOTIMES = new dotimes(); +} Added: branches/save-image/src/org/armedbear/lisp/dotimes.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dotimes.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,74 @@ +;;; dotimes.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: dotimes.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defmacro dotimes ((var count &optional (result nil)) &body body) + (multiple-value-bind (forms decls) (parse-body body nil) + (let ((index (gensym "INDEX-")) + (top (gensym "TOP-"))) + (if (numberp count) + `(block nil + (let ((,var 0) + (,index 0)) + (declare (type (integer 0 ,count) ,index)) + (declare (ignorable ,var)) + , at decls + (when (> ,count 0) + (tagbody + ,top + , at forms + (setq ,index (1+ ,index)) + (setq ,var ,index) + (when (< ,index ,count) + (go ,top)))) + (progn ,result))) + (let ((limit (gensym "LIMIT-"))) + ;; Annotations for the compiler. + (setf (get limit 'dotimes-limit-variable-p) t) + (setf (get limit 'dotimes-index-variable-name) index) + (setf (get index 'dotimes-index-variable-p) t) + (setf (get index 'dotimes-limit-variable-name) limit) + `(block nil + (let ((,var 0) + (,limit ,count) + (,index 0)) + (declare (ignorable ,var)) + , at decls + (when (> ,limit 0) + (tagbody + ,top + , at forms + (setq ,index (1+ ,index)) + (setq ,var ,index) + (when (< ,index ,limit) + (go ,top)))) + (progn ,result)))))))) Added: branches/save-image/src/org/armedbear/lisp/dribble.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dribble.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,84 @@ +;;; dribble.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: dribble.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + + +;;; Each time we start dribbling to a new stream, we put it in +;;; *DRIBBLE-STREAM*, and push a list of *DRIBBLE-STREAM*, *STANDARD-INPUT*, +;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* in *PREVIOUS-DRIBBLE-STREAMS*. +;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* is changed to a broadcast stream that +;;; broadcasts to *DRIBBLE-STREAM* and to the old values of the variables. +;;; *STANDARD-INPUT* is changed to an echo stream that echos input from the old +;;; value of standard input to *DRIBBLE-STREAM*. +;;; +;;; When dribble is called with no arguments, *DRIBBLE-STREAM* is closed, +;;; and the values of *DRIBBLE-STREAM*, *STANDARD-INPUT*, and +;;; *STANDARD-OUTPUT* are popped from *PREVIOUS-DRIBBLE-STREAMS*. + +;;; From SBCL. + +(in-package "SYSTEM") + +(defvar *previous-dribble-streams* nil) +(defvar *dribble-stream* nil) + +(defun dribble (&optional pathname &key (if-exists :append)) + "With a file name as an argument, dribble opens the file and sends a + record of further I/O to that file. Without an argument, it closes + the dribble file, and quits logging." + (cond (pathname + (let* ((new-dribble-stream + (open pathname + :direction :output + :if-exists if-exists + :if-does-not-exist :create)) + (new-standard-output + (make-broadcast-stream *standard-output* new-dribble-stream)) + (new-error-output + (make-broadcast-stream *error-output* new-dribble-stream)) + (new-standard-input + (make-echo-stream *standard-input* new-dribble-stream))) + (push (list *dribble-stream* *standard-input* *standard-output* + *error-output*) + *previous-dribble-streams*) + (setf *dribble-stream* new-dribble-stream) + (setf *standard-input* new-standard-input) + (setf *standard-output* new-standard-output) + (setf *error-output* new-error-output))) + ((null *dribble-stream*) + (error "Not currently dribbling.")) + (t + (let ((old-streams (pop *previous-dribble-streams*))) + (close *dribble-stream*) + (setf *dribble-stream* (first old-streams)) + (setf *standard-input* (second old-streams)) + (setf *standard-output* (third old-streams)) + (setf *error-output* (fourth old-streams))))) + (values)) Added: branches/save-image/src/org/armedbear/lisp/dump-class.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dump-class.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,229 @@ +;;; dump-class.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: dump-class.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(require '#:opcodes) + +(in-package #:jvm) + +(defvar *pool* nil) + +(defun read-u1 (stream) + (read-byte stream)) + +(defun read-u2 (stream) + (+ (ash (read-byte stream) 8) (read-byte stream))) + +(defun read-u4 (stream) + (+ (ash (read-u2 stream) 16) (read-u2 stream))) + +(defun lookup-utf8 (index) + (let ((entry (svref *pool* index))) + (when (eql (car entry) 1) + (caddr entry)))) + +(defun read-constant-pool-entry (stream) + (let ((tag (read-u1 stream))) + (case tag + ((7 8) + (list tag (read-u2 stream))) + (1 + (let* ((len (read-u2 stream)) + (s (make-string len))) + (dotimes (i len) + (setf (char s i) (code-char (read-u1 stream)))) + (list tag len s))) + ((3 4) + (list tag (read-u4 stream))) + ((5 6) + (list tag (read-u4 stream) (read-u4 stream))) + ((12 9 10 11) + (list tag (read-u2 stream) (read-u2 stream))) + (t + (error "READ-CONSTANT-POOL-ENTRY unhandled tag ~D" tag))))) + +(defvar *indent* 0) + +(defparameter *spaces* (make-string 256 :initial-element #\space)) + +(defmacro out (&rest args) + `(progn (format t (subseq *spaces* 0 *indent*)) (format t , at args))) + +(defun dump-code (code) + (let ((code-length (length code))) + (do ((i 0)) + ((>= i code-length)) + (let* ((opcode (svref code i)) + (size (opcode-size opcode))) + (out "~D: ~D (#x~X) ~A~%" i opcode opcode (opcode-name opcode)) + (incf i) + (dotimes (j (1- size)) + (let ((byte (svref code i))) + (out "~D: ~D (#x~X)~%" i byte byte)) + (incf i)))))) + +(defun dump-code-attribute (stream) + (let ((*indent* (+ *indent* 2))) + (out "Stack: ~D~%" (read-u2 stream)) + (out "Locals: ~D~%" (read-u2 stream)) + (let* ((code-length (read-u4 stream)) + (code (make-array code-length))) + (out "Code length: ~D~%" code-length) + (out "Code:~%") + (dotimes (i code-length) + (setf (svref code i) (read-u1 stream))) + (let ((*indent* (+ *indent* 2))) + (dump-code code))) + (let ((exception-table-length (read-u2 stream))) + (out "Exception table length: ~D~%" exception-table-length) + (let ((*indent* (+ *indent* 2))) + (dotimes (i exception-table-length) + (out "Start PC: ~D~%" (read-u2 stream)) + (out "End PC: ~D~%" (read-u2 stream)) + (out "Handler PC: ~D~%" (read-u2 stream)) + (out "Catch type: ~D~%" (read-u2 stream))))) + (let ((attributes-count (read-u2 stream))) + (out "Number of attributes: ~D~%" attributes-count) + (let ((*indent* (+ *indent* 2))) + (dotimes (i attributes-count) + (read-attribute i stream)))))) + +(defun dump-exceptions (stream) + (declare (ignore stream)) + ) + +(defun read-attribute (index stream) + (let* ((name-index (read-u2 stream)) + (name (lookup-utf8 name-index)) + (length (read-u4 stream)) + (*indent* (+ *indent* 2))) + (out "Attribute ~D: Name index: ~D (~S)~%" index name-index name) + (out "Attribute ~D: Length: ~D~%" index length) + (cond ((string= name "Code") + (dump-code-attribute stream)) + ((string= name "Exceptions") + (let ((count (read-u2 stream))) + (out "Attribute ~D: Number of exceptions: ~D~%" index count) + (let ((*indent* (+ *indent* 2))) + (dotimes (i count) + (out "Exception ~D: ~D~%" i (read-u2 stream)))))) + ((string= name "SourceFile") + (let ((source-file-index (read-u2 stream))) + (out "Attribute ~D: Source file index: ~D (~S)~%" + index source-file-index (lookup-utf8 source-file-index)))) + (t + (dotimes (i length) + (read-u1 stream)))))) + +(defun read-info (index stream type) + (let* ((access-flags (read-u2 stream)) + (name-index (read-u2 stream)) + (descriptor-index (read-u2 stream)) + (attributes-count (read-u2 stream)) + (*indent* (+ *indent* 2)) + (type (case type + ('field "Field") + ('method "Method")))) + (out "~A ~D: Access flags: #x~X~%" type index access-flags) + (out "~A ~D: Name index: ~D (~S)~%" type index name-index (lookup-utf8 name-index)) + (out "~A ~D: Descriptor index: ~D~%" type index descriptor-index) + (out "~A ~D: Number of attributes: ~D~%" type index attributes-count) + (let ((*indent* (+ *indent* 2))) + (dotimes (i attributes-count) + (read-attribute i stream))))) + +(defun dump-class (filename) + (let ((*indent* 0) + (*pool* nil)) + (with-open-file (stream filename :direction :input :element-type 'unsigned-byte) + (handler-bind ((end-of-file + #'(lambda (c) (return-from dump-class c)))) + (out "Magic number: #x~X~%" (read-u4 stream)) + (let ((minor (read-u2 stream)) + (major (read-u2 stream))) + (out "Version: ~D.~D~%" major minor)) + ;; Constant pool. + (let ((count (read-u2 stream)) + entry type) + (out "Constant pool (~D entries):~%" count) + (setq *pool* (make-array count)) + (let ((*indent* (+ *indent* 2))) + (dotimes (index (1- count)) + (setq entry (read-constant-pool-entry stream)) + (setf (svref *pool* (1+ index)) entry) + (setq type (case (car entry) + (7 'class) + (9 'field) + (10 'method) + (11 'interface) + (8 'string) + (3 'integer) + (4 'float) + (5 'long) + (6 'double) + (12 'name-and-type) + (1 'utf8))) + (out "~D: ~A ~S~%" (1+ index) type entry)))) + (out "Access flags: #x~X~%" (read-u2 stream)) + (out "This class: ~D~%" (read-u2 stream)) + (out "Superclass: ~D~%" (read-u2 stream)) + ;; Interfaces. + (let ((count (read-u2 stream))) + (cond ((zerop count) + (out "No interfaces~%")) + (t + (out "Interfaces (~D):~%" count) + (dotimes (i count) + (out " ~D: ~D~%" i (read-u2 stream)))))) + ;; Fields. + (let ((count (read-u2 stream))) + (cond ((zerop count) + (out "No fields~%")) + (t + (out "Fields (~D):~%" count))) + (dotimes (index count) + (read-info index stream 'field))) + ;; Methods. + (let ((count (read-u2 stream))) + (cond ((zerop count) + (out "No methods~%")) + (t + (out "Methods (~D):~%" count))) + (dotimes (index count) + (read-info index stream 'method))) + ;; Attributes. + (let ((count (read-u2 stream))) + (cond ((zerop count) + (out "No attributes~%")) + (t + (out "Attributes (~D):~%" count))) + (dotimes (index count) + (read-attribute index stream)))))) + t) Added: branches/save-image/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/dump-form.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,121 @@ +;;; dump-form.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $Id: dump-form.lisp 11566 2009-01-18 21:04:07Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export 'dump-form) + +(declaim (ftype (function (cons stream) t) dump-cons)) +(defun dump-cons (object stream) + (cond ((and (eq (car object) 'QUOTE) (= (length object) 2)) + (%stream-write-char #\' stream) + (dump-object (%cadr object) stream)) + (t + (%stream-write-char #\( stream) + (loop + (dump-object (%car object) stream) + (setf object (%cdr object)) + (when (null object) + (return)) + (when (> (charpos stream) 80) + (%stream-terpri stream)) + (%stream-write-char #\space stream) + (when (atom object) + (%stream-write-char #\. stream) + (%stream-write-char #\space stream) + (dump-object object stream) + (return))) + (%stream-write-char #\) stream)))) + +(declaim (ftype (function (t stream) t) dump-vector)) +(defun dump-vector (object stream) + (write-string "#(" stream) + (let ((length (length object))) + (when (> length 0) + (dotimes (i (1- length)) + (declare (type index i)) + (dump-object (aref object i) stream) + (when (> (charpos stream) 80) + (%stream-terpri stream)) + (%stream-write-char #\space stream)) + (dump-object (aref object (1- length)) stream)) + (%stream-write-char #\) stream))) + +(declaim (ftype (function (t stream) t) dump-instance)) +(defun dump-instance (object stream) + (multiple-value-bind (creation-form initialization-form) + (make-load-form object) + (write-string "#." stream) + (if initialization-form + (let* ((instance (gensym)) + load-form) + (setf initialization-form + (subst instance object initialization-form)) + (setf initialization-form + (subst instance (list 'quote instance) initialization-form + :test #'equal)) + (setf load-form `(progn + (let ((,instance ,creation-form)) + ,initialization-form + ,instance))) + (dump-object load-form stream)) + (dump-object creation-form stream)))) + +(declaim (ftype (function (t stream) t) dump-object)) +(defun dump-object (object stream) + (cond ((consp object) + (dump-cons object stream)) + ((stringp object) + (%stream-output-object object stream)) + ((bit-vector-p object) + (%stream-output-object object stream)) + ((vectorp object) + (dump-vector object stream)) + ((or (structure-object-p object) ;; FIXME instance-p + (standard-object-p object) + (java:java-object-p object)) + (dump-instance object stream)) + (t + (%stream-output-object object stream)))) + +(declaim (ftype (function (t stream) t) dump-form)) +(defun dump-form (form stream) + (let ((*print-fasl* t) + (*print-level* nil) + (*print-length* nil) + (*print-circle* nil) + (*print-structure* t) + ;; make sure to write all floats with their exponent marker: + ;; the dump-time default may not be the same at load-time + (*read-default-float-format* nil)) + (dump-object form stream))) + +(provide 'dump-form) Added: branches/save-image/src/org/armedbear/lisp/early-defuns.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/early-defuns.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,276 @@ +;;; early-defuns.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: early-defuns.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(export '(index java-long %type-error check-sequence-bounds require-type + normalize-type)) + +;; (deftype index () '(integer 0 (#.most-positive-fixnum))) +(put 'index 'deftype-definition + (lambda () '(integer 0 (#.most-positive-fixnum)))) + +;; (deftype java-long () +;; '(integer #.most-negative-java-long #.most-positive-java-long)) +(put 'java-long 'deftype-definition + (lambda () '(integer #.most-negative-java-long #.most-positive-java-long))) + +(defun %type-error (datum expected-type) + (error 'type-error :datum datum :expected-type expected-type)) + +(defun check-sequence-bounds (sequence start end) + (declare (optimize speed)) + (unless (fixnump start) + (%type-error start 'fixnum)) + (if end + (unless (fixnump end) + (%type-error end 'fixnum)) + (setf end (length sequence))) + end) + +(defun require-type (arg type) + (if (typep arg type) + arg + (error 'simple-type-error + :datum arg + :expected-type type))) + +(defun normalize-type (type) + (cond ((symbolp type) + (case type + (BIT + (return-from normalize-type '(integer 0 1))) + (CONS + (return-from normalize-type '(cons t t))) + (FIXNUM + (return-from normalize-type + '(integer #.most-negative-fixnum #.most-positive-fixnum))) + (SIGNED-BYTE + (return-from normalize-type 'integer)) + (UNSIGNED-BYTE + (return-from normalize-type '(integer 0 *))) + (BASE-CHAR + (return-from normalize-type 'character)) + (SHORT-FLOAT + (return-from normalize-type 'single-float)) + (LONG-FLOAT + (return-from normalize-type 'double-float)) + (COMPLEX + (return-from normalize-type '(complex *))) + (ARRAY + (return-from normalize-type '(array * *))) + (SIMPLE-ARRAY + (return-from normalize-type '(simple-array * *))) + (VECTOR + (return-from normalize-type '(array * (*)))) + (SIMPLE-VECTOR + (return-from normalize-type '(simple-array t (*)))) + (BIT-VECTOR + (return-from normalize-type '(bit-vector *))) + (SIMPLE-BIT-VECTOR + (return-from normalize-type '(simple-bit-vector *))) + (BASE-STRING + (return-from normalize-type '(array base-char (*)))) + (SIMPLE-BASE-STRING + (return-from normalize-type '(simple-array base-char (*)))) + (STRING + (return-from normalize-type '(string *))) + (SIMPLE-STRING + (return-from normalize-type '(simple-string *))) + ((nil) + (return-from normalize-type nil)) + (t + (unless (get type 'deftype-definition) + (return-from normalize-type type))))) + ((classp type) + (return-from normalize-type + (if (eq (%class-name type) 'fixnum) + '(integer #.most-negative-fixnum #.most-positive-fixnum) + type))) + ((and (consp type) + (memq (%car type) '(and or not eql member satisfies mod values))) + (cond ((or (equal type '(and fixnum unsigned-byte)) + (equal type '(and unsigned-byte fixnum))) + (return-from normalize-type '(integer 0 #.most-positive-fixnum))) + (t + (return-from normalize-type type))))) + ;; Fall through... + (let (tp i) + (loop + (if (consp type) + (setf tp (%car type) i (%cdr type)) + (setf tp type i nil)) + (if (and (symbolp tp) (get tp 'deftype-definition)) + (setf type (apply (get tp 'deftype-definition) i)) + (return))) + (case tp + (INTEGER + (return-from normalize-type (if i (cons tp i) tp))) + (CONS + (let* ((len (length i)) + (car-typespec (if (> len 0) (car i) t)) + (cdr-typespec (if (> len 1) (cadr i) t))) + (unless (and car-typespec cdr-typespec) + (return-from normalize-type nil)) + (when (eq car-typespec '*) + (setf car-typespec t)) + (when (eq cdr-typespec '*) + (setf cdr-typespec t)) + (return-from normalize-type (cons tp (list car-typespec cdr-typespec))))) + (SIGNED-BYTE + (if (or (null i) (eq (car i) '*)) + (return-from normalize-type 'integer) + (return-from normalize-type + (list 'integer + (- (expt 2 (1- (car i)))) + (1- (expt 2 (1- (car i)))))))) + (UNSIGNED-BYTE + (if (or (null i) (eq (car i) '*)) + (return-from normalize-type '(integer 0 *))) + (return-from normalize-type (list 'integer 0 (1- (expt 2 (car i)))))) + ((ARRAY SIMPLE-ARRAY) + (unless i + (return-from normalize-type (list tp '* '*))) + (when (= (length i) 1) + (setf i (append i '(*)))) + (setf (car i) (normalize-type (car i))) + (return-from normalize-type (cons tp i))) + (VECTOR + (case (length i) + (0 + (return-from normalize-type '(array * (*)))) + (1 + (setf (car i) (normalize-type (car i))) + (return-from normalize-type (list 'array (car i) '(*)))) + (2 + (setf (car i) (normalize-type (car i))) + (return-from normalize-type (list 'array (car i) (list (cadr i))))) + (t + (error "Invalid type specifier ~S." type)))) + (SIMPLE-VECTOR + (case (length i) + (0 + (return-from normalize-type '(simple-array t (*)))) + (1 + (return-from normalize-type (list 'simple-array t (list (car i))))) + (t + (error "Invalid type specifier ~S." type)))) + (BIT-VECTOR + (case (length i) + (0 + (return-from normalize-type '(bit-vector *))) + (1 + (return-from normalize-type (list 'bit-vector (car i)))) + (t + (error "Invalid type specifier ~S." type)))) + (SIMPLE-BIT-VECTOR + (case (length i) + (0 + (return-from normalize-type '(simple-bit-vector *))) + (1 + (return-from normalize-type (list 'simple-bit-vector (car i)))) + (t + (error "Invalid type specifier ~S." type)))) + (BASE-STRING + (if i + (return-from normalize-type (list 'array 'base-char (list (car i)))) + (return-from normalize-type '(array base-char (*))))) + (SIMPLE-BASE-STRING + (if i + (return-from normalize-type (list 'simple-array 'base-char (list (car i)))) + (return-from normalize-type '(simple-array base-char (*))))) + (SHORT-FLOAT + (setf tp 'single-float)) + (LONG-FLOAT + (setf tp 'double-float)) + (COMPLEX + (cond ((null i) + (return-from normalize-type '(complex *))) + ((eq (car i) 'short-float) + (return-from normalize-type '(complex single-float))) + ((eq (car i) 'long-float) + (return-from normalize-type '(complex double-float)))))) + (if i (cons tp i) tp))) + +(defun caaaar (list) (car (car (car (car list))))) +(defun caaadr (list) (car (car (car (cdr list))))) +(defun caaddr (list) (car (car (cdr (cdr list))))) +(defun cadddr (list) (car (cdr (cdr (cdr list))))) +(defun cddddr (list) (cdr (cdr (cdr (cdr list))))) +(defun cdaaar (list) (cdr (car (car (car list))))) +(defun cddaar (list) (cdr (cdr (car (car list))))) +(defun cdddar (list) (cdr (cdr (cdr (car list))))) +(defun caadar (list) (car (car (cdr (car list))))) +(defun cadaar (list) (car (cdr (car (car list))))) +(defun cadadr (list) (car (cdr (car (cdr list))))) +(defun caddar (list) (car (cdr (cdr (car list))))) +(defun cdaadr (list) (cdr (car (car (cdr list))))) +(defun cdadar (list) (cdr (car (cdr (car list))))) +(defun cdaddr (list) (cdr (car (cdr (cdr list))))) +(defun cddadr (list) (cdr (cdr (car (cdr list))))) + +;;; SOME, EVERY, NOTANY, NOTEVERY (adapted from ECL) + +(defun some (predicate sequence &rest more-sequences) + (setq more-sequences (cons sequence more-sequences)) + (do ((i 0 (1+ i)) + (l (apply #'min (mapcar #'length more-sequences)))) + ((>= i l) nil) + (let ((that-value + (apply predicate + (mapcar #'(lambda (z) (elt z i)) more-sequences)))) + (when that-value (return that-value))))) + +(defun every (predicate sequence &rest more-sequences) + (declare (optimize speed)) + (cond ((null more-sequences) + (cond ((listp sequence) + (dolist (x sequence t) + (unless (funcall predicate x) + (return nil)))) + (t + (dotimes (i (length sequence) t) + (declare (type index i)) + (unless (funcall predicate (elt sequence i)) + (return nil)))))) + (t + (setq more-sequences (cons sequence more-sequences)) + (do ((i 0 (1+ i)) + (l (apply #'min (mapcar #'length more-sequences)))) + ((>= i l) t) + (unless (apply predicate (mapcar #'(lambda (z) (elt z i)) more-sequences)) + (return nil)))))) + +(defun notany (predicate sequence &rest more-sequences) + (not (apply #'some predicate sequence more-sequences))) + +(defun notevery (predicate sequence &rest more-sequences) + (not (apply #'every predicate sequence more-sequences))) Added: branches/save-image/src/org/armedbear/lisp/ed.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ed.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,127 @@ +;;; ed.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $Id: ed.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defun ed (&optional x) + "Starts the editor (on a file or a function if named). Functions +from the list *ED-FUNCTIONS* are called in order with X as an argument +until one of them returns non-NIL; these functions are responsible for +signalling a FILE-ERROR to indicate failure to perform an operation on +the file system." + (dolist (fun *ed-functions* + (error 'simple-error + :format-control "Don't know how to ~S ~A" + :format-arguments (list 'ed x))) + (when (funcall fun x) + (return))) + (values)) + +(defun default-ed-function (what) + (let ((portfile (merge-pathnames ".j/port" + (if (featurep :windows) + (if (ext:probe-directory "C:\\.j") + "C:\\" + (ext:probe-directory (pathname (ext:getenv "APPDATA")))) + (user-homedir-pathname)))) + stream) + (when (probe-file portfile) + (let* ((port (with-open-file (s portfile) (read s nil nil))) + (socket (and (integerp port) (make-socket "127.0.0.1" port)))) + (setf stream (and socket (get-socket-stream socket))))) + (unwind-protect + (cond ((stringp what) + (if stream + (progn + (write-string (namestring (user-homedir-pathname)) stream) + (terpri stream) + (write-string (format nil "~S~%" what) stream)) + (run-shell-command (format nil "j ~S" what)))) + ((and what (symbolp what)) + (when (autoloadp what) + (let ((*load-verbose* nil) + (*load-print* nil) + (*autoload-verbose* nil)) + (resolve what))) + (cond ((source what) + (let ((file (namestring (source-pathname what))) + (position (source-file-position what)) + (line-number 1) + (pattern (string what))) + (with-open-file (s file) + (dotimes (i position) + (let ((c (read-char s nil s))) + (cond ((eq c s) + (return)) + ((eql c #\newline) + (incf line-number))))) + (dotimes (i 10) + (let ((text (read-line s nil s))) + (cond ((eq text s) + (return)) + ((search pattern text :test 'string-equal) + (return)) + (t + (incf line-number)))))) + (if stream + (progn + (write-string (namestring (user-homedir-pathname)) stream) + (terpri stream) + (write-string (format nil "+~D~%~S~%" line-number file) stream)) + (run-shell-command (format nil "j +~D ~S" line-number file))))) + ((not (null *lisp-home*)) + (let ((tagfile (merge-pathnames "tags" *lisp-home*))) + (when (and tagfile (probe-file tagfile)) + (with-open-file (s tagfile) + (loop + (let ((text (read-line s nil s))) + (cond ((eq text s) + (return)) + ((eq what (read-from-string text nil nil)) + ;; Found it! + (with-input-from-string (string-stream text) + (let* ((symbol (read string-stream text nil nil)) ; Ignored. + (file (read string-stream text nil nil)) + (line-number (read string-stream text nil nil))) + (declare (ignore symbol)) + (when (pathnamep file) + (setf file (namestring file))) + (if stream + (progn + (write-string (namestring (user-homedir-pathname)) stream) + (terpri stream) + (write-string (format nil "+~D~%~S~%" line-number file) stream)) + (run-shell-command (format nil "j +~D ~S" line-number file)))))))))))))))) + (when stream + (close stream)))) + t) Added: branches/save-image/src/org/armedbear/lisp/emacs.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/emacs.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,517 @@ +;;; emacs.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: emacs.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:j) + +(export '(emacs-mode + java-mode-map + lisp-mode-map + lisp-shell-mode-map + directory-mode-map)) + +(defpackage #:emacs + (:use #:cl #:ext #:j)) + +(in-package #:emacs) + +(defun set-mark-command () + (setf (buffer-mark (current-buffer)) (current-point)) + (status "Mark set")) + +(defun define-keys (map mappings) + (dolist (mapping mappings) + (define-key map (first mapping) (second mapping)))) + +(defparameter *emacs-global-map* (make-keymap)) +(defparameter *esc-map* (make-keymap)) +(defparameter *control-x-map* (make-keymap)) +(defparameter *help-map* (make-keymap)) +(defparameter *java-mode-map* (make-keymap)) + +(define-key *emacs-global-map* "Escape" *esc-map*) +(define-key *emacs-global-map* "Ctrl X" *control-x-map*) +(define-key *emacs-global-map* "Ctrl H" *help-map*) + +;; // File menu. +(define-key *control-x-map* "Ctrl F" "openFile") +;; mapKey(KeyEvent.VK_O, CTRL_MASK | ALT_MASK, "openFileInOtherWindow"); +;; mapKey(KeyEvent.VK_O, CTRL_MASK | SHIFT_MASK, "openFileInOtherFrame"); +;; mapKey(KeyEvent.VK_N, CTRL_MASK, "newBuffer"); +;; mapKey(KeyEvent.VK_R, ALT_MASK, "recentFiles"); +(define-key *control-x-map* "Ctrl S" "save") +;; mapKey(KeyEvent.VK_S, CTRL_MASK | SHIFT_MASK, "saveAs"); +;; mapKey(KeyEvent.VK_S, CTRL_MASK | ALT_MASK, "saveCopy"); +;; mapKey(KeyEvent.VK_F2, 0, "saveAll"); + +;; j's killBuffer is really kill-this-buffer +(define-key *control-x-map* "k" "killBuffer") + +;; mapKey(KeyEvent.VK_P, ALT_MASK, "properties"); +;; mapKey(KeyEvent.VK_N, CTRL_MASK | SHIFT_MASK, "newFrame"); +(define-key *emacs-global-map* "Alt X" "executeCommand") +(define-key *esc-map* #\x "executecommand") +;; mapKey(KeyEvent.VK_P, CTRL_MASK, "print"); +;; mapKey(KeyEvent.VK_Q, CTRL_MASK | SHIFT_MASK, "saveAllExit"); +(define-key *control-x-map* "Ctrl C" "saveAllExit") + +(define-key *emacs-global-map* "Ctrl Space" #'set-mark-command) +(define-key *emacs-global-map* "Ctrl Shift 2" #'set-mark-command) ; C-@ + +;; // Edit menu. +(define-keys *emacs-global-map* + `(("Ctrl /" "undo") + ("Ctrl Shift 0x2d" "undo") ; C-_ + ("Shift Alt 0x2d" "redo") ; M-_ + ("Ctrl W" "killRegion") + ("Shift Delete" "killRegion") + ("Alt W" "copyRegion") + ("Ctrl NumPad Insert" "copyRegion") + ("Ctrl Y" "paste") + ("Shift NumPad Insert" "paste") + ("Alt Y" "cyclePaste"))) + +(define-key *control-x-map* "u" "undo") +(define-key *esc-map* #\y "cyclePaste") +;; mapKey(KeyEvent.VK_X, CTRL_MASK | SHIFT_MASK, "killAppend"); +;; mapKey(KeyEvent.VK_C, CTRL_MASK | SHIFT_MASK, "copyAppend"); +;; mapKey(KeyEvent.VK_T, ALT_MASK, "cycleTabWidth"); + +;; // Goto menu. +;; mapKey(KeyEvent.VK_J, CTRL_MASK, "jumpToLine"); +(define-key *emacs-global-map* "Alt G" "jumpToLine") +(define-key *esc-map* #\g "jumpToLine") +;; mapKey(KeyEvent.VK_J, CTRL_MASK | SHIFT_MASK, "jumpToColumn"); +;; mapKey(KeyEvent.VK_M, CTRL_MASK, "findMatchingChar"); +;; mapKey(KeyEvent.VK_M, CTRL_MASK | SHIFT_MASK, "selectSyntax"); + +(define-keys *emacs-global-map* + '(("Ctrl Alt Up" "findFirstOccurrence") + ("Ctrl Alt NumPad Up" "findFirstOccurrence") + ("Alt Up" "findPrevWord") + ("Alt NumPad Up" "findPrevWord") + ("Alt Down" "findNextWord") + ("Alt NumPad Down" "findNextWord"))) + +;; mapKey(KeyEvent.VK_N, CTRL_MASK | ALT_MASK, "nextChange"); +;; mapKey(KeyEvent.VK_P, CTRL_MASK | ALT_MASK, "previousChange"); +(define-key *emacs-global-map* "F5" "pushPosition") +(define-key *emacs-global-map* "Shift F5" "popPosition") + +;; // Search menu. +(define-keys *emacs-global-map* + '(("Ctrl S" "incrementalFind") + ("Alt F3" "find") + ("F3" "findNext") + ("Shift F3" "findPrev") + ("F6" "findInFiles") + ("Ctrl Shift F" "findInFiles") + ("Ctrl F3" "listOccurrences") + ("Ctrl Shift L" "listFiles") + ("Shift Alt 5" "replace") ; M-% + ("Ctrl Shift R" "replaceInFiles"))) + +;; Emacs uses Ctrl Alt L for reposition-window +;; XEmacs uses Ctrl Alt L for switch-to-other-buffer +(define-key *emacs-global-map* "Ctrl Alt L" "listOccurrencesOfPatternAtDot") + +;; mapKey(KeyEvent.VK_K, CTRL_MASK, "killLine"); +(define-key *emacs-global-map* "Ctrl K" "killLine") +;; mapKey(KeyEvent.VK_DELETE, CTRL_MASK, "deleteWordRight"); +(define-key *emacs-global-map* "Ctrl Delete" "deleteWordRight") + +(define-keys *emacs-global-map* + '(("Home" "home") + ("Ctrl A" "home") + ("End" "end"); + ("Ctrl E" "end"); + ("Shift Home" "selectHome") + ("Shift End" "selectEnd") + ("Ctrl Home" "bob") + ("Ctrl Shift Home" "selectBob") + ("Ctrl End" "eob") + ("Ctrl Shift End" "selectEob") + ("Ctrl P" "up") + ("Up" "up") + ("NumPad Up" "up") + ("Ctrl N" "down") + ("Down" "down") + ("NumPad Down" "down") + ("Shift Up" "selectUp") + ("Shift NumPad Up" "selectUp") + ("Shift Down" "selectDown") + ("Shift NumPad Down" "selectDown") + ("Ctrl B" "left") + ("Left" "left") + ("NumPad Left" "left") + ("Ctrl F" "right") + ("Right" "right") + ("NumPad Right" "right") + ("Shift Left" "selectLeft") + ("Shift NumPad Left" "selectLeft") + ("Shift Right" "selectRight") + ("Shift NumPad Right" "selectRight") + ("Alt B" "wordLeft") + ("Ctrl Left" "wordLeft") + ("Ctrl NumPad Left" "wordLeft") + ("Ctrl Right" "wordRight") + ("Ctrl NumPad Right" "wordRight") + ("Ctrl Shift Left" "selectWordLeft") + ("Ctrl Shift NumPad Left" "selectWordLeft") + ("Ctrl Shift Right" "selectWordRight") + ("Ctrl Shift NumPad Right" "selectWordRight") + ("Alt V" "pageUp") + ("Page Up" "pageUp") + ("Ctrl V" "pageDown") + ("Page Down" "pageDown"))) + +(define-keys *esc-map* + '((#\< "bob") + (#\> "eob") + (#\. "findTagAtDot") + (#\, "listMatchingTagsAtDot") + (#\% "replace") + )) + +;; Emacs uses Ctrl Up for backward-paragraph, which j doesn't have. +(define-keys *emacs-global-map* + '(("Ctrl Up" "windowUp") + ("Ctrl NumPad Up" "windowUp"))) +;; Emacs uses Ctrl Down for forward-paragraph, which j doesn't have. +(define-keys *emacs-global-map* + '(("Ctrl Down" "windowDown") + ("Ctrl NumPad Down" "windowDown"))) + +;; Emacs uses Alt Left for backward-word, which is also on Alt B and Ctrl Left. +(define-keys *emacs-global-map* + '(("Alt Left" "prevBuffer") + ("Alt NumPad Left" "prevBuffer"))) +;; Emacs uses Alt Right for forward-word, which is also on Alt F and Ctrl Right. +(define-keys *emacs-global-map* + '(("Alt Right" "nextBuffer") + ("Alt NumPad Right" "nextBuffer"))) + +;; mapKey(KeyEvent.VK_PAGE_UP, ALT_MASK, "pageUpOtherWindow"); +;; mapKey(KeyEvent.VK_PAGE_UP, SHIFT_MASK, "selectPageUp"); +;; mapKey(KeyEvent.VK_PAGE_DOWN, ALT_MASK, "pageDownOtherWindow"); +;; mapKey(KeyEvent.VK_PAGE_DOWN, SHIFT_MASK, "selectPageDown"); +;; mapKey(KeyEvent.VK_PAGE_UP, CTRL_MASK, "top"); +;; mapKey(KeyEvent.VK_PAGE_DOWN, CTRL_MASK, "bottom"); +;; mapKey(KeyEvent.VK_DELETE, 0, "delete"); +(define-keys *emacs-global-map* + '(("Delete" "delete") + ("Ctrl D" "delete") + ("Backspace" "backspace") + ("Shift Backspace" "backspace") + ("Ctrl Backspace" "deleteWordLeft") + ("Enter" "newline") + ("Ctrl M" "newline") + ("Ctrl J" "newlineAndIndent"))) + +(define-key *emacs-global-map* "Shift Alt 9" "insertParentheses") +(define-key *emacs-global-map* "Shift Alt 0" "movePastCloseAndReindent") + +(define-key *emacs-global-map* "Ctrl G" "escape") ; keyboard-quit + +(define-key *emacs-global-map* "Ctrl Shift G" "gotoFile") +(define-key *emacs-global-map* "Ctrl Shift B" "browsefileatdot") + +(define-key *control-x-map* #\d "dir") + +;; mapKey(KeyEvent.VK_F2, SHIFT_MASK, "stamp"); + +;; mapKey(KeyEvent.VK_A, CTRL_MASK, "selectAll"); + +;; mapKey(KeyEvent.VK_OPEN_BRACKET, ALT_MASK, "slideOut"); +;; mapKey(KeyEvent.VK_CLOSE_BRACKET, ALT_MASK, "slideIn"); + +;; // Bookmarks MUST be mapped like this! +;; mapKey(KeyEvent.VK_0, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_1, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_2, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_3, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_4, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_5, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_6, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_7, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_8, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_9, ALT_MASK, "dropBookmark"); +;; mapKey(KeyEvent.VK_0, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_1, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_2, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_3, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_4, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_5, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_6, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_7, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_8, CTRL_MASK, "gotoBookmark"); +;; mapKey(KeyEvent.VK_9, CTRL_MASK, "gotoBookmark"); + +;; // Temporary marker commands. +;; mapKey(KeyEvent.VK_BACK_SLASH, ALT_MASK, "dropTemporaryMarker"); +;; mapKey(KeyEvent.VK_BACK_SLASH, CTRL_MASK, "gotoTemporaryMarker"); +;; mapKey(KeyEvent.VK_BACK_SLASH, CTRL_MASK | SHIFT_MASK, "selectToTemporaryMarker"); + +;; mapKey(KeyEvent.VK_F11, 0, "commentRegion"); +(define-key *emacs-global-map* "F11" "commentRegion") +;; mapKey(KeyEvent.VK_F11, SHIFT_MASK, "uncommentRegion"); +(define-key *emacs-global-map* "Shift F11" "uncommentRegion") + +;; // Duplicate mappings to support IBM 1.3 for Linux. +;; mapKey(0xffc8, 0, "commentRegion"); +;; mapKey(0xffc8, SHIFT_MASK, "uncommentRegion"); + +;; mapKey(KeyEvent.VK_F12, 0, "wrapParagraph"); +(define-key *emacs-global-map* "F12" "wrapParagraph") +;; mapKey(KeyEvent.VK_F12, SHIFT_MASK, "unwrapParagraph"); +(define-key *emacs-global-map* "Shift F12" "unwrapParagraph") +;; mapKey(KeyEvent.VK_F12, CTRL_MASK, "toggleWrap"); +(define-key *emacs-global-map* "Ctrl F12" "toggleWrap") + +;; // Duplicate mappings to support IBM 1.3 for Linux. +;; mapKey(0xffc9, 0, "wrapParagraph"); // F12 +;; mapKey(0xffc9, SHIFT_MASK, "unwrapParagraph"); // Shift F12 +;; mapKey(0xffc9, CTRL_MASK, "toggleWrap"); // Ctrl F12 + +;; mapKey(KeyEvent.VK_T, CTRL_MASK | ALT_MASK, "visibleTabs"); + +;; mapKey(KeyEvent.VK_SLASH, ALT_MASK, "expand"); +(define-key *emacs-global-map* "Alt /" "expand") + +;; // On Windows, Alt Space drops down the window menu. +;; if (!Platform.isPlatformWindows()) +;; mapKey(KeyEvent.VK_SPACE, ALT_MASK, "expand"); + +;; mapKey(KeyEvent.VK_N, ALT_MASK, "nextFrame"); + +;; mapKey(KeyEvent.VK_W, ALT_MASK, "selectWord"); + +;; FIXME These are j's normal mouse bindings. We don't have the required +;; functionality in the right form to support the emacs mouse bindings. +(define-keys *emacs-global-map* + '(("Mouse-1" "mouseMoveDotToPoint") + ("Shift Mouse-1" "mouseSelect") + ("Ctrl Shift Mouse-1" "mouseSelectColumn") + ("Double Mouse-1" "selectWord") + ("Mouse-3" "mouseShowContextMenu"))) + +(when (featurep :unix) + (define-key *emacs-global-map* "Mouse-2" "pastePrimarySelection")) + +(define-keys *control-x-map* + '((#\( "startMacro") + (#\) "endMacro") + (#\e "playbackMacro"))) + +;; mapKey(KeyEvent.VK_W, CTRL_MASK | SHIFT_MASK, "killFrame"); + +;; // Sidebar. +;; mapKey(KeyEvent.VK_EQUALS, ALT_MASK, "toggleSidebar"); +;; mapKey(KeyEvent.VK_B, ALT_MASK, "sidebarListBuffers"); +;; mapKey(KeyEvent.VK_T, CTRL_MASK | SHIFT_MASK, "sidebarListTags"); + +(define-keys *control-x-map* + '(("2" "splitWindow") + ("1" "unsplitwindow") + ("0" "killWindow") + ("o" "otherwindow"))) + +(when (get-global-property 'enable-experimental-features) + (define-key *emacs-global-map* "Alt F9" "shell")) + +(define-key *control-x-map* "`" "nextError") +(define-key *emacs-global-map* "F4" "nextError") +(define-key *emacs-global-map* "Shift F4" "previousError") +(define-key *emacs-global-map* "Ctrl Alt M" "showMessage") + +;; FIXME We need a binding for findTag. +(define-key *emacs-global-map* "Alt ." "findTagAtDot") +(define-key *emacs-global-map* "Alt ," "listMatchingTagsAtDot") + +;;; Help. + +(define-keys *help-map* + '(("a" "apropos") + ("b" "describeBindings") + ("c" "describeKey") ; describe-key-briefly + ("i" "help") + ("k" "describeKey"))) + +;;; Java mode. + +(define-keys *java-mode-map* + '(("{" "electricOpenBrace") + ("}" "electricCloseBrace") + ("Tab" "tab") + ("Ctrl Tab" "insertTab") + ("';'" "electricSemi") + (#\: "electricColon") + (#\* "electricStar") + (#\) "closeParen") + ("Ctrl Shift [" "insertBraces") + ("F12" "wrapComment") + ("F9" "compile") + ("Ctrl F9" "recompile") + ("Alt F1" "jdkHelp") + ("Ctrl F1" "source"))) + +(defun java-mode-map () + *java-mode-map*) + +;;; Lisp mode + +(defparameter *lisp-mode-map* (make-keymap)) +(defparameter *lisp-mode-control-c-map* (make-keymap)) +(defparameter *lisp-mode-control-x-map* (make-keymap)) +(define-key *lisp-mode-map* "Ctrl C" *lisp-mode-control-c-map*) +(define-key *lisp-mode-map* "Ctrl X" *lisp-mode-control-x-map*) + +(define-keys *lisp-mode-map* + '(("Tab" "tab") + ("Ctrl Tab" "insertTab") + ("F12" "wrapComment") + (#\) "closeParen") + ("Alt F1" "hyperspec") + ("Ctrl Alt F" "forwardSexp") + ("Ctrl Alt B" "backwardSexp") + ("Ctrl Alt Space" "markSexp") + ("Ctrl Alt D" "downList") + ("Ctrl Alt U" "backwardUpList") + ("Ctrl Alt X" "evalDefunLisp"))) + +(define-keys *lisp-mode-control-c-map* + '(("Ctrl C" "compileDefunLisp") + ("Ctrl R" "evalRegionLisp"))) + +(defun lisp-mode-map () + *lisp-mode-map*) + +;;; Lisp shell mode + +(defparameter *lisp-shell-mode-map* (make-keymap)) +(defparameter *lisp-shell-mode-esc-map* (make-keymap)) +(defparameter *lisp-shell-mode-control-c-map* (make-keymap)) +(define-key *lisp-shell-mode-map* "Escape" *lisp-shell-mode-esc-map*) +(define-key *lisp-shell-mode-map* "Ctrl C" *lisp-shell-mode-control-c-map*) + +(define-keys *lisp-shell-mode-map* + '(("Home" "shellHome") + ("Ctrl A" "shellHome") + ("Backspace" "shellbackspace") + ("Alt P" "shellPreviousInput") + ("Alt N" "shellNextInput") + ("Enter" "LispShellMode.enter") + ("Alt Enter" "newlineandindent") + ("Ctrl R" "resetLisp") + ("Tab" "indentLineOrRegion") + ("Alt F1" "hyperspec"))) + +(define-keys *lisp-shell-mode-esc-map* + '((#\p "shellPreviousInput") + (#\n "shellNextInput"))) + +(define-keys *lisp-shell-mode-control-c-map* + '(("Ctrl C" "shellInterrupt") + ("Ctrl P" "shellPreviousPrompt") + ("Ctrl N" "shellNextPrompt"))) + +(defun lisp-shell-mode-map () + *lisp-shell-mode-map*) + +;;; Slime + +(defun define-keys-for-slime () + (define-keys *lisp-mode-map* + '(("Space" "(slime:slime-space)") + ("Alt ." "(slime:slime-edit-definition)") + ("Ctrl Alt I" "(slime:slime-complete-symbol)") + ("Ctrl Alt X" "(slime:slime-eval-defun)"))) + (define-keys *lisp-mode-control-c-map* + '(("Tab" "(slime:slime-complete-symbol)") + ("Ctrl C" "(slime:slime-compile-defun)") + ("Ctrl I" "(slime:slime-complete-symbol)") + ("Ctrl K" "(slime:slime-compile-and-load-file)") + ("Ctrl R" "(slime:slime-eval-region)"))) + (define-keys *lisp-mode-control-x-map* + '(("Ctrl E" "(slime:slime-eval-last-expression)"))) + (define-keys *lisp-shell-mode-map* + '(("Tab" "(slime:slime-complete-symbol)") + ("Space" "(slime:slime-space)") + ("Alt ." "(slime:slime-edit-definition)") + ("Ctrl Alt I" "(slime:slime-complete-symbol)"))) + (define-keys *lisp-shell-mode-esc-map* + '(("Tab" "(slime:slime-complete-symbol)"))) + (define-keys *lisp-shell-mode-control-c-map* + '(("Tab" "(slime:slime-complete-symbol)")))) + +;;; Directory mode + +(defparameter *directory-mode-map* (make-keymap)) + +;; These are basically j's normal directory mode bindings. J's directory mode +;; doesn't really work like dired in emacs. +(define-keys *directory-mode-map* + '(("Enter" "dirOpenFile") + ("Ctrl Shift G" "diropenfile") + ("Double Mouse-1" "dirOpenFile") + ("Mouse-2" "dirOpenFile") + ("Ctrl Enter" "diropenfileandkilldirectory") + ("Ctrl Shift B" "dirBrowseFile") + ("Backspace" "dirUpDir") + (#\u "dirUpDir") + (#\l "dirLimit") + (#\L "dirUnlimit") + (#\s "dirCycleSortBy") + (#\r "dirRescan") + ("Delete" "dirDeleteFiles") + (#\c "dirCopyFile") + (#\g "dirGetFile") + (#\m "dirMoveFile") + (#\t "dirTagFile") + (#\! "dirDoShellCommand") + ("Home" "dirHome") + (#\b "dirBack") + (#\f "dirForward"))) + +(defun directory-mode-map () + *directory-mode-map*) + +(defun emacs-mode (&optional (arg t)) + (cond (arg + ;; FIXME This is the right idea (so mappings like Alt F will be + ;; possible), but it doesn't work. + (set-global-property "useMenuMnemonics" "false") + (set-global-property "emulation" "emacs") + (use-global-map *emacs-global-map*) + (j::%execute-command "reloadKeyMaps")) + ((null arg) + (set-global-property "useMenuMnemonics" "true") + (set-global-property "emulation" nil) + (j::%execute-command "defaultKeyMaps")))) Added: branches/save-image/src/org/armedbear/lisp/enough-namestring.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/enough-namestring.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,65 @@ +;;; enough-namestring.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: enough-namestring.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(declaim (inline equal-components-p)) +(defun equal-components-p (component1 component2) + #+win32 (equalp component1 component2) + #-win32 (equal component1 component2)) + +(defun enough-namestring (pathname + &optional + (defaults *default-pathname-defaults*)) + (unless (equal (pathname-host pathname) (pathname-host defaults)) + (return-from enough-namestring (namestring pathname))) + (let ((pathname-directory (pathname-directory pathname))) + (if pathname-directory + (let* ((defaults-directory (pathname-directory defaults)) + (prefix-len (length defaults-directory)) + (result-directory + (cond ((and (>= prefix-len 1) + (>= (length pathname-directory) prefix-len) + (equal-components-p (subseq pathname-directory 0 prefix-len) + defaults-directory)) + (cons :relative (nthcdr prefix-len pathname-directory))) + ((eq (car pathname-directory) :absolute) + pathname-directory) + (t + (return-from enough-namestring (namestring pathname)))))) + (if (equal result-directory '(:relative)) + (file-namestring pathname) + (concatenate 'simple-string + (directory-namestring (make-pathname :directory result-directory)) + (file-namestring pathname)))) + (file-namestring pathname)))) Added: branches/save-image/src/org/armedbear/lisp/ensure-directories-exist.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ensure-directories-exist.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,63 @@ +;;; ensure-directories-exist.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $Id: ensure-directories-exist.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package "SYSTEM") + +(defun ensure-directories-exist (pathspec &key verbose) + (let ((pathname (pathname pathspec)) + (created-p nil)) + (when (wild-pathname-p pathname) + (error 'file-error + :format-control "Bad place for a wild pathname." + :pathname pathname)) + (let ((dir (pathname-directory pathname))) + (loop for i from 1 upto (length dir) + do (let ((newpath (make-pathname + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq dir 0 i)))) + (unless (probe-file newpath) + (let ((namestring (namestring newpath))) + (when verbose + (fresh-line) + (format *standard-output* + "Creating directory: ~A~%" + namestring)) + (mkdir namestring) + (unless (probe-file namestring) + (error 'file-error + :pathname pathspec + :format-control "Can't create directory ~A." + :format-arguments (list namestring))) + (setq created-p t))))) + (values pathname created-p)))) Added: branches/save-image/src/org/armedbear/lisp/error.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/error.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,9 @@ +;;; error.lisp + +(in-package "COMMON-LISP") + +(export '(ignore-errors)) + +(defmacro ignore-errors (&rest forms) + `(handler-case (progn , at forms) + (error (condition) (values nil condition)))) Added: branches/save-image/src/org/armedbear/lisp/fdefinition.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/fdefinition.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,105 @@ +;;; fdefinition.lisp +;;; +;;; Copyright (C) 2005-2006 Peter Graves +;;; $Id: fdefinition.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(export '(record-source-information untraced-function)) + +(defun check-redefinition (name) + (when (and *warn-on-redefinition* (fboundp name) (not (autoloadp name))) + (cond ((symbolp name) + (let ((old-source (source-pathname name)) + (current-source (or *source* :top-level))) + (cond ((equal old-source current-source)) ; OK + (t + (if (eq current-source :top-level) + (style-warn "redefining ~S at top level" name) + (let ((*package* +cl-package+)) + (if (eq old-source :top-level) + (style-warn "redefining ~S in ~S (previously defined at top level)" + name current-source) + (style-warn "redefining ~S in ~S (previously defined in ~S)" + name current-source old-source))))))))))) + +(defun record-source-information (name &optional source-pathname source-position) + (unless source-pathname + (setf source-pathname (or *source* :top-level))) + (unless source-position + (setf source-position *source-position*)) + (let ((source (if source-position + (cons source-pathname source-position) + source-pathname))) + (cond ((symbolp name) + (put name '%source source))))) + +;; Redefined in trace.lisp. +(defun trace-redefined-update (&rest args) + (declare (ignore args)) + ) + +;; Redefined in trace.lisp. +(defun untraced-function (name) + (declare (ignore name)) + nil) + +(defun fset (name function &optional source-position arglist documentation) + (cond ((symbolp name) + (check-redefinition name) + (record-source-information name nil source-position) + (when arglist + (%set-arglist function arglist)) + (%set-documentation function 'function documentation) + (%set-symbol-function name function)) + ((setf-function-name-p name) + (check-redefinition name) + (record-source-information name nil source-position) + ;; FIXME arglist documentation + (setf (get (%cadr name) 'setf-function) function)) + (t + (require-type name '(or symbol (cons (eql setf) (cons symbol null)))))) + (when (functionp function) ; FIXME Is this test needed? + (%set-lambda-name function name)) + (trace-redefined-update name function) + function) + +(defun fdefinition (name) + (cond ((symbolp name) + (symbol-function name)) + ((setf-function-name-p name) + (or (get (%cadr name) 'setf-function) + (error 'undefined-function :name name))) + (t + (require-type name '(or symbol (cons (eql setf) (cons symbol null))))))) + +(defun %set-fdefinition (name function) + (fset name function)) + +(defsetf fdefinition %set-fdefinition) Added: branches/save-image/src/org/armedbear/lisp/featurep.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/featurep.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,53 @@ +;;; featurep.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: featurep.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:extensions) + +(export 'featurep) + +(defun featurep (form) + (if (atom form) + (not (null (memq form *features*))) + (case (car form) + ((:not not) + (if (cddr form) + (error "Too many subexpressions in feature expression: ~S" form) + (not (featurep (cadr form))))) + ((:and and) + (dolist (subform (cdr form) t) + (unless (featurep subform) (return)))) + ((:or or) + (dolist (subform (cdr form) nil) + (when (featurep subform) (return t)))) + (t + (error "Unknown operator in feature expression: ~S" form))))) Added: branches/save-image/src/org/armedbear/lisp/file_author.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/file_author.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * file_author.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: file_author.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; + +// ### file-author +public final class file_author extends Primitive +{ + private file_author() + { + super("file-author"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) + error(new FileError("Bad place for a wild pathname.", pathname)); + return NIL; + } + + private static final Primitive FILE_AUTHOR = new file_author(); +} Added: branches/save-image/src/org/armedbear/lisp/file_error_pathname.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/file_error_pathname.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +/* + * file_error_pathname.java + * + * Copyright (C) 2004 Peter Graves + * $Id: file_error_pathname.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### file-error-pathname +public final class file_error_pathname extends Primitive +{ + private file_error_pathname() + { + super("file-error-pathname"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg instanceof FileError ? ((FileError)arg).getPathname() : NIL; + } + + private static final file_error_pathname FILE_ERROR_PATHNAME = + new file_error_pathname(); +} Added: branches/save-image/src/org/armedbear/lisp/file_length.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/file_length.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,57 @@ +/* + * file_length.java + * + * Copyright (C) 2004 Peter Graves + * $Id: file_length.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class file_length extends Primitive +{ + private file_length() + { + super("file-length", "stream"); + } + + // ### file-length + // file-length stream => length + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((Stream)arg).fileLength(); + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.STREAM)); + } + } + + private static final Primitive FILE_LENGTH = new file_length(); +} Added: branches/save-image/src/org/armedbear/lisp/file_string_length.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/file_string_length.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,58 @@ +/* + * file_string_length.java + * + * Copyright (C) 2004 Peter Graves + * $Id: file_string_length.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### file-string-length +public final class file_string_length extends Primitive +{ + private file_string_length() + { + super("file-string-length", "stream object"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + try { + return ((Stream)first).fileStringLength(second); + } + catch (ClassCastException e) { + return error(new TypeError(first, Symbol.STREAM)); + } + } + + private static final Primitive FILE_STRING_LENGTH = + new file_string_length(); +} Added: branches/save-image/src/org/armedbear/lisp/file_write_date.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/file_write_date.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +/* + * file_write_date.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: file_write_date.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; + +// ### file-write-date +public final class file_write_date extends Primitive +{ + private file_write_date() + { + super("file-write-date"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) + error(new FileError("Bad place for a wild pathname.", pathname)); + File file = Utilities.getFile(pathname); + long lastModified = file.lastModified(); + if (lastModified == 0) + return NIL; + return number(lastModified / 1000 + 2208988800L); + } + + private static final Primitive FILE_WRITE_DATE = new file_write_date(); +} Added: branches/save-image/src/org/armedbear/lisp/fill.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/fill.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,58 @@ +;;; fill.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: fill.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; Adapted from CMUCL. + +(defun list-fill (sequence item start end) + (do ((current (nthcdr start sequence) (cdr current)) + (index start (1+ index))) + ((or (atom current) (and end (= index end))) + sequence) + (rplaca current item))) + +(defun vector-fill (sequence item start end) + (unless end + (setf end (length sequence))) + (do ((index start (1+ index))) + ((= index end) sequence) + (setf (aref sequence index) item))) + +(defun fill (sequence item &key (start 0) end) + (cond ((listp sequence) + (list-fill sequence item start end)) + ((and (stringp sequence) + (zerop start) + (null end)) + (simple-string-fill sequence item)) + (t + (vector-fill sequence item start end)))) Added: branches/save-image/src/org/armedbear/lisp/find-all-symbols.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/find-all-symbols.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,41 @@ +;;; find-all-symbols.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: find-all-symbols.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun find-all-symbols (string) + (let ((string (string string)) + (res ())) + (dolist (package (list-all-packages)) + (multiple-value-bind (symbol status) (find-symbol string package) + (when status + (pushnew symbol res)))) + res)) Added: branches/save-image/src/org/armedbear/lisp/find.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/find.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,241 @@ +;;; find.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: find.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; From CMUCL. + +(defmacro vector-locater-macro (sequence body-form return-type) + `(let ((incrementer (if from-end -1 1)) + (start (if from-end (1- (the fixnum end)) start)) + (end (if from-end (1- (the fixnum start)) end))) + (declare (fixnum start end incrementer)) + (do ((index start (+ index incrementer)) + ,@(case return-type (:position nil) (:element '(current)))) + ((= index end) ()) + (declare (fixnum index)) + ,@(case return-type + (:position nil) + (:element `((setf current (aref ,sequence index))))) + ,body-form))) + +(defmacro locater-test-not (item sequence seq-type return-type) + (let ((seq-ref (case return-type + (:position + (case seq-type + (:vector `(aref ,sequence index)) + (:list `(pop ,sequence)))) + (:element 'current))) + (return (case return-type + (:position 'index) + (:element 'current)))) + `(if test-not + (if (not (funcall test-not ,item (sys::apply-key key ,seq-ref))) + (return ,return)) + (if (funcall test ,item (sys::apply-key key ,seq-ref)) + (return ,return))))) + +(defmacro vector-locater (item sequence return-type) + `(vector-locater-macro ,sequence + (locater-test-not ,item ,sequence :vector ,return-type) + ,return-type)) + +(defmacro locater-if-test (test sequence seq-type return-type sense) + (let ((seq-ref (case return-type + (:position + (case seq-type + (:vector `(aref ,sequence index)) + (:list `(pop ,sequence)))) + (:element 'current))) + (return (case return-type + (:position 'index) + (:element 'current)))) + (if sense + `(if (funcall ,test (sys::apply-key key ,seq-ref)) + (return ,return)) + `(if (not (funcall ,test (sys::apply-key key ,seq-ref))) + (return ,return))))) + +(defmacro vector-locater-if-macro (test sequence return-type sense) + `(vector-locater-macro ,sequence + (locater-if-test ,test ,sequence :vector ,return-type ,sense) + ,return-type)) + +(defmacro vector-locater-if (test sequence return-type) + `(vector-locater-if-macro ,test ,sequence ,return-type t)) + +(defmacro vector-locater-if-not (test sequence return-type) + `(vector-locater-if-macro ,test ,sequence ,return-type nil)) + +(defmacro list-locater-macro (sequence body-form return-type) + `(if from-end + (do ((sequence (nthcdr (- (the fixnum (length sequence)) + (the fixnum end)) + (reverse (the list ,sequence)))) + (index (1- (the fixnum end)) (1- index)) + (terminus (1- (the fixnum start))) + ,@(case return-type (:position nil) (:element '(current)))) + ((or (= index terminus) (null sequence)) ()) + (declare (fixnum index terminus)) + ,@(case return-type + (:position nil) + (:element `((setf current (pop ,sequence))))) + ,body-form) + (do ((sequence (nthcdr start ,sequence)) + (index start (1+ index)) + ,@(case return-type (:position nil) (:element '(current)))) + ((or (= index (the fixnum end)) (null sequence)) ()) + (declare (fixnum index)) + ,@(case return-type + (:position nil) + (:element `((setf current (pop ,sequence))))) + ,body-form))) + +(defmacro list-locater (item sequence return-type) + `(list-locater-macro ,sequence + (locater-test-not ,item ,sequence :list ,return-type) + ,return-type)) + +(defmacro list-locater-if-macro (test sequence return-type sense) + `(list-locater-macro ,sequence + (locater-if-test ,test ,sequence :list ,return-type ,sense) + ,return-type)) + +(defmacro list-locater-if (test sequence return-type) + `(list-locater-if-macro ,test ,sequence ,return-type t)) + +(defmacro list-locater-if-not (test sequence return-type) + `(list-locater-if-macro ,test ,sequence ,return-type nil)) + +(defmacro vector-position (item sequence) + `(vector-locater ,item ,sequence :position)) + +(defmacro list-position (item sequence) + `(list-locater ,item ,sequence :position)) + + +(defun position (item sequence &key from-end (test #'eql) test-not (start 0) + end key) + (if (listp sequence) + (list-position* item sequence from-end test test-not start end key) + (vector-position* item sequence from-end test test-not start end key))) + + +(defun list-position* (item sequence from-end test test-not start end key) + (declare (type fixnum start)) + (let ((end (or end (length sequence)))) + (declare (type fixnum end)) + (list-position item sequence))) + +(defun vector-position* (item sequence from-end test test-not start end key) + (declare (type fixnum start)) + (let ((end (or end (length sequence)))) + (declare (type fixnum end)) + (vector-position item sequence))) + +(defmacro vector-position-if (test sequence) + `(vector-locater-if ,test ,sequence :position)) + +(defmacro list-position-if (test sequence) + `(list-locater-if ,test ,sequence :position)) + +(defun position-if (test sequence &key from-end (start 0) key end) + (declare (type fixnum start)) + (let ((end (or end (length sequence)))) + (declare (type fixnum end)) + (if (listp sequence) + (list-position-if test sequence) + (vector-position-if test sequence)))) + +(defmacro vector-position-if-not (test sequence) + `(vector-locater-if-not ,test ,sequence :position)) + +(defmacro list-position-if-not (test sequence) + `(list-locater-if-not ,test ,sequence :position)) + +(defun position-if-not (test sequence &key from-end (start 0) key end) + (declare (type fixnum start)) + (let ((end (or end (length sequence)))) + (declare (type fixnum end)) + (if (listp sequence) + (list-position-if-not test sequence) + (vector-position-if-not test sequence)))) + +(defmacro vector-find (item sequence) + `(vector-locater ,item ,sequence :element)) + +(defmacro list-find (item sequence) + `(list-locater ,item ,sequence :element)) + +(defun list-find* (item sequence from-end test test-not start end key) + (declare (type fixnum start end)) + (unless (or test test-not) + (setf test 'eql)) + (list-find item sequence)) + +(defun vector-find* (item sequence from-end test test-not start end key) + (declare (type fixnum start end)) + (unless (or test test-not) + (setf test 'eql)) + (vector-find item sequence)) + +(defun find (item sequence &key from-end (test #'eql) test-not (start 0) + end key) + (let ((end (check-sequence-bounds sequence start end))) + (if (listp sequence) + (list-find* item sequence from-end test test-not start end key) + (vector-find* item sequence from-end test test-not start end key)))) + +(defmacro vector-find-if (test sequence) + `(vector-locater-if ,test ,sequence :element)) + +(defmacro list-find-if (test sequence) + `(list-locater-if ,test ,sequence :element)) + +(defun find-if (test sequence &key from-end (start 0) end key) + (let ((end (or end (length sequence)))) + (declare (type fixnum end)) + (if (listp sequence) + (list-find-if test sequence) + (vector-find-if test sequence)))) + +(defmacro vector-find-if-not (test sequence) + `(vector-locater-if-not ,test ,sequence :element)) + +(defmacro list-find-if-not (test sequence) + `(list-locater-if-not ,test ,sequence :element)) + +(defun find-if-not (test sequence &key from-end (start 0) end key) + (let ((end (or end (length sequence)))) + (declare (type fixnum end)) + (if (listp sequence) + (list-find-if-not test sequence) + (vector-find-if-not test sequence)))) Added: branches/save-image/src/org/armedbear/lisp/float_sign.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/float_sign.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,78 @@ +/* + * float_sign.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: float_sign.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### float-sign +public final class float_sign extends Primitive +{ + private float_sign() + { + super("float-sign", "float-1 &optional float-2"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof SingleFloat) { + float f = ((SingleFloat)arg).value; + int bits = Float.floatToRawIntBits(f); + return bits < 0 ? SingleFloat.MINUS_ONE : SingleFloat.ONE; + } + if (arg instanceof DoubleFloat) { + double d = ((DoubleFloat)arg).value; + long bits = Double.doubleToRawLongBits(d); + return bits < 0 ? DoubleFloat.MINUS_ONE : DoubleFloat.ONE; + } + return type_error(arg, Symbol.FLOAT); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (!first.floatp()) + return type_error(first, Symbol.FLOAT); + if (!second.floatp()) + return type_error(second, Symbol.FLOAT); + if (first.minusp()) { + if (second.minusp()) + return second; + else + return Fixnum.ZERO.subtract(second); + } else + return second.ABS(); + } + + private static final Primitive FLOAT_SIGN = new float_sign(); +} Added: branches/save-image/src/org/armedbear/lisp/floor.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/floor.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,89 @@ +/* + * floor.java + * + * Copyright (C) 2004 Peter Graves + * $Id: floor.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### floor number &optional divisor +public final class floor extends Primitive +{ + private floor() + { + super("floor", "number &optional divisor"); + } + + @Override + public LispObject execute(LispObject number) + throws ConditionThrowable + { + LispObject quotient = number.truncate(Fixnum.ONE); + final LispThread thread = LispThread.currentThread(); + LispObject remainder = thread._values[1]; + if (!remainder.zerop()) { + if (number.minusp()) { + quotient = quotient.decr(); + remainder = remainder.incr(); + thread._values[0] = quotient; + thread._values[1] = remainder; + } + } + return quotient; + } + + @Override + public LispObject execute(LispObject number, LispObject divisor) + throws ConditionThrowable + { + LispObject quotient = number.truncate(divisor); + final LispThread thread = LispThread.currentThread(); + LispObject remainder = thread._values[1]; + boolean adjust = false; + if (!remainder.zerop()) { + if (divisor.minusp()) { + if (number.plusp()) + adjust = true; + } else { + if (number.minusp()) + adjust = true; + } + } + if (adjust) { + quotient = quotient.decr(); + remainder = remainder.add(divisor); + thread._values[0] = quotient; + thread._values[1] = remainder; + } + return quotient; + } + + private static final Primitive FLOOR = new floor(); +} Added: branches/save-image/src/org/armedbear/lisp/format.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/format.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,2872 @@ +;;; format.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $Id: format.lisp 11626 2009-02-05 19:40:13Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL/SBCL. + +(in-package "SYSTEM") + +;;; From primordial-extensions.lisp. + +;;; Concatenate together the names of some strings and symbols, +;;; producing a symbol in the current package. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun symbolicate (&rest things) + (let ((name (apply #'concatenate 'string (mapcar #'string things)))) + (values (intern name))))) + +;;; a helper function for various macros which expect clauses of a +;;; given length, etc. +;;; +;;; Return true if X is a proper list whose length is between MIN and +;;; MAX (inclusive). +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun proper-list-of-length-p (x min &optional (max min)) + ;; FIXME: This implementation will hang on circular list + ;; structure. Since this is an error-checking utility, i.e. its + ;; job is to deal with screwed-up input, it'd be good style to fix + ;; it so that it can deal with circular list structure. + (cond ((minusp max) nil) + ((null x) (zerop min)) + ((consp x) + (and (plusp max) + (proper-list-of-length-p (cdr x) + (if (plusp (1- min)) + (1- min) + 0) + (1- max)))) + (t nil)))) + +;;; From early-extensions.lisp. + +(defconstant form-feed-char-code 12) + +(defmacro named-let (name binds &body body) + (dolist (x binds) + (unless (proper-list-of-length-p x 2) + (error "malformed NAMED-LET variable spec: ~S" x))) + `(labels ((,name ,(mapcar #'first binds) , at body)) + (,name ,@(mapcar #'second binds)))) + +;;;; ONCE-ONLY +;;;; +;;;; "The macro ONCE-ONLY has been around for a long time on various +;;;; systems [..] if you can understand how to write and when to use +;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig, +;;;; _Paradigms of Artificial Intelligence Programming: Case Studies +;;;; in Common Lisp_, p. 853 + +;;; ONCE-ONLY is a utility useful in writing source transforms and +;;; macros. It provides a concise way to wrap a LET around some code +;;; to ensure that some forms are only evaluated once. +;;; +;;; Create a LET* which evaluates each value expression, binding a +;;; temporary variable to the result, and wrapping the LET* around the +;;; result of the evaluation of BODY. Within the body, each VAR is +;;; bound to the corresponding temporary variable. +(defmacro once-only (specs &body body) + (named-let frob ((specs specs) + (body body)) + (if (null specs) + `(progn , at body) + (let ((spec (first specs))) + ;; FIXME: should just be DESTRUCTURING-BIND of SPEC + (unless (proper-list-of-length-p spec 2) + (error "malformed ONCE-ONLY binding spec: ~S" spec)) + (let* ((name (first spec)) + (exp-temp (gensym (symbol-name name)))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "ONCE-ONLY-"))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) + +;;; From print.lisp. + +;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does +;;; most of the work for all printing of floating point numbers in the +;;; printer and in FORMAT. It converts a floating point number to a +;;; string in a free or fixed format with no exponent. The +;;; interpretation of the arguments is as follows: +;;; +;;; X - The floating point number to convert, which must not be +;;; negative. +;;; WIDTH - The preferred field width, used to determine the number +;;; of fraction digits to produce if the FDIGITS parameter +;;; is unspecified or NIL. If the non-fraction digits and the +;;; decimal point alone exceed this width, no fraction digits +;;; will be produced unless a non-NIL value of FDIGITS has been +;;; specified. Field overflow is not considerd an error at this +;;; level. +;;; FDIGITS - The number of fractional digits to produce. Insignificant +;;; trailing zeroes may be introduced as needed. May be +;;; unspecified or NIL, in which case as many digits as possible +;;; are generated, subject to the constraint that there are no +;;; trailing zeroes. +;;; SCALE - If this parameter is specified or non-NIL, then the number +;;; printed is (* x (expt 10 scale)). This scaling is exact, +;;; and cannot lose precision. +;;; FMIN - This parameter, if specified or non-NIL, is the minimum +;;; number of fraction digits which will be produced, regardless +;;; of the value of WIDTH or FDIGITS. This feature is used by +;;; the ~E format directive to prevent complete loss of +;;; significance in the printed value due to a bogus choice of +;;; scale factor. +;;; +;;; Most of the optional arguments are for the benefit for FORMAT and are not +;;; used by the printer. +;;; +;;; Returns: +;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) +;;; where the results have the following interpretation: +;;; +;;; DIGIT-STRING - The decimal representation of X, with decimal point. +;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. +;;; LEADING-POINT - True if the first character of DIGIT-STRING is the +;;; decimal point. +;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the +;;; decimal point. +;;; POINT-POS - The position of the digit preceding the decimal +;;; point. Zero indicates point before first digit. +;;; +;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee +;;; accuracy. Specifically, the decimal number printed is the closest +;;; possible approximation to the true value of the binary number to +;;; be printed from among all decimal representations with the same +;;; number of digits. In free-format output, i.e. with the number of +;;; digits unconstrained, it is guaranteed that all the information is +;;; preserved, so that a properly- rounding reader can reconstruct the +;;; original binary number, bit-for-bit, from its printed decimal +;;; representation. Furthermore, only as many digits as necessary to +;;; satisfy this condition will be printed. +;;; +;;; FLOAT-STRING actually generates the digits for positive numbers. +;;; The algorithm is essentially that of algorithm Dragon4 in "How to +;;; Print Floating-Point Numbers Accurately" by Steele and White. The +;;; current (draft) version of this paper may be found in +;;; [CMUC]tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO +;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER! + +(defun flonum-to-string (x &optional width fdigits scale fmin) + (declare (ignore fmin)) ; FIXME + (cond ((zerop x) + ;; Zero is a special case which FLOAT-STRING cannot handle. + (if fdigits + (let ((s (make-string (1+ fdigits) :initial-element #\0))) + (setf (schar s 0) #\.) + (values s (length s) t (zerop fdigits) 0)) + (values "." 1 t t 0))) + (t + (when scale + (setf x (* x (expt 10 scale)))) + (let* ((s (float-string x)) + (length (length s)) + (index (position #\. s))) + (when (and (< x 1) + (> length 0) + (eql (schar s 0) #\0)) + (setf s (subseq s 1) + length (length s) + index (position #\. s))) + (when fdigits + ;; "Leading zeros are not permitted, except that a single zero + ;; digit is output before the decimal point if the printed value + ;; is less than one, and this single zero digit is not output at + ;; all if w=d+1." + (let ((actual-fdigits (- length index 1))) + (cond ((< actual-fdigits fdigits) + ;; Add the required number of trailing zeroes. + (setf s (concatenate 'string s + (make-string (- fdigits actual-fdigits) + :initial-element #\0)) + length (length s))) + ((> actual-fdigits fdigits) + (let* ((desired-length (+ index 1 fdigits)) + (c (schar s desired-length))) + (setf s (subseq s 0 (+ index 1 fdigits)) + length (length s) + index (position #\. s)) + (when (char>= c #\5) + (setf s (round-up s) + length (length s) + index (position #\. s)))))))) + (when (and width (> length width)) + ;; The string is too long. Shorten it by removing insignificant + ;; trailing zeroes if possible. + (let ((minimum-width (+ (1+ index) (or fdigits 0)))) + (when (< minimum-width width) + (setf minimum-width width)) + (when (> length minimum-width) + ;; But we don't want to shorten e.g. "1.7d100"... + (when (every #'digit-char-p (subseq s (1+ index))) + (let ((c (schar s minimum-width))) + (setf s (subseq s 0 minimum-width) + length minimum-width) + (when (char>= c #\5) + (setf s (round-up s) + length (length s) + index (position #\. s)))))))) + (values s length (eql index 0) (eql index (1- length)) index))))) + +(defun round-up (string) + (let* ((index (position #\. string)) + (n (read-from-string (setf string (remove #\. string)))) + (s (princ-to-string (incf n)))) + (loop for char across string + while (equal char #\0) + do (setf s (concatenate 'string "0" s))) + (cond ((null index) + s) + (t + (when (> (length s) (length string)) + ;; Rounding up made the string longer, which means we went from (say) 99 + ;; to 100. Drop the trailing #\0 and move the #\. one character to the + ;; right. + (setf s (subseq s 0 (1- (length s)))) + (incf index)) + (concatenate 'string (subseq s 0 index) "." (subseq s index)))))) + + +(defun scale-exponent (original-x) + (let* ((x (coerce original-x 'long-float))) + (multiple-value-bind (sig exponent) (decode-float x) + (declare (ignore sig)) + (if (= x 0.0l0) + (values (float 0.0l0 original-x) 1) + (let* ((ex (locally (declare (optimize (safety 0))) + (the fixnum + (round (* exponent (log 2l0 10)))))) + (x (if (minusp ex) + (if (float-denormalized-p x) + (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) + (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) + (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) + (do ((d 10.0l0 (* d 10.0l0)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y 1.0l0) + (do ((m 10.0l0 (* m 10.0l0)) + (z y (* y m)) + (ex ex (1- ex))) + ((>= z 0.1l0) + (values (float z original-x) ex)) + (declare (long-float m) (integer ex)))) + (declare (long-float d)))))))) + +(defconstant double-float-exponent-byte + (byte 11 20)) + +(defun float-denormalized-p (x) + "Return true if the double-float X is denormalized." + (and (zerop (ldb double-float-exponent-byte (double-float-high-bits x))) + (not (zerop x)))) + +;;; From early-format.lisp. + +(in-package #:format) + +(defparameter *format-whitespace-chars* + (vector #\space + #\newline + #\tab)) + +(defvar *format-directive-expanders* + (make-array char-code-limit :initial-element nil)) +(defvar *format-directive-interpreters* + (make-array char-code-limit :initial-element nil)) + +(defvar *default-format-error-control-string* nil) +(defvar *default-format-error-offset* nil) + +;;;; specials used to communicate information + +;;; Used both by the expansion stuff and the interpreter stuff. When it is +;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. +(defvar *up-up-and-out-allowed* nil) + +;;; Used by the interpreter stuff. When it's non-NIL, it's a function +;;; that will invoke PPRINT-POP in the right lexical environemnt. +(declaim (type (or null function) *logical-block-popper*)) +(defvar *logical-block-popper* nil) + +;;; Used by the expander stuff. This is bindable so that ~<...~:> +;;; can change it. +(defvar *expander-next-arg-macro* 'expander-next-arg) + +;;; Used by the expander stuff. Initially starts as T, and gets set to NIL +;;; if someone needs to do something strange with the arg list (like use +;;; the rest, or something). +(defvar *only-simple-args*) + +;;; Used by the expander stuff. We do an initial pass with this as NIL. +;;; If someone doesn't like this, they (THROW 'NEED-ORIG-ARGS NIL) and we try +;;; again with it bound to T. If this is T, we don't try to do anything +;;; fancy with args. +(defvar *orig-args-available* nil) + +;;; Used by the expander stuff. List of (symbol . offset) for simple args. +(defvar *simple-args*) + +;;; From late-format.lisp. + +(in-package #:format) + +(define-condition format-error (error) + ((complaint :reader format-error-complaint :initarg :complaint) + (args :reader format-error-args :initarg :args :initform nil) + (control-string :reader format-error-control-string + :initarg :control-string + :initform *default-format-error-control-string*) + (offset :reader format-error-offset :initarg :offset + :initform *default-format-error-offset*) + (print-banner :reader format-error-print-banner :initarg :print-banner + :initform t)) + (:report %print-format-error)) + +(defun %print-format-error (condition stream) + (format stream + "~:[~;error in format: ~]~ + ~?~@[~% ~A~% ~V at T^~]" + (format-error-print-banner condition) + (format-error-complaint condition) + (format-error-args condition) + (format-error-control-string condition) + (format-error-offset condition))) + +(defstruct format-directive + (string (missing-arg) :type simple-string) + (start (missing-arg) :type (and unsigned-byte fixnum)) + (end (missing-arg) :type (and unsigned-byte fixnum)) + (character (missing-arg) :type base-char) + (colonp nil :type (member t nil)) + (atsignp nil :type (member t nil)) + (params nil :type list)) +(defmethod print-object ((x format-directive) stream) + (print-unreadable-object (x stream) + (write-string (format-directive-string x) + stream + :start (format-directive-start x) + :end (format-directive-end x)))) + +;;;; TOKENIZE-CONTROL-STRING + +(defun tokenize-control-string (string) + (declare (simple-string string)) + (let ((index 0) + (end (length string)) + (result nil) + (in-block nil) + (pprint nil) + (semi nil) + (justification-semi 0)) + (declare (type index fixnum)) + (loop + (let ((next-directive (or (position #\~ string :start index) end))) + (declare (type index next-directive)) + (when (> next-directive index) + (push (subseq string index next-directive) result)) + (when (= next-directive end) + (return)) + (let* ((directive (parse-directive string next-directive)) + (directive-char (format-directive-character directive))) + (declare (type character directive-char)) + ;; We are looking for illegal combinations of format + ;; directives in the control string. See the last paragraph + ;; of CLHS 22.3.5.2: "an error is also signaled if the + ;; ~<...~:;...~> form of ~<...~> is used in the same format + ;; string with ~W, ~_, ~<...~:>, ~I, or ~:T." + (cond ((char= #\< directive-char) + ;; Found a justification or logical block + (setf in-block t)) + ((and in-block (char= #\; directive-char)) + ;; Found a semi colon in a justification or logical block + (setf semi t)) + ((char= #\> directive-char) + ;; End of justification or logical block. Figure out which. + (setf in-block nil) + (cond ((format-directive-colonp directive) + ;; A logical-block directive. Note that fact, and also + ;; note that we don't care if we found any ~; + ;; directives in the block. + (setf pprint t) + (setf semi nil)) + (semi + ;; A justification block with a ~; directive in it. + (incf justification-semi)))) + ((and (not in-block) + (or (and (char= #\T directive-char) (format-directive-colonp directive)) + (char= #\W directive-char) + (char= #\_ directive-char) + (char= #\I directive-char))) + (setf pprint t))) + (push directive result) + (setf index (format-directive-end directive))))) + (when (and pprint (plusp justification-semi)) + (error 'format-error + :complaint "A justification directive cannot be in the same format string~%~ + as ~~W, ~~I, ~~:T, or a logical-block directive." + :control-string string + :offset 0)) + (nreverse result))) + +(defun parse-directive (string start) + (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) + (end (length string))) + (flet ((get-char () + (if (= posn end) + (error 'format-error + :complaint "String ended before directive was found." + :control-string string + :offset start) + (schar string posn))) + (check-ordering () + (when (or colonp atsignp) + (error 'format-error + :complaint "parameters found after #\\: or #\\@ modifier" + :control-string string + :offset posn)))) + (loop + (let ((char (get-char))) + (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (check-ordering) + (multiple-value-bind (param new-posn) + (parse-integer string :start posn :junk-allowed t) + (push (cons posn param) params) + (setf posn new-posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return))))) + ((or (char= char #\v) + (char= char #\V)) + (check-ordering) + (push (cons posn :arg) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\#) + (check-ordering) + (push (cons posn :remaining) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\') + (check-ordering) + (incf posn) + (push (cons posn (get-char)) params) + (incf posn) + (unless (char= (get-char) #\,) + (decf posn))) + ((char= char #\,) + (check-ordering) + (push (cons posn nil) params)) + ((char= char #\:) + (if colonp + (error 'format-error + :complaint "too many colons supplied" + :control-string string + :offset posn) + (setf colonp t))) + ((char= char #\@) + (if atsignp + (error 'format-error + :complaint "too many #\\@ characters supplied" + :control-string string + :offset posn) + (setf atsignp t))) + (t + (when (and (char= (schar string (1- posn)) #\,) + (or (< posn 2) + (char/= (schar string (- posn 2)) #\'))) + (check-ordering) + (push (cons (1- posn) nil) params)) + (return)))) + (incf posn)) + (let ((char (get-char))) + (when (char= char #\/) + (let ((closing-slash (position #\/ string :start (1+ posn)))) + (if closing-slash + (setf posn closing-slash) + (error 'format-error + :complaint "no matching closing slash" + :control-string string + :offset posn)))) + (make-format-directive + :string string :start start :end (1+ posn) + :character (char-upcase char) + :colonp colonp :atsignp atsignp + :params (nreverse params)))))) + +;;;; FORMATTER stuff + +(defmacro formatter (control-string) + `#',(%formatter control-string)) + +(defun %formatter (control-string) + (block nil + (catch 'need-orig-args + (let* ((*simple-args* nil) + (*only-simple-args* t) + (guts (expand-control-string control-string)) + (args nil)) + (dolist (arg *simple-args*) + (push `(,(car arg) + (error + 'format-error + :complaint "required argument missing" + :control-string ,control-string + :offset ,(cdr arg))) + args)) + (return `(lambda (stream &optional , at args &rest args) + ,guts + args)))) + (let ((*orig-args-available* t) + (*only-simple-args* nil)) + `(lambda (stream &rest orig-args) + (let ((args orig-args)) + ,(expand-control-string control-string) + args))))) + +(defun expand-control-string (string) + (let* ((string (etypecase string + (simple-string + string) + (string + (coerce string 'simple-string)))) + (*default-format-error-control-string* string) + (directives (tokenize-control-string string))) + `(block nil + ,@(expand-directive-list directives)))) + +(defun expand-directive-list (directives) + (let ((results nil) + (remaining-directives directives)) + (loop + (unless remaining-directives + (return)) + (multiple-value-bind (form new-directives) + (expand-directive (car remaining-directives) + (cdr remaining-directives)) + (push form results) + (setf remaining-directives new-directives))) + (reverse results))) + +(defun expand-directive (directive more-directives) + (etypecase directive + (format-directive + (let ((expander + (aref *format-directive-expanders* + (char-code (format-directive-character directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) + (declare (type (or null function) expander)) + (if expander + (funcall expander directive more-directives) + (error 'format-error + :complaint "unknown directive ~@[(character: ~A)~]" + :args (list (char-name (format-directive-character directive))))))) + (simple-string + (values `(write-string ,directive stream) + more-directives)))) + +(defmacro expander-next-arg (string offset) + `(if args + (pop args) + (error 'format-error + :complaint "no more arguments" + :control-string ,string + :offset ,offset))) + +(defun expand-next-arg (&optional offset) + (if (or *orig-args-available* (not *only-simple-args*)) + `(,*expander-next-arg-macro* + ,*default-format-error-control-string* + ,(or offset *default-format-error-offset*)) + (let ((symbol (gensym "FORMAT-ARG-"))) + (push (cons symbol (or offset *default-format-error-offset*)) + *simple-args*) + symbol))) + +(defmacro expand-bind-defaults (specs params &body body) + (sys::once-only ((params params)) + (if specs + (collect ((expander-bindings) (runtime-bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (let ((symbol (gensym))) + (expander-bindings + `(,var ',symbol)) + (runtime-bindings + `(list ',symbol + (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg `(or ,(expand-next-arg offset) + ,,default)) + (:remaining + (setf *only-simple-args* nil) + '(length args)) + ((nil) ,default) + (t param)))))))) + `(let ,(expander-bindings) + `(let ,(list ,@(runtime-bindings)) + ,@(if ,params + (error + 'format-error + :complaint + "too many parameters, expected no more than ~W" + :args (list ,(length specs)) + :offset (caar ,params))) + ,, at body))) + `(progn + (when ,params + (error 'format-error + :complaint "too many parameters, expected none" + :offset (caar ,params))) + , at body)))) + +;;;; format directive machinery + +;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN +(defmacro def-complex-format-directive (char lambda-list &body body) + (let ((defun-name + (intern (concatenate 'string + (let ((name (char-name char))) + (cond (name + (string-capitalize name)) + (t + (string char)))) + "-FORMAT-DIRECTIVE-EXPANDER"))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) + `(progn + (defun ,defun-name (,directive ,directives) + ,@(if lambda-list + `((let ,(mapcar (lambda (var) + `(,var + (,(sys::symbolicate "FORMAT-DIRECTIVE-" var) + ,directive))) + (butlast lambda-list)) + , at body)) + `((declare (ignore ,directive ,directives)) + , at body))) + (%set-format-directive-expander ,char #',defun-name)))) + +;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN +(defmacro def-format-directive (char lambda-list &body body) + (let ((directives (gensym)) + (declarations nil) + (body-without-decls body)) + (loop + (let ((form (car body-without-decls))) + (unless (and (consp form) (eq (car form) 'declare)) + (return)) + (push (pop body-without-decls) declarations))) + (setf declarations (reverse declarations)) + `(def-complex-format-directive ,char (, at lambda-list ,directives) + , at declarations + (values (progn , at body-without-decls) + ,directives)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defun %set-format-directive-expander (char fn) + (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) + char) + + (defun %set-format-directive-interpreter (char fn) + (setf (aref *format-directive-interpreters* + (char-code (char-upcase char))) + fn) + char) + + (defun find-directive (directives kind stop-at-semi) + (if directives + (let ((next (car directives))) + (if (format-directive-p next) + (let ((char (format-directive-character next))) + (if (or (char= kind char) + (and stop-at-semi (char= char #\;))) + (car directives) + (find-directive + (cdr (flet ((after (char) + (member (find-directive (cdr directives) + char + nil) + directives))) + (case char + (#\( (after #\))) + (#\< (after #\>)) + (#\[ (after #\])) + (#\{ (after #\})) + (t directives)))) + kind stop-at-semi))) + (find-directive (cdr directives) kind stop-at-semi))))) + + ) ; EVAL-WHEN + +;;;; format directives for simple output + +(def-format-directive #\A (colonp atsignp params) + (if params + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp + ,mincol ,colinc ,minpad ,padchar)) + `(princ ,(if colonp + `(or ,(expand-next-arg) "()") + (expand-next-arg)) + stream))) + +(def-format-directive #\S (colonp atsignp params) + (cond (params + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))) + (colonp + `(let ((arg ,(expand-next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + `(prin1 ,(expand-next-arg) stream)))) + +(def-format-directive #\C (colonp atsignp params) + (expand-bind-defaults () params + (if colonp + `(format-print-named-character ,(expand-next-arg) stream) + (if atsignp + `(prin1 ,(expand-next-arg) stream) + `(write-char ,(expand-next-arg) stream))))) + +(def-format-directive #\W (colonp atsignp params) + (expand-bind-defaults () params + (if (or colonp atsignp) + `(let (,@(when colonp + '((*print-pretty* t))) + ,@(when atsignp + '((*print-level* nil) + (*print-length* nil)))) + (sys::output-object ,(expand-next-arg) stream)) + `(sys::output-object ,(expand-next-arg) stream)))) + +;;;; format directives for integer output + +(defun expand-format-integer (base colonp atsignp params) + (if (or colonp atsignp params) + (expand-bind-defaults + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp + ,base ,mincol ,padchar ,commachar + ,commainterval)) + `(write ,(expand-next-arg) :stream stream :base ,base :radix nil + :escape nil))) + +(def-format-directive #\D (colonp atsignp params) + (expand-format-integer 10 colonp atsignp params)) + +(def-format-directive #\B (colonp atsignp params) + (expand-format-integer 2 colonp atsignp params)) + +(def-format-directive #\O (colonp atsignp params) + (expand-format-integer 8 colonp atsignp params)) + +(def-format-directive #\X (colonp atsignp params) + (expand-format-integer 16 colonp atsignp params)) + +(def-format-directive #\R (colonp atsignp params) + (expand-bind-defaults + ((base nil) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (let ((n-arg (gensym))) + `(let ((,n-arg ,(expand-next-arg))) + (if ,base + (format-print-integer stream ,n-arg ,colonp ,atsignp + ,base ,mincol + ,padchar ,commachar ,commainterval) + ,(if atsignp + (if colonp + `(format-print-old-roman stream ,n-arg) + `(format-print-roman stream ,n-arg)) + (if colonp + `(format-print-ordinal stream ,n-arg) + `(format-print-cardinal stream ,n-arg)))))))) + +;;;; format directive for pluralization + +(def-format-directive #\P (colonp atsignp params end) + (expand-bind-defaults () params + (let ((arg (cond + ((not colonp) + (expand-next-arg)) + (*orig-args-available* + `(if (eq orig-args args) + (error 'format-error + :complaint "no previous argument" + :offset ,(1- end)) + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr))))) + (*only-simple-args* + (unless *simple-args* + (error 'format-error + :complaint "no previous argument")) + (caar *simple-args*)) + (t + (throw 'need-orig-args nil))))) + (if atsignp + `(write-string (if (eql ,arg 1) "y" "ies") stream) + `(unless (eql ,arg 1) (write-char #\s stream)))))) + +;;;; format directives for floating point output + +(def-format-directive #\F (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "The colon modifier cannot be used with this directive.")) + (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params + `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) + +(def-format-directive #\E (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "The colon modifier cannot be used with this directive.")) + (expand-bind-defaults + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) + params + `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark + ,atsignp))) + +(def-format-directive #\G (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "The colon modifier cannot be used with this directive.")) + (expand-bind-defaults + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) + params + `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) + +(def-format-directive #\$ (colonp atsignp params) + (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params + `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp + ,atsignp))) + +;;;; format directives for line/page breaks etc. + +(def-format-directive #\% (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (terpri stream))) + '(terpri stream))) + +(def-format-directive #\& (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) + (if params + (expand-bind-defaults ((count 1)) params + `(progn + (fresh-line stream) + (dotimes (i (1- ,count)) + (terpri stream)))) + '(fresh-line stream))) + +(def-format-directive #\| (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char (code-char sys::form-feed-char-code) stream))) + '(write-char (code-char sys::form-feed-char-code) stream))) + +(def-format-directive #\~ (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char #\~ stream))) + '(write-char #\~ stream))) + +(def-complex-format-directive #\newline (colonp atsignp params directives) + (when (and colonp atsignp) + (error 'format-error + :complaint "both colon and atsign modifiers used simultaneously")) + (values (expand-bind-defaults () params + (if atsignp + '(write-char #\newline stream) + nil)) + (if (and (not colonp) + directives + (simple-string-p (car directives))) + (cons (string-left-trim *format-whitespace-chars* + (car directives)) + (cdr directives)) + directives))) + +;;;; format directives for tabs and simple pretty printing + +(def-format-directive #\T (colonp atsignp params) + (if colonp + (expand-bind-defaults ((n 1) (m 1)) params + `(pprint-tab ,(if atsignp :section-relative :section) + ,n ,m stream)) + (if atsignp + (expand-bind-defaults ((colrel 1) (colinc 1)) params + `(format-relative-tab stream ,colrel ,colinc)) + (expand-bind-defaults ((colnum 1) (colinc 1)) params + `(format-absolute-tab stream ,colnum ,colinc))))) + +(def-format-directive #\_ (colonp atsignp params) + (expand-bind-defaults () params + `(pprint-newline ,(if colonp + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) + +(def-format-directive #\I (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint + "cannot use the at-sign modifier with this directive")) + (expand-bind-defaults ((n 0)) params + `(pprint-indent ,(if colonp :current :block) ,n stream))) + +;;;; format directive for ~* + +(def-format-directive #\* (colonp atsignp params end) + (if atsignp + (if colonp + (error 'format-error + :complaint + "both colon and atsign modifiers used simultaneously") + (expand-bind-defaults ((posn 0)) params + (unless *orig-args-available* + (throw 'need-orig-args nil)) + `(if (<= 0 ,posn (length orig-args)) + (setf args (nthcdr ,posn orig-args)) + (error 'format-error + :complaint "Index ~W out of bounds. Should have been ~ + between 0 and ~W." + :args (list ,posn (length orig-args)) + :offset ,(1- end))))) + (if colonp + (expand-bind-defaults ((n 1)) params + (unless *orig-args-available* + (throw 'need-orig-args nil)) + `(do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn ,n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + (error 'format-error + :complaint + "Index ~W is out of bounds; should have been ~ + between 0 and ~W." + :args (list new-posn (length orig-args)) + :offset ,(1- end))))))) + (if params + (expand-bind-defaults ((n 1)) params + (setf *only-simple-args* nil) + `(dotimes (i ,n) + ,(expand-next-arg))) + (expand-next-arg))))) + +;;;; format directive for indirection + +(def-format-directive #\? (colonp atsignp params string end) + (when colonp + (error 'format-error + :complaint "cannot use the colon modifier with this directive")) + (expand-bind-defaults () params + `(handler-bind + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) + ,(if atsignp + (if *orig-args-available* + `(setf args (%format stream ,(expand-next-arg) orig-args args)) + (throw 'need-orig-args nil)) + `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) + +;;;; format directives for capitalization + +(def-complex-format-directive #\( (colonp atsignp params directives) + (let ((close (find-directive directives #\) nil))) + (unless close + (error 'format-error + :complaint "no corresponding close parenthesis")) + (let* ((posn (position close directives)) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives))) + (values + (expand-bind-defaults () params + `(let ((stream (sys::make-case-frob-stream stream + ,(if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + ,@(expand-directive-list before))) + after)))) + +(def-complex-format-directive #\) () + (error 'format-error + :complaint "no corresponding open parenthesis")) + +;;;; format directives and support functions for conditionalization + +(def-complex-format-directive #\[ (colonp atsignp params directives) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (values + (if atsignp + (if colonp + (error 'format-error + :complaint + "both colon and atsign modifiers used simultaneously") + (if (cdr sublists) + (error 'format-error + :complaint + "Can only specify one section") + (expand-bind-defaults () params + (expand-maybe-conditional (car sublists))))) + (if colonp + (if (= (length sublists) 2) + (expand-bind-defaults () params + (expand-true-false-conditional (car sublists) + (cadr sublists))) + (error 'format-error + :complaint + "must specify exactly two sections")) + (expand-bind-defaults ((index nil)) params + (setf *only-simple-args* nil) + (let ((clauses nil) + (case `(or ,index ,(expand-next-arg)))) + (when last-semi-with-colon-p + (push `(t ,@(expand-directive-list (pop sublists))) + clauses)) + (let ((count (length sublists))) + (dolist (sublist sublists) + (push `(,(decf count) + ,@(expand-directive-list sublist)) + clauses))) + `(case ,case , at clauses))))) + remaining))) + +(defun parse-conditional-directive (directives) + (let ((sublists nil) + (last-semi-with-colon-p nil) + (remaining directives)) + (loop + (let ((close-or-semi (find-directive remaining #\] t))) + (unless close-or-semi + (error 'format-error + :complaint "no corresponding close bracket")) + (let ((posn (position close-or-semi remaining))) + (push (subseq remaining 0 posn) sublists) + (setf remaining (nthcdr (1+ posn) remaining)) + (when (char= (format-directive-character close-or-semi) #\]) + (return)) + (setf last-semi-with-colon-p + (format-directive-colonp close-or-semi))))) + (values sublists last-semi-with-colon-p remaining))) + +(defun expand-maybe-conditional (sublist) + (flet ((hairy () + `(let ((prev-args args) + (arg ,(expand-next-arg))) + (when arg + (setf args prev-args) + ,@(expand-directive-list sublist))))) + (if *only-simple-args* + (multiple-value-bind (guts new-args) + (let ((*simple-args* *simple-args*)) + (values (expand-directive-list sublist) + *simple-args*)) + (cond ((and new-args (eq *simple-args* (cdr new-args))) + (setf *simple-args* new-args) + `(when ,(caar new-args) + , at guts)) + (t + (setf *only-simple-args* nil) + (hairy)))) + (hairy)))) + +(defun expand-true-false-conditional (true false) + (let ((arg (expand-next-arg))) + (flet ((hairy () + `(if ,arg + (progn + ,@(expand-directive-list true)) + (progn + ,@(expand-directive-list false))))) + (if *only-simple-args* + (multiple-value-bind (true-guts true-args true-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list true) + *simple-args* + *only-simple-args*)) + (multiple-value-bind (false-guts false-args false-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list false) + *simple-args* + *only-simple-args*)) + (if (= (length true-args) (length false-args)) + `(if ,arg + (progn + , at true-guts) + ,(do ((false false-args (cdr false)) + (true true-args (cdr true)) + (bindings nil (cons `(,(caar false) ,(caar true)) + bindings))) + ((eq true *simple-args*) + (setf *simple-args* true-args) + (setf *only-simple-args* + (and true-simple false-simple)) + (if bindings + `(let ,bindings + , at false-guts) + `(progn + , at false-guts))))) + (progn + (setf *only-simple-args* nil) + (hairy))))) + (hairy))))) + +(def-complex-format-directive #\; () + (error 'format-error + :complaint + "~~; directive not contained within either ~~[...~~] or ~~<...~~>")) + +(def-complex-format-directive #\] () + (error 'format-error + :complaint + "no corresponding open bracket")) + +;;;; format directive for up-and-out + +(def-format-directive #\^ (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "cannot use the at-sign modifier with this directive")) + (when (and colonp (not *up-up-and-out-allowed*)) + (error 'format-error + :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) + `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params + `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) + (,arg2 (eql ,arg1 ,arg2)) + (,arg1 (eql ,arg1 0)) + (t ,(if colonp + '(null outside-args) + (progn + (setf *only-simple-args* nil) + '(null args)))))) + ,(if colonp + '(return-from outside-loop nil) + '(return)))) + +;;;; format directives for iteration + +(def-complex-format-directive #\{ (colonp atsignp params string end directives) + (let ((close (find-directive directives #\} nil))) + (unless close + (error 'format-error + :complaint "no corresponding close brace")) + (let* ((closed-with-colon (format-directive-colonp close)) + (posn (position close directives))) + (labels + ((compute-insides () + (if (zerop posn) + (if *orig-args-available* + `((handler-bind + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) + (setf args + (%format stream inside-string orig-args args)))) + (throw 'need-orig-args nil)) + (let ((*up-up-and-out-allowed* colonp)) + (expand-directive-list (subseq directives 0 posn))))) + (compute-loop (count) + (when atsignp + (setf *only-simple-args* nil)) + `(loop + ,@(unless closed-with-colon + '((when (null args) + (return)))) + ,@(when count + `((when (and ,count (minusp (decf ,count))) + (return)))) + ,@(if colonp + (let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + `((let* ((orig-args ,(expand-next-arg)) + (outside-args args) + (args orig-args)) + (declare (ignorable orig-args outside-args args)) + (block nil + ,@(compute-insides))))) + (compute-insides)) + ,@(when closed-with-colon + '((when (null args) + (return)))))) + (compute-block (count) + (if colonp + `(block outside-loop + ,(compute-loop count)) + (compute-loop count))) + (compute-bindings (count) + (if atsignp + (compute-block count) + `(let* ((orig-args ,(expand-next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,(let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + (compute-block count)))))) + (values (if params + (expand-bind-defaults ((count nil)) params + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings count)) + (compute-bindings count))) + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings nil)) + (compute-bindings nil))) + (nthcdr (1+ posn) directives)))))) + +(def-complex-format-directive #\} () + (error 'format-error + :complaint "no corresponding open brace")) + +;;;; format directives and support functions for justification + +(defparameter *illegal-inside-justification* + (mapcar (lambda (x) (parse-directive x 0)) + '("~W" "~:W" "~@W" "~:@W" + "~_" "~:_" "~@_" "~:@_" + "~:>" "~:@>" + "~I" "~:I" "~@I" "~:@I" + "~:T" "~:@T"))) + +(defun illegal-inside-justification-p (directive) + (member directive *illegal-inside-justification* + :test (lambda (x y) + (and (format-directive-p x) + (format-directive-p y) + (eql (format-directive-character x) (format-directive-character y)) + (eql (format-directive-colonp x) (format-directive-colonp y)) + (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) + +(def-complex-format-directive #\< (colonp atsignp params string end directives) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (values + (if (format-directive-colonp close) + (multiple-value-bind (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (expand-format-logical-block prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :args (list count))) + (expand-format-justification segments colonp atsignp + first-semi params))) + remaining))) + +(def-complex-format-directive #\> () + (error 'format-error + :complaint "no corresponding open bracket")) + +(defun parse-format-logical-block + (segments colonp first-semi close params string end) + (when params + (error 'format-error + :complaint "No parameters can be supplied with ~~<...~~:>." + :offset (caar params))) + (multiple-value-bind (prefix insides suffix) + (multiple-value-bind (prefix-default suffix-default) + (if colonp (values "(" ")") (values "" "")) + (flet ((extract-string (list prefix-p) + (let ((directive (find-if #'format-directive-p list))) + (if directive + (error 'format-error + :complaint + "cannot include format directives inside the ~ + ~:[suffix~;prefix~] segment of ~~<...~~:>" + :args (list prefix-p) + :offset (1- (format-directive-end directive))) + (apply #'concatenate 'string list))))) + (case (length segments) + (0 (values prefix-default nil suffix-default)) + (1 (values prefix-default (car segments) suffix-default)) + (2 (values (extract-string (car segments) t) + (cadr segments) suffix-default)) + (3 (values (extract-string (car segments) t) + (cadr segments) + (extract-string (caddr segments) nil))) + (t + (error 'format-error + :complaint "too many segments for ~~<...~~:>"))))) + (when (format-directive-atsignp close) + (setf insides + (add-fill-style-newlines insides + string + (if first-semi + (format-directive-end first-semi) + end)))) + (values prefix + (and first-semi (format-directive-atsignp first-semi)) + insides + suffix))) + +(defun add-fill-style-newlines (list string offset &optional last-directive) + (cond + (list + (let ((directive (car list))) + (cond + ((simple-string-p directive) + (let* ((non-space (position #\Space directive :test #'char/=)) + (newlinep (and last-directive + (char= + (format-directive-character last-directive) + #\Newline)))) + (cond + ((and newlinep non-space) + (nconc + (list (subseq directive 0 non-space)) + (add-fill-style-newlines-aux + (subseq directive non-space) string (+ offset non-space)) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (newlinep + (cons directive + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (t + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive)))))))) + (t + (cons directive + (add-fill-style-newlines + (cdr list) string + (format-directive-end directive) directive)))))) + (t nil))) + +(defun add-fill-style-newlines-aux (literal string offset) + (let ((end (length literal)) + (posn 0)) + (collect ((results)) + (loop + (let ((blank (position #\space literal :start posn))) + (when (null blank) + (results (subseq literal posn)) + (return)) + (let ((non-blank (or (position #\space literal :start blank + :test #'char/=) + end))) + (results (subseq literal posn non-blank)) + (results (make-format-directive + :string string :character #\_ + :start (+ offset non-blank) :end (+ offset non-blank) + :colonp t :atsignp nil :params nil)) + (setf posn non-blank)) + (when (= posn end) + (return)))) + (results)))) + +(defun parse-format-justification (directives) + (let ((first-semi nil) + (close nil) + (remaining directives)) + (collect ((segments)) + (loop + (let ((close-or-semi (find-directive remaining #\> t))) + (unless close-or-semi + (error 'format-error + :complaint "no corresponding close bracket")) + (let ((posn (position close-or-semi remaining))) + (segments (subseq remaining 0 posn)) + (setf remaining (nthcdr (1+ posn) remaining))) + (when (char= (format-directive-character close-or-semi) + #\>) + (setf close close-or-semi) + (return)) + (unless first-semi + (setf first-semi close-or-semi)))) + (values (segments) first-semi close remaining)))) + +(defmacro expander-pprint-next-arg (string offset) + `(progn + (when (null args) + (error 'format-error + :complaint "no more arguments" + :control-string ,string + :offset ,offset)) + (pprint-pop) + (pop args))) + +(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) + `(let ((arg ,(if atsignp 'args (expand-next-arg)))) + ,@(when atsignp + (setf *only-simple-args* nil) + '((setf args nil))) + (pprint-logical-block + (stream arg + ,(if per-line-p :per-line-prefix :prefix) ,prefix + :suffix ,suffix) + (let ((args arg) + ,@(unless atsignp + `((orig-args arg)))) + (declare (ignorable args ,@(unless atsignp '(orig-args)))) + (block nil + ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) + (*only-simple-args* nil) + (*orig-args-available* + (if atsignp *orig-args-available* t))) + (expand-directive-list insides))))))) + +(defun expand-format-justification (segments colonp atsignp first-semi params) + (let ((newline-segment-p + (and first-semi + (format-directive-colonp first-semi)))) + (expand-bind-defaults + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + `(let ((segments nil) + ,@(when newline-segment-p + '((newline-segment nil) + (extra-space 0) + (line-len 72)))) + (block nil + ,@(when newline-segment-p + `((setf newline-segment + (with-output-to-string (stream) + ,@(expand-directive-list (pop segments)))) + ,(expand-bind-defaults + ((extra 0) + (line-len '(or #-abcl(sb!impl::line-length stream) 72))) + (format-directive-params first-semi) + `(setf extra-space ,extra line-len ,line-len)))) + ,@(mapcar (lambda (segment) + `(push (with-output-to-string (stream) + ,@(expand-directive-list segment)) + segments)) + segments)) + (format-justification stream + ,@(if newline-segment-p + '(newline-segment extra-space line-len) + '(nil 0 0)) + segments ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))))) + +;;;; format directive and support function for user-defined method + +(def-format-directive #\/ (string start end colonp atsignp params) + (let ((symbol (extract-user-fun-name string start end))) + (collect ((param-names) (bindings)) + (dolist (param-and-offset params) + (let ((param (cdr param-and-offset))) + (let ((param-name (gensym))) + (param-names param-name) + (bindings `(,param-name + ,(case param + (:arg (expand-next-arg)) + (:remaining '(length args)) + (t param))))))) + `(let ,(bindings) + (,symbol stream ,(expand-next-arg) ,colonp ,atsignp + ,@(param-names)))))) + +(defun extract-user-fun-name (string start end) + (let ((slash (position #\/ string :start start :end (1- end) + :from-end t))) + (unless slash + (error 'format-error + :complaint "malformed ~~/ directive")) + (let* ((name (string-upcase (let ((foo string)) + ;; Hack alert: This is to keep the compiler + ;; quiet about deleting code inside the + ;; subseq expansion. + (subseq foo (1+ slash) (1- end))))) + (first-colon (position #\: name)) + (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) + (package-name (if first-colon + (subseq name 0 first-colon) + "COMMON-LISP-USER")) + (package (find-package package-name))) + (unless package + ;; FIXME: should be PACKAGE-ERROR? Could we just use + ;; FIND-UNDELETED-PACKAGE-OR-LOSE? + (error 'format-error + :complaint "no package named ~S" + :args (list package-name))) + (intern (cond + ((and second-colon (= second-colon (1+ first-colon))) + (subseq name (1+ second-colon))) + (first-colon + (subseq name (1+ first-colon))) + (t name)) + package)))) + +;;; compile-time checking for argument mismatch. This code is +;;; inspired by that of Gerd Moellmann, and comes decorated with +;;; FIXMEs: +(defun %compiler-walk-format-string (string args) + (declare (type simple-string string)) + (let ((*default-format-error-control-string* string)) + (macrolet ((incf-both (&optional (increment 1)) + `(progn + (incf min ,increment) + (incf max ,increment))) + (walk-complex-directive (function) + `(multiple-value-bind (min-inc max-inc remaining) + (,function directive directives args) + (incf min min-inc) + (incf max max-inc) + (setq directives remaining)))) + ;; FIXME: these functions take a list of arguments as well as + ;; the directive stream. This is to enable possibly some + ;; limited type checking on FORMAT's arguments, as well as + ;; simple argument count mismatch checking: when the minimum and + ;; maximum argument counts are the same at a given point, we + ;; know which argument is going to be used for a given + ;; directive, and some (annotated below) require arguments of + ;; particular types. + (labels + ((walk-justification (justification directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (format-directive-end justification)))) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (declare (ignore segments first-semi)) + (cond + ((not (format-directive-colonp close)) + (values 0 0 directives)) + ((format-directive-atsignp justification) + (values 0 call-arguments-limit directives)) + ;; FIXME: here we could assert that the + ;; corresponding argument was a list. + (t (values 1 1 remaining)))))) + (walk-conditional (conditional directives args) + (let ((*default-format-error-offset* + (1- (format-directive-end conditional)))) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (declare (ignore last-semi-with-colon-p)) + (let ((sub-max + (loop for s in sublists + maximize (nth-value + 1 (walk-directive-list s args))))) + (cond + ((format-directive-atsignp conditional) + (values 1 (max 1 sub-max) remaining)) + ((loop for p in (format-directive-params conditional) + thereis (or (integerp (cdr p)) + (memq (cdr p) '(:remaining :arg)))) + (values 0 sub-max remaining)) + ;; FIXME: if not COLONP, then the next argument + ;; must be a number. + (t (values 1 (1+ sub-max) remaining))))))) + (walk-iteration (iteration directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (format-directive-end iteration)))) + (let* ((close (find-directive directives #\} nil)) + (posn (or (position close directives) + (error 'format-error + :complaint "no corresponding close brace"))) + (remaining (nthcdr (1+ posn) directives))) + ;; FIXME: if POSN is zero, the next argument must be + ;; a format control (either a function or a string). + (if (format-directive-atsignp iteration) + (values (if (zerop posn) 1 0) + call-arguments-limit + remaining) + ;; FIXME: the argument corresponding to this + ;; directive must be a list. + (let ((nreq (if (zerop posn) 2 1))) + (values nreq nreq remaining)))))) + (walk-directive-list (directives args) + (let ((min 0) (max 0)) + (loop + (let ((directive (pop directives))) + (when (null directive) + (return (values min (min max call-arguments-limit)))) + (when (format-directive-p directive) + (incf-both (count :arg (format-directive-params directive) + :key #'cdr)) + (let ((c (format-directive-character directive))) + (cond + ((find c "ABCDEFGORSWX$/") + (incf-both)) + ((char= c #\P) + (unless (format-directive-colonp directive) + (incf-both))) + ((or (find c "IT%&|_();>") (char= c #\Newline))) + ;; FIXME: check correspondence of ~( and ~) + ((char= c #\<) + (walk-complex-directive walk-justification)) + ((char= c #\[) + (walk-complex-directive walk-conditional)) + ((char= c #\{) + (walk-complex-directive walk-iteration)) + ((char= c #\?) + ;; FIXME: the argument corresponding to this + ;; directive must be a format control. + (cond + ((format-directive-atsignp directive) + (incf min) + (setq max call-arguments-limit)) + (t (incf-both 2)))) + (t (throw 'give-up-format-string-walk nil)))))))))) + (catch 'give-up-format-string-walk + (let ((directives (tokenize-control-string string))) + (walk-directive-list directives args))))))) + +;;; From target-format.lisp. + +(in-package #:format) + +(defun format (destination control-string &rest format-arguments) + (etypecase destination + (null + (with-output-to-string (stream) + (%format stream control-string format-arguments))) + (string + (with-output-to-string (stream destination) + (%format stream control-string format-arguments))) + ((member t) + (%format *standard-output* control-string format-arguments) + nil) + ((or stream xp::xp-structure) + (%format destination control-string format-arguments) + nil))) + +(defun %format (stream string-or-fun orig-args &optional (args orig-args)) + (if (functionp string-or-fun) + (apply string-or-fun stream args) + (catch 'up-and-out + (let* ((string (etypecase string-or-fun + (simple-string + string-or-fun) + (string + (coerce string-or-fun 'simple-string)))) + (*default-format-error-control-string* string) + (*logical-block-popper* nil)) + (interpret-directive-list stream (tokenize-control-string string) + orig-args args))))) + +(defun interpret-directive-list (stream directives orig-args args) + (if directives + (let ((directive (car directives))) + (etypecase directive + (simple-string + (write-string directive stream) + (interpret-directive-list stream (cdr directives) orig-args args)) + (format-directive + (multiple-value-bind (new-directives new-args) + (let* ((character (format-directive-character directive)) + (function + (svref *format-directive-interpreters* + (char-code character))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) + (unless function + (error 'format-error + :complaint "unknown format directive ~@[(character: ~A)~]" + :args (list (char-name character)))) + (multiple-value-bind (new-directives new-args) + (funcall function stream directive + (cdr directives) orig-args args) + (values new-directives new-args))) + (interpret-directive-list stream new-directives + orig-args new-args))))) + args)) + +;;;; FORMAT directive definition macros and runtime support + +(eval-when (:compile-toplevel :execute) + + ;;; This macro is used to extract the next argument from the current arg list. + ;;; This is the version used by format directive interpreters. + (defmacro next-arg (&optional offset) + `(progn + (when (null args) + (error 'format-error + :complaint "no more arguments" + ,@(when offset + `(:offset ,offset)))) + (when *logical-block-popper* + (funcall *logical-block-popper*)) + (pop args))) + + (defmacro def-complex-format-interpreter (char lambda-list &body body) + (let ((defun-name + (intern (concatenate 'string + (let ((name (char-name char))) + (cond (name + (string-capitalize name)) + (t + (string char)))) + "-FORMAT-DIRECTIVE-INTERPRETER"))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) + `(progn + (defun ,defun-name (stream ,directive ,directives orig-args args) + (declare (ignorable stream orig-args args)) + ,@(if lambda-list + `((let ,(mapcar (lambda (var) + `(,var + (,(sys::symbolicate "FORMAT-DIRECTIVE-" var) + ,directive))) + (butlast lambda-list)) + (values (progn , at body) args))) + `((declare (ignore ,directive ,directives)) + , at body))) + (%set-format-directive-interpreter ,char #',defun-name)))) + + (defmacro def-format-interpreter (char lambda-list &body body) + (let ((directives (gensym))) + `(def-complex-format-interpreter ,char (, at lambda-list ,directives) + , at body + ,directives))) + + (defmacro interpret-bind-defaults (specs params &body body) + (sys::once-only ((params params)) + (collect ((bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (bindings `(,var (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg (or (next-arg offset) ,default)) + (:remaining (length args)) + ((nil) ,default) + (t param))))))) + `(let* ,(bindings) + (when ,params + (error 'format-error + :complaint + "too many parameters, expected no more than ~W" + :args (list ,(length specs)) + :offset (caar ,params))) + , at body)))) + + ) ; EVAL-WHEN + +;;;; format interpreters and support functions for simple output + +(defun format-write-field (stream string mincol colinc minpad padchar padleft) + (unless padleft + (write-string string stream)) + (dotimes (i minpad) + (write-char padchar stream)) + ;; As of sbcl-0.6.12.34, we could end up here when someone tries to + ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says + ;; we're supposed to soldier on bravely, and so we have to deal with + ;; the unsupplied-MINCOL-and-COLINC case without blowing up. + (when (and mincol colinc) + (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc))) + ((>= chars mincol)) + (dotimes (i colinc) + (write-char padchar stream)))) + (when padleft + (write-string string stream))) + +(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) + (format-write-field stream + (if (or arg (not colonp)) + (princ-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) + +(def-format-interpreter #\A (colonp atsignp params) + (if params + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + (format-princ stream (next-arg) colonp atsignp + mincol colinc minpad padchar)) + (princ (if colonp (or (next-arg) "()") (next-arg)) stream))) + +(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) + (format-write-field stream + (if (or arg (not colonp)) + (prin1-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) + +(def-format-interpreter #\S (colonp atsignp params) + (cond (params + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + (format-prin1 stream (next-arg) colonp atsignp + mincol colinc minpad padchar))) + (colonp + (let ((arg (next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + (prin1 (next-arg) stream)))) + +(def-format-interpreter #\C (colonp atsignp params) + (interpret-bind-defaults () params + (if colonp + (format-print-named-character (next-arg) stream) + (if atsignp + (prin1 (next-arg) stream) + (write-char (next-arg) stream))))) + +(defun format-print-named-character (char stream) + (let* ((name (char-name char))) + (cond (name + (write-string (string-capitalize name) stream)) + (t + (write-char char stream))))) + +(def-format-interpreter #\W (colonp atsignp params) + (interpret-bind-defaults () params + (let ((*print-pretty* (or colonp *print-pretty*)) + (*print-level* (unless atsignp *print-level*)) + (*print-length* (unless atsignp *print-length*))) + (sys::output-object (next-arg) stream)))) + +;;;; format interpreters and support functions for integer output + +;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing +;;; directives. The parameters are interpreted as defined for ~D. +(defun format-print-integer (stream number print-commas-p print-sign-p + radix mincol padchar commachar commainterval) + (let ((*print-base* radix) + (*print-radix* nil)) + (if (integerp number) + (let* ((text (princ-to-string (abs number))) + (commaed (if print-commas-p + (format-add-commas text commachar commainterval) + text)) + (signed (cond ((minusp number) + (concatenate 'string "-" commaed)) + (print-sign-p + (concatenate 'string "+" commaed)) + (t commaed)))) + ;; colinc = 1, minpad = 0, padleft = t + (format-write-field stream signed mincol 1 0 padchar t)) + (princ number stream)))) + +(defun format-add-commas (string commachar commainterval) + (let ((length (length string))) + (multiple-value-bind (commas extra) (truncate (1- length) commainterval) + (let ((new-string (make-string (+ length commas))) + (first-comma (1+ extra))) + (replace new-string string :end1 first-comma :end2 first-comma) + (do ((src first-comma (+ src commainterval)) + (dst first-comma (+ dst commainterval 1))) + ((= src length)) + (setf (schar new-string dst) commachar) + (replace new-string string :start1 (1+ dst) + :start2 src :end2 (+ src commainterval))) + new-string)))) + +;;; FIXME: This is only needed in this file, could be defined with +;;; SB!XC:DEFMACRO inside EVAL-WHEN +(defmacro interpret-format-integer (base) + `(if (or colonp atsignp params) + (interpret-bind-defaults + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + (format-print-integer stream (next-arg) colonp atsignp ,base mincol + padchar commachar commainterval)) + (write (next-arg) :stream stream :base ,base :radix nil :escape nil))) + +(def-format-interpreter #\D (colonp atsignp params) + (interpret-format-integer 10)) + +(def-format-interpreter #\B (colonp atsignp params) + (interpret-format-integer 2)) + +(def-format-interpreter #\O (colonp atsignp params) + (interpret-format-integer 8)) + +(def-format-interpreter #\X (colonp atsignp params) + (interpret-format-integer 16)) + +(def-format-interpreter #\R (colonp atsignp params) + (interpret-bind-defaults + ((base nil) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (let ((arg (next-arg))) + (if base + (format-print-integer stream arg colonp atsignp base mincol + padchar commachar commainterval) + (if atsignp + (if colonp + (format-print-old-roman stream arg) + (format-print-roman stream arg)) + (if colonp + (format-print-ordinal stream arg) + (format-print-cardinal stream arg))))))) + +(defparameter *cardinal-ones* + #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) + +(defparameter *cardinal-tens* + #(nil nil "twenty" "thirty" "forty" + "fifty" "sixty" "seventy" "eighty" "ninety")) + +(defparameter *cardinal-teens* + #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) + +(defparameter *cardinal-periods* + #("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion" " undecillion" " duodecillion" " tredecillion" + " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" + " octodecillion" " novemdecillion" " vigintillion")) + +(defparameter *ordinal-ones* + #(nil "first" "second" "third" "fourth" + "fifth" "sixth" "seventh" "eighth" "ninth")) + +(defparameter *ordinal-tens* + #(nil "tenth" "twentieth" "thirtieth" "fortieth" + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) + +(defun format-print-small-cardinal (stream n) + (multiple-value-bind (hundreds rem) (truncate n 100) + (when (plusp hundreds) + (write-string (svref *cardinal-ones* hundreds) stream) + (write-string " hundred" stream) + (when (plusp rem) + (write-char #\space stream))) + (when (plusp rem) + (multiple-value-bind (tens ones) (truncate rem 10) + (cond ((< 1 tens) + (write-string (svref *cardinal-tens* tens) stream) + (when (plusp ones) + (write-char #\- stream) + (write-string (svref *cardinal-ones* ones) stream))) + ((= tens 1) + (write-string (svref *cardinal-teens* ones) stream)) + ((plusp ones) + (write-string (svref *cardinal-ones* ones) stream))))))) + +(defun format-print-cardinal (stream n) + (cond ((minusp n) + (write-string "negative " stream) + (format-print-cardinal-aux stream (- n) 0 n)) + ((zerop n) + (write-string "zero" stream)) + (t + (format-print-cardinal-aux stream n 0 n)))) + +(defun format-print-cardinal-aux (stream n period err) + (multiple-value-bind (beyond here) (truncate n 1000) + (unless (<= period 20) + (error "number too large to print in English: ~:D" err)) + (unless (zerop beyond) + (format-print-cardinal-aux stream beyond (1+ period) err)) + (unless (zerop here) + (unless (zerop beyond) + (write-char #\space stream)) + (format-print-small-cardinal stream here) + (write-string (svref *cardinal-periods* period) stream)))) + +(defun format-print-ordinal (stream n) + (when (minusp n) + (write-string "negative " stream)) + (let ((number (abs n))) + (multiple-value-bind (top bot) (truncate number 100) + (unless (zerop top) + (format-print-cardinal stream (- number bot))) + (when (and (plusp top) (plusp bot)) + (write-char #\space stream)) + (multiple-value-bind (tens ones) (truncate bot 10) + (cond ((= bot 12) (write-string "twelfth" stream)) + ((= tens 1) + (write-string (svref *cardinal-teens* ones) stream);;;RAD + (write-string "th" stream)) + ((and (zerop tens) (plusp ones)) + (write-string (svref *ordinal-ones* ones) stream)) + ((and (zerop ones)(plusp tens)) + (write-string (svref *ordinal-tens* tens) stream)) + ((plusp bot) + (write-string (svref *cardinal-tens* tens) stream) + (write-char #\- stream) + (write-string (svref *ordinal-ones* ones) stream)) + ((plusp number) + (write-string "th" stream)) + (t + (write-string "zeroth" stream))))))) + +;;; Print Roman numerals + +(defun format-print-old-roman (stream n) + (unless (< 0 n 5000) + (error "Number too large to print in old Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (start n (do ((i start (progn + (write-char cur-char stream) + (- i cur-val)))) + ((< i cur-val) i)))) + ((zerop start)))) + +(defun format-print-roman (stream n) + (unless (< 0 n 4000) + (error "Number too large to print in Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) + (sub-val '(100 10 10 1 1 0) (cdr sub-val)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (cur-sub-char #\C (car sub-chars)) + (cur-sub-val 100 (car sub-val)) + (start n (do ((i start (progn + (write-char cur-char stream) + (- i cur-val)))) + ((< i cur-val) + (cond ((<= (- cur-val cur-sub-val) i) + (write-char cur-sub-char stream) + (write-char cur-char stream) + (- i (- cur-val cur-sub-val))) + (t i)))))) + ((zerop start)))) + +;;;; plural + +(def-format-interpreter #\P (colonp atsignp params) + (interpret-bind-defaults () params + (let ((arg (if colonp + (if (eq orig-args args) + (error 'format-error + :complaint "no previous argument") + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr)))) + (next-arg)))) + (if atsignp + (write-string (if (eql arg 1) "y" "ies") stream) + (unless (eql arg 1) (write-char #\s stream)))))) + +;;;; format interpreters and support functions for floating point output + +(defun decimal-string (n) + (write-to-string n :base 10 :radix nil :escape nil)) + +(def-format-interpreter #\F (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "cannot specify the colon modifier with this directive")) + (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + params + (format-fixed stream (next-arg) w d k ovf pad atsignp))) + +(defun format-fixed (stream number w d k ovf pad atsign) + (if (numberp number) + (if (floatp number) + (format-fixed-aux stream number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux stream + (coerce number 'single-float) + w d k ovf pad atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + (format-princ stream number nil nil w 1 0 pad))) + +;;; We return true if we overflowed, so that ~G can output the overflow char +;;; instead of spaces. +(defun format-fixed-aux (stream number w d k ovf pad atsign) + (cond + ((and (floatp number) + (or (sys:float-infinity-p number) + (sys:float-nan-p number))) + (prin1 number stream) + nil) + (t + (let ((spaceleft w)) + (when (and w (or atsign (minusp (float-sign number)))) + (decf spaceleft)) + (multiple-value-bind (str len lpoint tpoint) + (sys::flonum-to-string (abs number) spaceleft d k) + ;;if caller specifically requested no fraction digits, suppress the + ;;optional trailing zero + (when (and d (zerop d)) + (setf tpoint nil)) + (when w + (decf spaceleft len) + ;;optional leading zero + (when lpoint + (if (or (> spaceleft 0) tpoint) ;force at least one digit + (decf spaceleft) + (setq lpoint nil))) + ;;optional trailing zero + (when tpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq tpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;field width overflow + (dotimes (i w) (write-char ovf stream)) + t) + (t + (when w (dotimes (i spaceleft) (write-char pad stream))) + (cond ((minusp (float-sign number)) + (write-char #\- stream)) + (atsign + (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string str stream) + (when tpoint (write-char #\0 stream)) + nil))))))) + +(def-format-interpreter #\E (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "cannot specify the colon modifier with this directive")) + (interpret-bind-defaults + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) + params + (format-exponential stream (next-arg) w d e k ovf pad mark atsignp))) + +(defun format-exponential (stream number w d e k ovf pad marker atsign) + (if (numberp number) + (if (floatp number) + (format-exp-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + (format-princ stream number nil nil w 1 0 pad))) + +(defun format-exponent-marker (number) + (if (typep number *read-default-float-format*) + #\e + (typecase number + (single-float #\f) + (double-float #\d) + (short-float #\s) + (long-float #\l)))) + +;;; Here we prevent the scale factor from shifting all significance out of +;;; a number to the right. We allow insignificant zeroes to be shifted in +;;; to the left right, athough it is an error to specify k and d such that this +;;; occurs. Perhaps we should detect both these condtions and flag them as +;;; errors. As for now, we let the user get away with it, and merely guarantee +;;; that at least one significant digit will appear. + +;;; Raymond Toy writes: The Hyperspec seems to say that the exponent +;;; marker is always printed. Make it so. Also, the original version +;;; causes errors when printing infinities or NaN's. The Hyperspec is +;;; silent here, so let's just print out infinities and NaN's instead +;;; of causing an error. +(defun format-exp-aux (stream number w d e k ovf pad marker atsign) + (if (and (floatp number) + (or (sys::float-infinity-p number) + (sys::float-nan-p number))) + (prin1 number stream) + (multiple-value-bind (num expt) (sys::scale-exponent (abs number)) + (let* ((expt (- expt k)) + (estr (decimal-string (abs expt))) + (elen (if e (max (length estr) e) (length estr))) + (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (minusp k) (- 1 k) nil)) + (spaceleft (if w + (- w 2 elen + (if (or atsign (minusp number)) + 1 0)) + nil))) + (if (and w ovf e (> elen e)) ;exponent overflow + (dotimes (i w) (write-char ovf stream)) + (multiple-value-bind (fstr flen lpoint) + (sys::flonum-to-string num spaceleft fdig k fmin) + (when w + (decf spaceleft flen) + (when lpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq lpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;significand overflow + (dotimes (i w) (write-char ovf stream))) + (t (when w + (dotimes (i spaceleft) (write-char pad stream))) + (if (minusp number) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream))))))))) + +(def-format-interpreter #\G (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "cannot specify the colon modifier with this directive")) + (interpret-bind-defaults + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) + params + (format-general stream (next-arg) w d e k ovf pad mark atsignp))) + +(defun format-general (stream number w d e k ovf pad marker atsign) + (if (numberp number) + (if (floatp number) + (format-general-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + (format-princ stream number nil nil w 1 0 pad))) + +;;; Raymond Toy writes: same change as for format-exp-aux +(defun format-general-aux (stream number w d e k ovf pad marker atsign) + (if (and (floatp number) + (or (sys::float-infinity-p number) + (sys::float-nan-p number))) + (prin1 number stream) + (multiple-value-bind (ignore n) (sys::scale-exponent (abs number)) + (declare (ignore ignore)) + ;; KLUDGE: Default d if omitted. The procedure is taken directly from + ;; the definition given in the manual, and is not very efficient, since + ;; we generate the digits twice. Future maintainers are encouraged to + ;; improve on this. -- rtoy?? 1998?? + (unless d + (multiple-value-bind (str len) + (sys::flonum-to-string (abs number)) + (declare (ignore str)) + (let ((q (if (= len 1) 1 (1- len)))) + (setq d (max q (min n 7)))))) + (let* ((ee (if e (+ e 2) 4)) + (ww (if w (- w ee) nil)) + (dd (- d n))) + (cond ((<= 0 dd d) + (let ((char (if (format-fixed-aux stream number ww dd nil + ovf pad atsign) + ovf + #\space))) + (dotimes (i ee) (write-char char stream)))) + (t + (format-exp-aux stream number w d e (or k 1) + ovf pad marker atsign))))))) + +(def-format-interpreter #\$ (colonp atsignp params) + (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params + (format-dollars stream (next-arg) d n w pad colonp atsignp))) + +(defun format-dollars (stream number d n w pad colon atsign) + (when (rationalp number) + ;; This coercion to SINGLE-FLOAT seems as though it gratuitously + ;; loses precision (why not LONG-FLOAT?) but it's the default + ;; behavior in the ANSI spec, so in some sense it's the right + ;; thing, and at least the user shouldn't be surprised. + (setq number (coerce number 'single-float))) + (if (floatp number) + (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) + (signlen (length signstr))) + (multiple-value-bind (str strlen ig2 ig3 pointplace) + (sys::flonum-to-string number nil d nil) + (declare (ignore ig2 ig3 strlen)) + (when colon + (write-string signstr stream)) + (dotimes (i (- w signlen (max n pointplace) 1 d)) + (write-char pad stream)) + (unless colon + (write-string signstr stream)) + (dotimes (i (- n pointplace)) + (write-char #\0 stream)) + (write-string str stream))) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) + +;;;; FORMAT interpreters and support functions for line/page breaks etc. + +(def-format-interpreter #\% (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "cannot specify either colon or atsign for this directive")) + (interpret-bind-defaults ((count 1)) params + (dotimes (i count) + (terpri stream)))) + +(def-format-interpreter #\& (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "cannot specify either colon or atsign for this directive")) + (interpret-bind-defaults ((count 1)) params + (fresh-line stream) + (dotimes (i (1- count)) + (terpri stream)))) + +(def-format-interpreter #\| (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "cannot specify either colon or atsign for this directive")) + (interpret-bind-defaults ((count 1)) params + (dotimes (i count) + (write-char (code-char sys::form-feed-char-code) stream)))) + +(def-format-interpreter #\~ (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "cannot specify either colon or atsign for this directive")) + (interpret-bind-defaults ((count 1)) params + (dotimes (i count) + (write-char #\~ stream)))) + +(def-complex-format-interpreter #\newline (colonp atsignp params directives) + (when (and colonp atsignp) + (error 'format-error + :complaint + "cannot specify both colon and atsign for this directive")) + (interpret-bind-defaults () params + (when atsignp + (write-char #\newline stream))) + (if (and (not colonp) + directives + (simple-string-p (car directives))) + (cons (string-left-trim *format-whitespace-chars* + (car directives)) + (cdr directives)) + directives)) + +;;;; format interpreters and support functions for tabs and simple pretty +;;;; printing + +(def-format-interpreter #\T (colonp atsignp params) + (if colonp + (interpret-bind-defaults ((n 1) (m 1)) params + (pprint-tab (if atsignp :section-relative :section) n m stream)) + (if atsignp + (interpret-bind-defaults ((colrel 1) (colinc 1)) params + (format-relative-tab stream colrel colinc)) + (interpret-bind-defaults ((colnum 1) (colinc 1)) params + (format-absolute-tab stream colnum colinc))))) + +(defun output-spaces (stream n) + (let ((spaces #.(make-string 100 :initial-element #\space))) + (loop + (when (< n (length spaces)) + (return)) + (write-string spaces stream) + (decf n (length spaces))) + (write-string spaces stream :end n))) + +(defun format-relative-tab (stream colrel colinc) + (if (xp::xp-structure-p stream) + (pprint-tab :line-relative colrel colinc stream) + (let* ((cur (charpos stream)) + (spaces (if (and cur (plusp colinc)) + (- (* (ceiling (+ cur colrel) colinc) colinc) cur) + colrel))) + (output-spaces stream spaces)))) + +(defun format-absolute-tab (stream colnum colinc) + (if (xp::xp-structure-p stream) + (pprint-tab :line colnum colinc stream) + (let ((cur (charpos stream))) + (cond ((null cur) + (write-string " " stream)) + ((< cur colnum) + (output-spaces stream (- colnum cur))) + (t + (unless (zerop colinc) + (output-spaces stream + (- colinc (rem (- cur colnum) colinc))))))))) + +(def-format-interpreter #\_ (colonp atsignp params) + (interpret-bind-defaults () params + (pprint-newline (if colonp + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) + +(def-format-interpreter #\I (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "cannot specify the at-sign modifier")) + (interpret-bind-defaults ((n 0)) params + (pprint-indent (if colonp :current :block) n stream))) + +;;;; format interpreter for ~* + +(def-format-interpreter #\* (colonp atsignp params) + (if atsignp + (if colonp + (error 'format-error + :complaint "cannot specify both colon and at-sign") + (interpret-bind-defaults ((posn 0)) params + (if (<= 0 posn (length orig-args)) + (setf args (nthcdr posn orig-args)) + (error 'format-error + :complaint "Index ~W is out of bounds. (It should ~ + have been between 0 and ~W.)" + :args (list posn (length orig-args)))))) + (if colonp + (interpret-bind-defaults ((n 1)) params + (do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + (error 'format-error + :complaint + "Index ~W is out of bounds. (It should + have been between 0 and ~W.)" + :args + (list new-posn (length orig-args)))))))) + (interpret-bind-defaults ((n 1)) params + (dotimes (i n) + (next-arg)))))) + +;;;; format interpreter for indirection + +(def-format-interpreter #\? (colonp atsignp params string end) + (when colonp + (error 'format-error + :complaint "cannot specify the colon modifier")) + (interpret-bind-defaults () params + (handler-bind + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) + (if atsignp + (setf args (%format stream (next-arg) orig-args args)) + (%format stream (next-arg) (next-arg)))))) + +;;;; format interpreters for capitalization + +(def-complex-format-interpreter #\( (colonp atsignp params directives) + (let ((close (find-directive directives #\) nil))) + (unless close + (error 'format-error + :complaint "no corresponding close paren")) + (interpret-bind-defaults () params + (let* ((posn (position close directives)) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives)) + (stream (sys::make-case-frob-stream stream + (if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + (setf args (interpret-directive-list stream before orig-args args)) + after)))) + +(def-complex-format-interpreter #\) () + (error 'format-error + :complaint "no corresponding open paren")) + +;;;; format interpreters and support functions for conditionalization + +(def-complex-format-interpreter #\[ (colonp atsignp params directives) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (setf args + (if atsignp + (if colonp + (error 'format-error + :complaint + "cannot specify both the colon and at-sign modifiers") + (if (cdr sublists) + (error 'format-error + :complaint + "can only specify one section") + (interpret-bind-defaults () params + (let ((prev-args args) + (arg (next-arg))) + (if arg + (interpret-directive-list stream + (car sublists) + orig-args + prev-args) + args))))) + (if colonp + (if (= (length sublists) 2) + (interpret-bind-defaults () params + (if (next-arg) + (interpret-directive-list stream (car sublists) + orig-args args) + (interpret-directive-list stream (cadr sublists) + orig-args args))) + (error 'format-error + :complaint + "must specify exactly two sections")) + (interpret-bind-defaults ((index (next-arg))) params + (let* ((default (and last-semi-with-colon-p + (pop sublists))) + (last (1- (length sublists))) + (sublist + (if (<= 0 index last) + (nth (- last index) sublists) + default))) + (interpret-directive-list stream sublist orig-args + args)))))) + remaining)) + +(def-complex-format-interpreter #\; () + (error 'format-error + :complaint + "~~; not contained within either ~~[...~~] or ~~<...~~>")) + +(def-complex-format-interpreter #\] () + (error 'format-error + :complaint + "no corresponding open bracket")) + +;;;; format interpreter for up-and-out + +(defvar *outside-args*) + +(def-format-interpreter #\^ (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "cannot specify the at-sign modifier")) + (when (and colonp (not *up-up-and-out-allowed*)) + (error 'format-error + :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) + (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params + (cond (arg3 (<= arg1 arg2 arg3)) + (arg2 (eql arg1 arg2)) + (arg1 (eql arg1 0)) + (t (if colonp + (null *outside-args*) + (null args))))) + (throw (if colonp 'up-up-and-out 'up-and-out) + args))) + +;;;; format interpreters for iteration + +(def-complex-format-interpreter #\{ + (colonp atsignp params string end directives) + (let ((close (find-directive directives #\} nil))) + (unless close + (error 'format-error + :complaint + "no corresponding close brace")) + (interpret-bind-defaults ((max-count nil)) params + (let* ((closed-with-colon (format-directive-colonp close)) + (posn (position close directives)) + (insides (if (zerop posn) + (next-arg) + (subseq directives 0 posn))) + (*up-up-and-out-allowed* colonp)) + (labels + ((do-guts (orig-args args) + (if (zerop posn) + (handler-bind + ((format-error + (lambda (condition) + (error + 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) + (%format stream insides orig-args args)) + (interpret-directive-list stream insides + orig-args args))) + (bind-args (orig-args args) + (if colonp + (let* ((arg (next-arg)) + (*logical-block-popper* nil) + (*outside-args* args)) + (catch 'up-and-out + (do-guts arg arg)) + args) + (do-guts orig-args args))) + (do-loop (orig-args args) + (catch (if colonp 'up-up-and-out 'up-and-out) + (loop + (when (and (not closed-with-colon) (null args)) + (return)) + (when (and max-count (minusp (decf max-count))) + (return)) + (setf args (bind-args orig-args args)) + (when (and closed-with-colon (null args)) + (return))) + args))) + (if atsignp + (setf args (do-loop orig-args args)) + (let ((arg (next-arg)) + (*logical-block-popper* nil)) + (do-loop arg arg))) + (nthcdr (1+ posn) directives)))))) + +(def-complex-format-interpreter #\} () + (error 'format-error + :complaint "no corresponding open brace")) + +;;;; format interpreters and support functions for justification + +(def-complex-format-interpreter #\< + (colonp atsignp params string end directives) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (setf args + (if (format-directive-colonp close) + (multiple-value-bind (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (interpret-format-logical-block stream orig-args args + prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :args (list count))) + (interpret-format-justification stream orig-args args + segments colonp atsignp + first-semi params)))) + remaining)) + +(defun interpret-format-justification + (stream orig-args args segments colonp atsignp first-semi params) + (interpret-bind-defaults + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + (let ((newline-string nil) + (strings nil) + (extra-space 0) + (line-len 0)) + (setf args + (catch 'up-and-out + (when (and first-semi (format-directive-colonp first-semi)) + (interpret-bind-defaults + ((extra 0) + (len (or #-abcl(sb!impl::line-length stream) 72))) + (format-directive-params first-semi) + (setf newline-string + (with-output-to-string (stream) + (setf args + (interpret-directive-list stream + (pop segments) + orig-args + args)))) + (setf extra-space extra) + (setf line-len len))) + (dolist (segment segments) + (push (with-output-to-string (stream) + (setf args + (interpret-directive-list stream segment + orig-args args))) + strings)) + args)) + (format-justification stream newline-string extra-space line-len strings + colonp atsignp mincol colinc minpad padchar))) + args) + +(defun format-justification (stream newline-prefix extra-space line-len strings + pad-left pad-right mincol colinc minpad padchar) + (setf strings (reverse strings)) + (let* ((num-gaps (+ (1- (length strings)) + (if pad-left 1 0) + (if pad-right 1 0))) + (chars (+ (* num-gaps minpad) + (loop + for string in strings + summing (length string)))) + (length (if (> chars mincol) + (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) + mincol)) + (padding (+ (- length chars) (* num-gaps minpad)))) + (when (and newline-prefix + (> (+ (or (charpos stream) 0) + length extra-space) + line-len)) + (write-string newline-prefix stream)) + (flet ((do-padding () + (let ((pad-len (if (zerop num-gaps) + padding + (truncate padding num-gaps)))) + (decf padding pad-len) + (decf num-gaps) + (dotimes (i pad-len) (write-char padchar stream))))) + (when (or pad-left + (and (not pad-right) (null (cdr strings)))) + (do-padding)) + (when strings + (write-string (car strings) stream) + (dolist (string (cdr strings)) + (do-padding) + (write-string string stream))) + (when pad-right + (do-padding))))) + +(defun interpret-format-logical-block + (stream orig-args args prefix per-line-p insides suffix atsignp) + (let ((arg (if atsignp args (next-arg)))) + (if per-line-p + (pprint-logical-block + (stream arg :per-line-prefix prefix :suffix suffix) + (let ((*logical-block-popper* (lambda () (pprint-pop)))) + (catch 'up-and-out + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg)))) + (pprint-logical-block (stream arg :prefix prefix :suffix suffix) + (let ((*logical-block-popper* (lambda () (pprint-pop)))) + (catch 'up-and-out + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg)))))) + (if atsignp nil args)) + +;;;; format interpreter and support functions for user-defined method + +(def-format-interpreter #\/ (string start end colonp atsignp params) + (let ((symbol (extract-user-fun-name string start end))) + (collect ((args)) + (dolist (param-and-offset params) + (let ((param (cdr param-and-offset))) + (case param + (:arg (args (next-arg))) + (:remaining (args (length args))) + (t (args param))))) + (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) + +(setf sys::*simple-format-function* #'format) + + +(provide 'format) Added: branches/save-image/src/org/armedbear/lisp/ftruncate.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ftruncate.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,160 @@ +/* + * ftruncate.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: ftruncate.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### ftruncate number &optional divisor => quotient, remainder +// (defun ftruncate (number &optional (divisor 1)) +// (multiple-value-bind (tru rem) (truncate number divisor) +// (values (float tru) rem))) + +// "FFLOOR, FCEILING, FTRUNCATE, and FROUND handle arguments of different types +// in the following way: If number is a float, and divisor is not a float of +// longer format, then the first result is a float of the same type as number. +// Otherwise, the first result is of the type determined by contagion rules." +public final class ftruncate extends Primitive +{ + private ftruncate() + { + super("ftruncate", "number &optional divisor"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (arg.zerop()) { + LispObject q = arg; + LispObject r; + if (arg instanceof DoubleFloat) + r = DoubleFloat.ZERO; + else + r = SingleFloat.ZERO; + return thread.setValues(q, r); + } + if (arg instanceof DoubleFloat) { + double d = ((DoubleFloat)arg).value; + if (Double.isInfinite(d) || Double.isNaN(d)) + return thread.setValues(arg, new DoubleFloat(Double.NaN)); + } else if (arg instanceof SingleFloat) { + float f = ((SingleFloat)arg).value; + if (Float.isInfinite(f) || Float.isNaN(f)) + return thread.setValues(arg, new SingleFloat(Float.NaN)); + } + LispObject q = arg.truncate(Fixnum.ONE); // an integer + if (arg instanceof DoubleFloat) { + if (q.zerop()) { + if (arg.minusp()) + q = new DoubleFloat(-0.0); + else + q = new DoubleFloat(0.0); + } else if (q instanceof Fixnum) + q = new DoubleFloat(((Fixnum)q).value); + else + q = new DoubleFloat(((Bignum)q).doubleValue()); + } else { + if (q.zerop()) { + if (arg.minusp()) + q = new SingleFloat(-0.0f); + else + q = new SingleFloat(0.0f); + } else if (q instanceof Fixnum) + q = new SingleFloat(((Fixnum)q).value); + else + q = new SingleFloat(((Bignum)q).floatValue()); + } + thread._values[0] = q; + return q; + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + if (first.zerop()) { + LispObject q = first; + LispObject r; + if (first instanceof DoubleFloat) + r = DoubleFloat.ZERO; + else + r = SingleFloat.ZERO; + return thread.setValues(q, r); + } + if (first instanceof DoubleFloat) { + double d1 = ((DoubleFloat)first).value; + if (Double.isInfinite(d1) || Double.isNaN(d1)) + return thread.setValues(first, new DoubleFloat(Double.NaN)); + } else if (first instanceof SingleFloat) { + float f1 = ((SingleFloat)first).value; + if (Float.isInfinite(f1) || Float.isNaN(f1)) + return thread.setValues(first, new SingleFloat(Float.NaN)); + } + LispObject q = first.truncate(second); // an integer + if (first instanceof DoubleFloat || second instanceof DoubleFloat) { + if (q.zerop()) { + if (first.minusp()) { + if (second.minusp()) + q = new DoubleFloat(0.0); + else + q = new DoubleFloat(-0.0); + } else if (second.minusp()) + q = new DoubleFloat(-0.0); + else + q = new DoubleFloat(0.0); + } else if (q instanceof Fixnum) + q = new DoubleFloat(((Fixnum)q).value); + else + q = new DoubleFloat(((Bignum)q).doubleValue()); + } else { + if (q.zerop()) { + if (first.minusp()) { + if (second.minusp()) + q = new SingleFloat(0.0f); + else + q = new SingleFloat(-0.0f); + } else if (second.minusp()) + q = new SingleFloat(-0.0f); + else + q = new SingleFloat(0.0f); + } else if (q instanceof Fixnum) + q = new SingleFloat(((Fixnum)q).value); + else + q = new SingleFloat(((Bignum)q).floatValue()); + } + thread._values[0] = q; + return q; + } + + private static final Primitive FTRUNCATE = new ftruncate(); +} Added: branches/save-image/src/org/armedbear/lisp/function_info.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/function_info.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,129 @@ +/* + * function_info.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: function_info.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class function_info extends Lisp +{ + private static EqualHashTable FUNCTION_TABLE = + new EqualHashTable(64, NIL, NIL); + + // ### function-info name + private static final Primitive FUNCTION_INFO = + new Primitive("function-info", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + LispObject info = FUNCTION_TABLE.get(arg); + return info != null ? info : NIL; + } + }; + + // ### %set-function-info name info + private static final Primitive _SET_FUNCTION_INFO = + new Primitive("%set-function-info", PACKAGE_SYS, false) + { + @Override + public LispObject execute(LispObject name, LispObject info) + throws ConditionThrowable + { + if (info == NIL) + FUNCTION_TABLE.remhash(name); + else + FUNCTION_TABLE.put(name, info); + return info; + } + }; + + // ### get-function-info-value name indicator => value + private static final Primitive GET_FUNCTION_INFO_VALUE = + new Primitive("get-function-info-value", PACKAGE_SYS, true, + "name indicator") + { + @Override + public LispObject execute(LispObject name, LispObject indicator) + throws ConditionThrowable + { + // info is an alist + LispObject info = FUNCTION_TABLE.get(name); + if (info != null) { + while (info != NIL) { + LispObject cons = info.car(); + if (cons instanceof Cons) { + if (cons.car().eql(indicator)) { + // Found it. + return LispThread.currentThread().setValues(cons.cdr(), T); + } + } else if (cons != NIL) + error(new TypeError(cons, Symbol.LIST)); + info = info.cdr(); + } + } + return LispThread.currentThread().setValues(NIL, NIL); + } + }; + + // ### set-function-info-value name indicator value => value + private static final Primitive SET_FUNCTION_INFO_VALUE = + new Primitive("set-function-info-value", PACKAGE_SYS, true, + "name indicator value") + { + @Override + public LispObject execute(LispObject name, LispObject indicator, + LispObject value) + throws ConditionThrowable + { + // info is an alist + LispObject info = FUNCTION_TABLE.get(name); + if (info == null) + info = NIL; + LispObject alist = info; + while (alist != NIL) { + LispObject cons = alist.car(); + if (cons instanceof Cons) { + if (cons.car().eql(indicator)) { + // Found it. + cons.setCdr(value); + return value; + } + } else if (cons != NIL) + error(new TypeError(cons, Symbol.LIST)); + alist = alist.cdr(); + } + // Not found. + FUNCTION_TABLE.put(name, info.push(new Cons(indicator, value))); + return value; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/gc.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/gc.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,70 @@ +/* + * gc.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: gc.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### gc +public final class gc extends Primitive +{ + private gc() + { + super("gc", PACKAGE_EXT); + } + + @Override + public LispObject execute() + { + Runtime runtime = Runtime.getRuntime(); + long free = 0; + long maxFree = 0; + while (true) { + try { + runtime.gc(); + Thread.sleep(100); + runtime.runFinalization(); + Thread.sleep(100); + runtime.gc(); + Thread.sleep(100); + } + catch (InterruptedException e) {} + free = runtime.freeMemory(); + if (free > maxFree) + maxFree = free; + else + break; + } + return number(free); + } + + private static final Primitive GC = new gc(); +} Added: branches/save-image/src/org/armedbear/lisp/gentemp.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/gentemp.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,45 @@ +;;; gentemp.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: gentemp.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package #:system) + +(defvar *gentemp-counter* 0) + +(defun gentemp (&optional (prefix "T") (package *package*)) + (require-type prefix 'string) + (require-type package '(or package string symbol character)) + (loop + (let ((name (format nil "~A~D" prefix (incf *gentemp-counter*)))) + (multiple-value-bind (symbol exists-p) (find-symbol name package) + (unless exists-p + (return (values (intern name package)))))))) Added: branches/save-image/src/org/armedbear/lisp/get_properties.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/get_properties.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,73 @@ +/* + * get_properties.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: get_properties.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### get-properties +public final class get_properties extends Primitive +{ + private get_properties() + { + super(Symbol.GET_PROPERTIES, "plist indicator-list"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final LispThread thread = LispThread.currentThread(); + LispObject plist = first; + while (plist != NIL) + { + if (plist.cdr() instanceof Cons) + { + LispObject indicator = ((Cons)plist).car; + LispObject indicators = second; + while (indicators instanceof Cons) + { + if (indicator == ((Cons)indicators).car) + return thread.setValues(indicator, plist.cadr(), plist); + indicators = ((Cons)indicators).cdr; + } + if (indicators != NIL) + return type_error(indicators, Symbol.LIST); + plist = plist.cddr(); + } + else + return type_error(plist.cdr(), Symbol.CONS); + } + return thread.setValues(NIL, NIL, NIL); + } + + private static final Primitive GET_PROPERTIES = new get_properties(); +} Added: branches/save-image/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/gray-streams.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,701 @@ +;;; gray-streams.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon +;;; $Id: gray-streams.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from: +;;;; Gray Streams Implementation for Corman Lisp - Version 1.3 +;;;; +;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved. +;;;; +;;;; License +;;;; ======= +;;;; This software is provided 'as-is', without any express or implied +;;;; warranty. In no event will the author be held liable for any damages +;;;; arising from the use of this software. +;;;; +;;;; Permission is granted to anyone to use this software for any purpose, +;;;; including commercial applications, and to alter it and redistribute +;;;; it freely, subject to the following restrictions: +;;;; +;;;; 1. The origin of this software must not be misrepresented; you must +;;;; not claim that you wrote the original software. If you use this +;;;; software in a product, an acknowledgment in the product documentation +;;;; would be appreciated but is not required. +;;;; +;;;; 2. Altered source versions must be plainly marked as such, and must +;;;; not be misrepresented as being the original software. +;;;; +;;;; 3. This notice may not be removed or altered from any source +;;;; distribution. +;;;; +;;;; Notes +;;;; ===== +;;;; A simple implementation of Gray streams for Corman Lisp 1.42. +;;;; Gray streams are 'clos' based streams as described at: +;;;; +;;;; ftp://parcftp.xerox.com/pub/cl/cleanup/mail/stream-definition-by-user.mail +;;;; +;;;; Some differences exist between this implementation and the +;;;; specification above. See notes below for details. +;;;; +;;;; More recent versions of this software may be available at: +;;;; http://www.double.co.nz/cl +;;;; +;;;; Comments, suggestions and bug reports to the author, +;;;; Christopher Double, at: chris at double.co.nz +;;;; +;;;; 03/03/2001 - 1.0 +;;;; Initial release. +;;;; +;;;; 20/08/2001 - 1.1 +;;;; Small modifications by Frederic Bastenaire (fba at free.fr) +;;;; (lines flagged by ;; # fb 1.01) +;;;; - Make it work with the READ function by +;;;; defining %read-char, %read-char-with-error +;;;; and input-character-stream-p +;;;; - Add nickname GS to package "GRAY-STREAMS" for ease of use +;;;; - added missing '*' to *old-write-byte* in gray-write-byte +;;;; +;;;; 03/01/2002 - 1.2 +;;;; Fixed bug with GRAY-WRITE-LINE and GRAY-WRITE-STRING +;;;; that appeared in Corman Lisp 2.0 due to changes to +;;;; WRITE-LINE and WRITE-STRING. +;;;; +;;;; 04/01/2002 - 1.3 +;;;; Added support for STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE. +;;;; Fixed STREAM-WRITE-STRING bug. +;;;; +;;;; Notes +;;;; ===== +;;;; CLOSE is not a generic function in this implementation. Instead, +;;;; the generic is called STREAM-CLOSE and the function CLOSE calls +;;;; STREAM-CLOSE. The same goes for STREAMP, INPUT-STREAM-P, +;;;; OUTPUT-STREAM-P and STREAM-ELEMENT-TYPE. The generic functions for +;;;; these are STREAM-STREAMP, STREAM-INPUT-STREAM-P, +;;;; STREAM-OUTPUT-STREAM-P and STREAM-STREAM-ELEMENT-TYPE. +;;;; +;;;; The standard Corman Lisp streams are not derived from +;;;; FUNDAMENTAL-STREAM. All the stream functions check to see if the +;;;; stream is an original Corman Lisp stream and forward on to the +;;;; original function implementations. +;;;; +;;;; The string streams are implemented in this file as Gray streams +;;;; but do not replace the Corman Lisp string streams. They are only +;;;; implemented here to test the Gray stream functionality. These methods +;;;; are called: +;;;; GRAY-MAKE-STRING-OUTPUT-STREAM +;;;; GRAY-GET-OUTPUT-STREAM-STRING +;;;; GRAY-MAKE-STRING-INPUT-STREAM +;;;; +;;;; Much of the implementation of the Gray streams below is from the +;;;; document referenced earlier. +;;;; +(defpackage "GRAY-STREAMS" + (:use + "COMMON-LISP") + (:nicknames "GS") ;; # fb 1.01 + (:export + "FUNDAMENTAL-STREAM" + "STREAM-CLOSE" + "STREAM-OPEN-STREAM-P" + "STREAM-STREAMP" + "STREAM-INPUT-STREAM-P" + "STREAM-OUTPUT-STREAM-P" + "STREAM-STREAM-ELEMENT-TYPE" + "STREAM-CLOSE" + "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-BINARY-STREAM" + "STREAM-READ-BYTE" + "STREAM-WRITE-BYTE" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "STREAM-READ-CHAR" + "STREAM-UNREAD-CHAR" + "STREAM-READ-CHAR-NO-HANG" + "STREAM-PEEK-CHAR" + "STREAM-LISTEN" + "STREAM-READ-LINE" + "STREAM-CLEAR-INPUT" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "STREAM-WRITE-CHAR" + "STREAM-LINE-COLUMN" + "STREAM-START-LINE-P" + "STREAM-WRITE-STRING" + "STREAM-TERPRI" + "STREAM-FRESH-LINE" + "STREAM-FINISH-OUTPUT" + "STREAM-FORCE-OUTPUT" + "STREAM-CLEAR-OUTPUT" + "STREAM-ADVANCE-TO-COLUMN" + "STREAM-READ-SEQUENCE" + "STREAM-WRITE-SEQUENCE" + "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM")) + +(in-package :gray-streams) + +(defvar *old-read-char* #'read-char) +(defvar *old-peek-char* #'peek-char) +(defvar *old-unread-char* #'unread-char) +(defvar *old-listen* nil) +(defvar *old-read-line* #'read-line) +(defvar *old-read-char-no-hang* #'read-char-no-hang) +(defvar *old-write-char* #'write-char) +(defvar *old-fresh-line* #'fresh-line) +(defvar *old-terpri* #'terpri) +(defvar *old-write-string* #'write-string) +(defvar *old-write-line* #'write-line) +(defvar *old-force-output* #'sys::%force-output) +(defvar *old-finish-output* #'sys::%finish-output) +(defvar *old-clear-output* #'sys::%clear-output) +(defvar *old-clear-input* #'clear-input) +(defvar *old-read-byte* #'read-byte) +(defvar *old-write-byte* #'write-byte) +(defvar *old-stream-element-type* #'cl::stream-element-type) +(defvar *old-close* #'cl::close) +(defvar *old-input-character-stream-p* + #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character)))) +(defvar *old-input-stream-p* #'cl::input-stream-p) +(defvar *old-output-stream-p* #'cl::output-stream-p) +(defvar *old-open-stream-p* #'cl::open-stream-p) +(defvar *old-streamp* #'cl::streamp) +(defvar *old-read-sequence* #'cl::read-sequence) +(defvar *old-write-sequence* #'cl::write-sequence) +(defvar *old-make-two-way-stream* #'cl:make-two-way-stream) +(defvar *old-two-way-stream-input-stream* #'cl:two-way-stream-input-stream) +(defvar *old-two-way-stream-output-stream* #'cl:two-way-stream-output-stream) + + +(defun old-streamp (stream) + (funcall *old-streamp* stream)) + +(defclass fundamental-stream ()) + +(defgeneric stream-close (stream &key abort)) +(defgeneric stream-open-stream-p (stream)) +(defgeneric stream-streamp (stream)) +(defgeneric stream-input-stream-p (stream)) +(defgeneric stream-input-character-stream-p (stream)) ;; # fb 1.01 +(defgeneric stream-output-stream-p (stream)) +(defgeneric stream-stream-element-type (stream)) + +(defmethod stream-close (stream &key abort) + (declare (ignore stream abort)) + nil) + +(defmethod stream-streamp (s) + (declare (ignore s)) + nil) + +(defmethod stream-streamp ((s fundamental-stream)) + s) + +(defclass fundamental-input-stream (fundamental-stream)) + +(defmethod stream-input-character-stream-p (s) ;; # fb 1.01 + (and (stream-input-stream-p s) + (eq (stream-stream-element-type s) 'character))) + +(defmethod stream-input-stream-p (s) + (declare (ignore s)) + nil) + +(defmethod stream-input-stream-p ((s fundamental-input-stream)) + (declare (ignore s)) + t) + +(defclass fundamental-output-stream (fundamental-stream)) + +(defmethod stream-output-stream-p (s) + (declare (ignore s)) + nil) + +(defmethod stream-output-stream-p ((s fundamental-output-stream)) + (declare (ignore s)) + t) + +(defclass fundamental-character-stream (fundamental-stream)) + +(defmethod stream-stream-element-type ((s fundamental-character-stream)) + (declare (ignore s)) + 'character) + +(defclass fundamental-binary-stream (fundamental-stream)) + +(defgeneric stream-read-byte (stream)) +(defgeneric stream-write-byte (stream integer)) + +(defclass fundamental-character-input-stream + (fundamental-input-stream fundamental-character-stream)) + +(defgeneric stream-read-char (stream)) +(defgeneric stream-unread-char (stream character)) +(defgeneric stream-read-char-no-hang (stream)) +(defgeneric stream-peek-char (stream)) +(defgeneric stream-listen (stream)) +(defgeneric stream-read-line (stream)) +(defgeneric stream-clear-input (stream)) + +(defmethod stream-peek-char ((stream fundamental-character-input-stream)) + (let ((character (stream-read-char stream))) + (unless (eq character :eof) + (stream-unread-char stream character)) + character)) + +(defmethod stream-listen ((stream fundamental-character-input-stream)) + (let ((char (stream-read-char-no-hang stream))) + (and (not (null char)) + (not (eq char :eof)) + (progn + (stream-unread-char stream char) + t)))) + +(defmethod stream-read-line ((stream fundamental-character-input-stream)) + (let ((line (make-array 64 + :element-type 'character + :fill-pointer 0 + :adjustable t))) + (loop + (let ((character (stream-read-char stream))) + (if (eq character :eof) + (return (values line t)) + (if (eql character #\Newline) + (return (values line nil)) + (vector-push-extend character line))))))) + +(defclass fundamental-character-output-stream + (fundamental-output-stream fundamental-character-stream)) + +(defgeneric stream-write-char (stream character)) +(defgeneric stream-line-column (stream)) +(defgeneric stream-start-line-p (stream)) +(defgeneric stream-write-string (stream string &optional start end)) +(defgeneric stream-terpri (stream)) +(defgeneric stream-fresh-line (stream)) +(defgeneric stream-finish-output (stream)) +(defgeneric stream-force-output (stream)) +(defgeneric stream-clear-output (stream)) +(defgeneric stream-advance-to-column (stream column)) +(defgeneric stream-read-sequence (stream sequence start end)) +(defgeneric stream-write-sequence (stream sequence start end)) + +(defmethod stream-force-output (stream) + (declare (ignore stream)) + nil) + +(defmethod stream-start-line-p ((stream fundamental-character-output-stream)) + (equal (stream-line-column stream) 0)) + +(defmethod stream-write-string ((stream fundamental-character-output-stream) + string + &optional + (start 0) + (end (length string))) + (let ((start (or start 0)) + (end (or end (length string)))) + (do ((i start (1+ i))) + ((>= i end) string) + (stream-write-char stream (char string i))))) + +(defmethod stream-fresh-line ((stream fundamental-character-output-stream)) + (if (stream-start-line-p stream) + nil + (progn + (stream-terpri stream) + t))) + +(defmethod stream-advance-to-column ((stream fundamental-character-output-stream) + column) + (let ((current (stream-line-column stream))) + (unless (null current) + (dotimes (i (- current column) t) + (stream-write-char stream #\Space))))) + +(defmethod stream-read-sequence ((stream fundamental-character-input-stream) sequence start end) + (if (null end) + (setf end (length sequence))) + (let ((element-type (stream-element-type stream)) + (eof (cons nil nil))) + (cond + ((eq element-type 'character) + (dotimes (count (- end start) (- end start)) + (let ((c (stream-read-char stream nil eof))) + (if (eq c eof) + (return (+ count start))) + (setf (elt sequence (+ count start)) c)))) + ((or (eq element-type 'byte) + (eq element-type 'unsigned-byte) + (eq element-type 'signed-byte)) + (dotimes (count (- end start) (- end start)) + (let ((b (stream-read-byte stream nil eof))) + (if (eq b eof) + (return (+ count start))) + (setf (elt sequence (+ count start)) b)))) + (t (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A" element-type))))) + +(defmethod stream-write-sequence ((stream fundamental-character-output-stream) + sequence start end) + (let ((element-type (stream-element-type stream)) + (start (if start start 0)) + (end (if end end (length sequence)))) + (if (eq element-type 'character) + (do ((n start (+ n 1))) + ((= n end)) + (stream-write-char + stream + (if (typep (elt sequence n) 'number) + (#+nil ccl:int-char code-char (elt sequence n)) + (elt sequence n)))) + (do ((n start (+ n 1))) + ((= n end)) + (stream-write-byte (elt sequence n) stream)))) ;; recoded to avoid LOOP, because it isn't loaded yet + (stream-force-output stream)) + +(defclass fundamental-binary-input-stream + (fundamental-input-stream fundamental-binary-stream)) + +(defclass fundamental-binary-output-stream + (fundamental-output-stream fundamental-binary-stream)) + +(defun decode-read-arg (arg) + (cond ((null arg) *standard-input*) + ((eq arg t) *terminal-io*) + (t arg))) + +(defun decode-print-arg (arg) + (cond ((null arg) *standard-output*) + ((eq arg t) *terminal-io*) + (t arg))) + +(defun report-eof (stream eof-errorp eof-value) + (if eof-errorp + (error 'end-of-file :stream stream) + eof-value)) + +(defun check-for-eof (value stream eof-errorp eof-value) + (if (eq value :eof) + (report-eof stream eof-errorp eof-value) + value)) + +(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-read-char* stream eof-errorp eof-value recursive-p) + (check-for-eof (stream-read-char stream) stream eof-errorp eof-value)))) + +(defun gray-peek-char (&optional peek-type input-stream (eof-errorp t) + eof-value recursive-p) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-peek-char* peek-type stream eof-errorp eof-value recursive-p) + (if (null peek-type) + (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value) + (loop + (let ((value (stream-peek-char stream))) + (if (eq value :eof) + (return (report-eof stream eof-errorp eof-value)) + (if (if (eq peek-type t) + (not (member value + '(#\space #\tab #\newline #\return))) + (char= peek-type value)) + (return value) + (stream-read-char stream))))))))) + +(defun gray-unread-char (character &optional input-stream) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-unread-char* character stream) + (stream-unread-char stream character)))) + +(defun gray-listen (&optional input-stream) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-listen* stream) + (stream-listen stream)))) + +(defun gray-read-line (&optional input-stream (eof-error-p t) + eof-value recursive-p) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-read-line* stream eof-error-p eof-value recursive-p) + (multiple-value-bind (string eofp) + (stream-read-line stream) + (if eofp + (if (= (length string) 0) + (report-eof stream eof-error-p eof-value) + (values string t)) + (values string nil)))))) + +(defun gray-clear-input (&optional input-stream) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-clear-input* stream) + (stream-clear-input stream)))) + +(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t) + eof-value recursive-p) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + (funcall *old-read-char-no-hang* stream eof-errorp eof-value recursive-p) + (check-for-eof (stream-read-char-no-hang stream) + stream eof-errorp eof-value)))) + +(defun gray-write-char (character &optional output-stream) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-write-char* character stream) + (stream-write-char stream character)))) + +(defun gray-fresh-line (&optional output-stream) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-fresh-line* stream) + (stream-fresh-line stream)))) + +(defun gray-terpri (&optional output-stream) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-terpri* stream) + (stream-terpri stream)))) + +(defun gray-write-string (string &optional output-stream &key (start 0) end) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-write-string* string stream :start start :end end) + (stream-write-string stream string start end)))) + +(defun gray-write-line (string &optional output-stream &key (start 0) end) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-write-line* string stream :start start :end end) + (progn + (stream-write-string stream string start end) + (stream-terpri stream) + string)))) + +(defun gray-force-output (&optional output-stream) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-force-output* stream) + (stream-force-output stream)))) + +(defun gray-finish-output (&optional output-stream) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-finish-output* stream) + (stream-finish-output stream)))) + +(defun gray-clear-output (&optional output-stream) + (let ((stream (decode-print-arg output-stream))) + (if (old-streamp stream) + (funcall *old-clear-output* stream) + (stream-clear-output stream)))) + +(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value) + (if (old-streamp binary-input-stream) + (funcall *old-read-byte* binary-input-stream eof-errorp eof-value) + (check-for-eof (stream-read-byte binary-input-stream) + binary-input-stream eof-errorp eof-value))) + +(defun gray-write-byte (integer binary-output-stream) + (if (old-streamp binary-output-stream) + (funcall *old-write-byte* integer binary-output-stream) + (stream-write-byte binary-output-stream integer))) + +(defclass string-input-stream (fundamental-character-input-stream) + ((string :initarg :string :type string) + (index :initarg :start :type fixnum) + (end :initarg :end :type fixnum))) + +(defun gray-make-string-input-stream (string &optional (start 0) end) + (make-instance 'string-input-stream :string string + :start start :end (or end (length string)))) + +(defmethod stream-read-char ((stream string-input-stream)) + (with-slots (index end string) stream + (if (>= index end) + :eof + (prog1 + (char string index) + (incf index))))) + +(defmethod stream-unread-char ((stream string-input-stream) character) + (with-slots (index end string) stream + (decf index) + (assert (eql (char string index) character)) + nil)) + +(defmethod stream-read-line ((stream string-input-stream)) + (with-slots (index end string) stream + (let* ((endline (position #\newline string :start index :end end)) + (line (subseq string index endline))) + (if endline + (progn + (setq index (1+ endline)) + (values line nil)) + (progn + (setq index end) + (values line t)))))) + +(defclass string-output-stream (fundamental-character-output-stream) + ((string :initform nil :initarg :string))) + +(defun gray-make-string-output-stream () + (make-instance 'string-output-stream)) + +(defun gray-get-output-stream-string (stream) + (with-slots (string) stream + (if (null string) + "" + (prog1 + (coerce string 'string) + (setq string nil))))) + +(defmethod stream-write-char ((stream string-output-stream) character) + (with-slots (string) stream + (when (null string) + (setq string (make-array 64 :slement-type 'character + :fill-pointer 0 :adjustable t))) + (vector-push-extend character string) + character)) + +(defmethod stream-line-column ((stream string-output-stream)) + (with-slots (string) stream + (if (null string) + 0 + (let ((nx (position #\newline string :from-end t))) + (if (null nx) + (length string) + (- (length string) nx 1)))))) + +(defmethod stream-line-column ((stream stream)) + nil) + +(defun gray-stream-column (&optional input-stream) + (let ((stream (decode-read-arg input-stream))) + (if (old-streamp stream) + nil ;(funcall *old-stream-column* stream) + (stream-line-column stream)))) + +(defun gray-stream-element-type (stream) + (if (old-streamp stream) + (funcall *old-stream-element-type* stream) + (stream-stream-element-type stream))) + +(defun gray-close (stream &key abort) + (if (old-streamp stream) + (funcall *old-close* stream :abort abort) + (stream-close stream :abort nil))) + +(defun gray-input-stream-p (stream) + (if (old-streamp stream) + (funcall *old-input-stream-p* stream) + (stream-input-stream-p stream))) + +(defun gray-input-character-stream-p (stream) + (if (old-streamp stream) + (funcall *old-input-character-stream-p* stream) + (stream-input-character-stream-p stream))) + +(defun gray-output-stream-p (stream) + (if (old-streamp stream) + (funcall *old-output-stream-p* stream) + (stream-output-stream-p stream))) + +(defun gray-open-stream-p (stream) + (if (old-streamp stream) + (funcall *old-open-stream-p* stream) + (stream-open-stream-p stream))) + +(defun gray-streamp (stream) + (if (old-streamp stream) + (funcall *old-streamp* stream) + (stream-streamp stream))) + +(defun gray-write-sequence (sequence stream &key (start 0) end) + (if (old-streamp stream) + (funcall *old-write-sequence* sequence stream :start start :end end) + (stream-write-sequence stream sequence start end))) + +(defun gray-read-sequence (sequence stream &key (start 0) (end nil)) + (if (old-streamp stream) + (funcall *old-read-sequence* sequence stream :start start :end end) + (stream-read-sequence stream sequence start end))) + +(defstruct two-way-stream-g + input-stream output-stream) + +(defun gray-make-two-way-stream (in out) + (if (and (old-streamp in) (old-streamp out)) + (funcall *old-make-two-way-stream* in out) + (make-two-way-stream-g :input-stream in :output-stream out))) + +(defun gray-two-way-stream-input-stream (stream) + (if (old-streamp stream) + (funcall *old-two-way-stream-input-stream* stream) + (two-way-stream-g-input-stream stream))) + +(defun gray-two-way-stream-output-stream (stream) + (if (old-streamp stream) + (funcall *old-two-way-stream-output-stream* stream) + (two-way-stream-g-output-stream stream))) + +(setf (symbol-function 'common-lisp::read-char) #'gray-read-char) +(setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char) +(setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char) +(setf (symbol-function 'common-lisp::read-line) #'gray-read-line) +(setf (symbol-function 'common-lisp::clear-input) #'gray-clear-input) +(setf (symbol-function 'common-lisp::read-char-no-hang) #'gray-read-char-no-hang) +(setf (symbol-function 'common-lisp::write-char) #'gray-write-char) +(setf (symbol-function 'common-lisp::fresh-line) #'gray-fresh-line) +(setf (symbol-function 'common-lisp::terpri) #'gray-terpri) +(setf (symbol-function 'common-lisp::write-string) #'gray-write-string) +(setf (symbol-function 'common-lisp::write-line) #'gray-write-line) +(setf (symbol-function 'sys::%force-output) #'gray-force-output) +(setf (symbol-function 'sys::%finish-output) #'gray-finish-output) +(setf (symbol-function 'sys::%clear-output) #'gray-clear-output) +(setf (symbol-function 'common-lisp::read-byte) #'gray-read-byte) +(setf (symbol-function 'common-lisp::write-byte) #'gray-write-byte) +(setf (symbol-function 'common-lisp::stream-column) #'gray-stream-column) +(setf (symbol-function 'common-lisp::stream-element-type) #'gray-stream-element-type) +(setf (symbol-function 'common-lisp::close) #'gray-close) +(setf (symbol-function 'common-lisp::input-stream-p) #'gray-input-stream-p) +(setf (symbol-function 'common-lisp::input-character-stream-p) #'gray-input-character-stream-p) ;; # fb 1.01 +(setf (symbol-function 'common-lisp::output-stream-p) #'gray-output-stream-p) +(setf (symbol-function 'common-lisp::open-stream-p) #'gray-open-stream-p) +(setf (symbol-function 'common-lisp::streamp) #'gray-streamp) +(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence) +(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence) +(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream) +(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream) +(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream) + +(provide 'gray-streams) Added: branches/save-image/src/org/armedbear/lisp/inline.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/inline.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,40 @@ +;;; precompiler.lisp +;;; +;;; Copyright (C) 2006 Peter Graves +;;; $Id: inline.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package :system) + +(defun inline-expansion (name) + (get-function-info-value name :inline-expansion)) + +(defun set-inline-expansion (name expansion) + (set-function-info-value name :inline-expansion expansion)) + +(defsetf inline-expansion set-inline-expansion) Added: branches/save-image/src/org/armedbear/lisp/input_stream_p.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/input_stream_p.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * input_stream_p.java + * + * Copyright (C) 2004 Peter Graves + * $Id: input_stream_p.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### input-stream-p +public final class input_stream_p extends Primitive +{ + private input_stream_p() + { + super("input-stream-p"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((Stream)arg).isInputStream() ? T : NIL; + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.STREAM)); + } + } + + private static final Primitive INPUT_STREAM_P = new input_stream_p(); +} Added: branches/save-image/src/org/armedbear/lisp/inspect.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/inspect.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,202 @@ +;;; inspect.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: inspect.lisp 11565 2009-01-18 19:39:47Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(require 'clos) + +(require 'format) + +(defun leader (name) + (let ((size (max 0 (- 16 (length (string name)))))) + (concatenate 'string (make-string size :initial-element #\-) "->"))) + +(defun safe-length (x) + (do ((n 0 (+ n 2)) + (fast x (cddr fast)) + (slow x (cdr slow))) + (()) + (when (null fast) + (return (values n :proper))) + (when (atom fast) + (return (values n :dotted))) + (when (null (cdr fast)) + (return (values (+ n 1) :proper))) + (when (atom (cdr fast)) + (return (values (+ n 1) :dotted))) + (when (and (eq fast slow) (> n 0)) + (return (values nil :circular))))) + +(defun display-object (obj) + (let ((*print-length* 2) + (*print-level* 2)) + (cond ((typep obj 'standard-object) + (let ((parts (inspected-parts obj)) + (i 0)) + (dolist (part parts) + (let ((name (car part)) + (value (cdr part))) + (format t "~4D ~A ~A ~S~%" + i + name + (leader name) + value) + (incf i))))) + ((simple-vector-p obj) + (format t "~A at #x~X~%" (inspected-description obj) (identity-hash-code obj)) + (let ((limit (min (length obj) 25))) + (dotimes (i limit) + (format t "~4D-> ~A~%" i (aref obj i))))) + ((vectorp obj) + (format t "~A~%" (inspected-description obj)) + (let ((limit (min (length obj) 25))) + (dotimes (i limit) + (format t "~4D-> ~A~%" i (aref obj i))))) + ((consp obj) + (multiple-value-bind (len kind) (safe-length obj) + (case kind + (:proper + (format t "A proper list with ~D elements at #x~X~%" + len + (identity-hash-code obj)) + (let ((i 0)) + (dolist (item obj) + (cond ((< i 25) + (format t "~4D-> ~S~%" i item)) + ((= i 25) + (format t " ...~%")) + ((= i (1- len)) + (format t "~4D-> ~S~%" i item))) + (incf i)))) + (:dotted + (format t "A dotted list with ~D elements at #x~X~%" + len + (identity-hash-code obj)) + (let* ((rest obj) + (item (car rest)) + (i 0)) + (loop + (cond ((< i 25) + (format t "~4D-> ~S~%" i item)) + ((= i 25) + (format t " ...~%"))) + (incf i) + (setf rest (cdr rest)) + (when (atom rest) + (return)) + (setf item (car rest))) + (format t "tail-> ~S~%" rest))) + (:circular + (format t "A circular list at #x~X~%" (identity-hash-code obj)))))) + (t + (format t "~A~%" (inspected-description obj)) + (let ((parts (inspected-parts obj)) + (i 0) + (limit 25)) + (dolist (part parts) + (let ((name (string (car part))) + (value (cdr part))) + (format t "~4D ~A ~A ~S~%" i + name + (leader name) + value) + (incf i) + (when (> i limit) + (return)))))))) + (values)) + +(defun display-current () + (if *inspect-break* + (display-object *inspected-object*) + (format t "No object is being inspected."))) + +(defun inspect (obj) + (when ext:*inspector-hook* + (funcall ext:*inspector-hook* obj)) + (when *inspected-object* + (push *inspected-object* *inspected-object-stack*)) + (setf *inspected-object* obj) + (let* ((*inspect-break* t) + (*debug-level* (1+ *debug-level*))) + (setf *** ** + ** * + * obj) + (display-current) + (catch 'inspect-exit + (tpl::repl))) + (setf *** ** + ** * + * obj) + (values)) + +(defun istep (args) + (if (null args) + (display-current) + (let* ((pos (position #\space args)) + (option-string (if pos (subseq args 0 pos) args)) + (option (read-from-string option-string))) + (cond ((string= option-string "-") + (if *inspected-object-stack* + (progn + (setf *inspected-object* (pop *inspected-object-stack*)) + (setf *** ** + ** * + * *inspected-object*) + (display-current)) + (format t "Object has no parent."))) + ((string= option-string "q") + (setf *inspected-object* nil + *inspected-object-stack* nil + *inspect-break* nil) + (throw 'inspect-exit nil)) + ((fixnump option) + (let* ((index option) + (parts (inspected-parts *inspected-object*))) + (cond ((null parts) + (if (typep *inspected-object* 'sequence) + (if (or (minusp index) + (>= index (length *inspected-object*))) + (format t "Invalid index (~D)." index) + (progn + (push *inspected-object* *inspected-object-stack*) + (setf *inspected-object* + (elt *inspected-object* index)) + (setf * *inspected-object*) + (display-current))) + (format t "Object has no selectable components."))) + ((or (minusp index) + (>= index (length parts))) + (format t "Invalid index (~D)." index)) + (t + (push *inspected-object* *inspected-object-stack*) + (setf *inspected-object* (cdr (elt parts index))) + (setf * *inspected-object*) + (display-current))))))))) Added: branches/save-image/src/org/armedbear/lisp/interactive_stream_p.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/interactive_stream_p.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,53 @@ +/* + * interactive_stream_p.java + * + * Copyright (C) 2004 Peter Graves + * $Id: interactive_stream_p.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### interactive-stream-p +public final class interactive_stream_p extends Primitive +{ + private interactive_stream_p() + { + super("interactive-stream-p", "stream"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Stream) + return ((Stream)arg).isInteractive() ? T : NIL; + return error(new TypeError(arg, Symbol.STREAM)); + } + + private static final Primitive INTERACTIVE_STREAM_P = new interactive_stream_p(); +} Added: branches/save-image/src/org/armedbear/lisp/j.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/j.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,256 @@ +;;; j.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: j.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:j) + +(export '(*current-command* + *last-command* + add-hook + after-save-hook + backward-char + backward-sexp + backward-up-list + beginning-of-line + buffer-activated-hook + buffer-live-p + buffer-modified-p + buffer-name + buffer-offset + buffer-pathname + buffer-stream-buffer + buffer-string + buffer-substring + char-after + char-before + copy-mark + current-buffer + current-editor + current-line + current-mark + current-point + defcommand + defun-at-point + delete-region + editor-buffer + emacs-mode + end-of-line + execute-command + find-beginning-of-defun + find-file-buffer + forward-char + forward-sexp + get-buffer + get-buffer-property + get-global-property + get-last-event-internal-time + global-map-key + global-unmap-key + goto-char + insert + invoke-hook + invoke-later + key-pressed-hook + kill-theme + line-chars + line-flags + line-next + line-number + line-previous + lisp-shell-startup-hook + location-bar-cancel-input + log-debug + looking-at + make-buffer-stream + make-mark + map-key-for-mode + mark-charpos + mark-line + mark= + move-to-position + open-file-hook + other-editor + point-max + point-min + pop-to-buffer + re-search-backward + re-search-forward + reset-display + restore-focus + save-excursion + search-backward + search-forward + set-buffer-modified-p + set-buffer-property + set-global-property + set-mark + set-mode-property + status + switch-to-buffer + undo + unmap-key-for-mode + update-display + update-location-bar + with-editor + with-other-editor + with-single-undo)) + +(declaim (special *current-command* *last-command*)) + +(autoload 'emacs-mode "emacs") + +(defun reset-display () + (jstatic "resetDisplay" "org.armedbear.j.Editor")) + +(defun log-debug (control-string &rest args) + (%log-debug (apply 'format nil control-string args))) + +(defun update-display (&optional ed) + (let ((method (jmethod "org.armedbear.j.Editor" "updateDisplay")) + (ed (or ed (current-editor)))) + (jcall method ed))) + +(defun update-location-bar (&optional ed) + (let ((method (jmethod "org.armedbear.j.Editor" "updateLocation")) + (ed (or ed (current-editor)))) + (jcall method ed))) + +(defun location-bar-cancel-input () + (jstatic "cancelInput" "org.armedbear.j.LocationBar")) + +;; Internal. +(defun %execute-command (command &optional ed) + (let ((method (jmethod "org.armedbear.j.Editor" + "executeCommand" "java.lang.String")) + (ed (or ed (current-editor)))) + (jcall method ed command) + (update-display ed))) + +(defmacro defcommand (name &optional (command nil)) + (unless command + (setf command (remove #\- (string `,name)))) + `(setf (symbol-function ',name) + (lambda (&optional arg) + (%execute-command (if arg + (concatenate 'string ,command " " arg) + ,command))))) + +(defcommand execute-command) + +;;; HOOKS +(defun add-hook (hook function) + (when (symbolp hook) + (unless (boundp hook) (set hook nil)) + (let ((hook-functions (symbol-value hook))) + (unless (memq function hook-functions) + (push function hook-functions) + (set hook hook-functions))))) + +(defun invoke-hook (hook &rest args) + (when (and (symbolp hook) (boundp hook)) + (let ((hooks (symbol-value hook))) + (when hooks + (dolist (function hooks) + (apply function args)) + t)))) + +(defvar open-file-hook nil) + +(defvar buffer-activated-hook nil) + +(defvar after-save-hook nil) + +(defvar key-pressed-hook nil) + +(defvar lisp-shell-startup-hook nil) + +(defsetf current-editor %set-current-editor) + +(defsetf buffer-mark %set-buffer-mark) + +(defsetf editor-mark %set-editor-mark) + +(defsetf line-flags %set-line-flags) + +(defmacro with-editor (editor &rest forms) + (let ((old-editor (gensym))) + `(let ((,old-editor (current-editor))) + (unwind-protect + (progn + (setf (current-editor) ,editor) + , at forms) + (update-display ,editor) + (setf (current-editor) ,old-editor))))) + +(defmacro with-other-editor (&rest forms) + (let ((old-editor (gensym)) + (other-editor (gensym))) + `(let ((,old-editor (current-editor)) + (,other-editor (other-editor))) + (unless ,other-editor + (error "there is no other editor")) + (unwind-protect + (progn + (setf (current-editor) ,other-editor) + , at forms) + (update-display ,other-editor) + (setf (current-editor) ,old-editor))))) + +(defmacro with-single-undo (&rest forms) + (let ((info (gensym))) + `(let ((,info (begin-compound-edit))) + (unwind-protect + (progn , at forms) + (end-compound-edit ,info))))) + +(defmacro save-excursion (&rest forms) + (let ((old-point (gensym))) + `(let ((,old-point (current-point))) + (unwind-protect + (progn , at forms) + (goto-char ,old-point))))) + +(defun search-forward (pattern &key buffer start ignore-case whole-words-only) + (%search pattern :forward nil buffer start ignore-case whole-words-only)) + +(defun search-backward (pattern &key buffer start ignore-case whole-words-only) + (%search pattern :backward nil buffer start ignore-case whole-words-only)) + +(defun re-search-forward (pattern &key buffer start ignore-case whole-words-only) + (%search pattern :forward t buffer start ignore-case whole-words-only)) + +(defun re-search-backward (pattern &key buffer start ignore-case whole-words-only) + (%search pattern :backward t buffer start ignore-case whole-words-only)) + +(in-package "COMMON-LISP-USER") + +(use-package '#:j) + +(provide '#:j) Added: branches/save-image/src/org/armedbear/lisp/java.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,299 @@ +;;; java.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves, Andras Simon +;;; $Id: java.lisp 11590 2009-01-25 23:34:24Z astalla $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "JAVA") + +(require "CLOS") + +(defun jregister-handler (object event handler &key data count) + (%jregister-handler object event handler data count)) + +(defun jinterface-implementation (interface &rest method-names-and-defs) + "Creates and returns an implementation of a Java interface with + methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS. + + INTERFACE is either a Java interface or a string naming one. + + METHOD-NAMES-AND-DEFS is an alternating list of method names + (strings) and method definitions (closures). + + For missing methods, a dummy implementation is provided that + returns nothing or null depending on whether the return type is + void or not. This is for convenience only, and a warning is issued + for each undefined method." + (let ((interface (jclass interface)) + (implemented-methods + (loop for m in method-names-and-defs + for i from 0 + if (evenp i) + do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m + else + do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))) + (null (make-immediate-object nil :ref))) + (loop for method across + (jclass-methods interface :declared nil :public t) + for method-name = (jmethod-name method) + when (not (member method-name implemented-methods :test #'string=)) + do + (let* ((void-p (string= (jclass-name (jmethod-return-type method)) "void")) + (arglist (when (plusp (length (jmethod-params method))) '(&rest ignore))) + (def `(lambda + ,arglist + ,(when arglist '(declare (ignore ignore))) + ,(if void-p '(values) null)))) + (warn "Implementing dummy method ~a for interface ~a" + method-name (jclass-name interface)) + (push (coerce def 'function) method-names-and-defs) + (push method-name method-names-and-defs))) + (apply #'%jnew-proxy interface method-names-and-defs))) + +(defun jmake-invocation-handler (function) + (%jmake-invocation-handler function)) + +(when (autoloadp 'jmake-proxy) + (fmakunbound 'jmake-proxy)) + +(defgeneric jmake-proxy (interface implementation &optional lisp-this) + (:documentation "Returns a proxy Java object implementing the provided interface using methods implemented in Lisp - typically closures, but implementations are free to provide other mechanisms. You can pass an optional 'lisp-this' object that will be passed to the implementing methods as their first argument. If you don't provide this object, NIL will be used. The second argument of the Lisp methods is the name of the Java method being implemented. This has the implication that overloaded methods are merged, so you have to manually discriminate them if you want to. The remaining arguments are java-objects wrapping the method's parameters.")) + +(defmethod jmake-proxy (interface invocation-handler &optional lisp-this) + "Basic implementation that directly uses an invocation handler." + (%jmake-proxy (jclass interface) invocation-handler lisp-this)) + +(defmethod jmake-proxy (interface (implementation function) &optional lisp-this) + "Implements a Java interface forwarding method calls to a Lisp function." + (%jmake-proxy (jclass interface) (jmake-invocation-handler implementation) lisp-this)) + +(defmethod jmake-proxy (interface (implementation package) &optional lisp-this) + "Implements a Java interface mapping Java method names to symbols in a given package. javaMethodName is mapped to a JAVA-METHOD-NAME symbol. An error is signaled if no such symbol exists in the package, or if the symbol exists but does not name a function." + (flet ((java->lisp (name) + (with-output-to-string (str) + (let ((last-lower-p nil)) + (map nil (lambda (char) + (let ((upper-p (char= (char-upcase char) char))) + (when (and last-lower-p upper-p) + (princ "-" str)) + (setf last-lower-p (not upper-p)) + (princ (char-upcase char) str))) + name))))) + (%jmake-proxy (jclass interface) + (jmake-invocation-handler + (lambda (obj method &rest args) + (let ((sym (find-symbol + (java->lisp method) + implementation))) + (unless sym + (error "Symbol ~A, implementation of method ~A, not found in ~A" + (java->lisp method) + method + implementation)) + (if (fboundp sym) + (apply (symbol-function sym) obj method args) + (error "Function ~A, implementation of method ~A, not found in ~A" + sym method implementation))))) + lisp-this))) + +(defmethod jmake-proxy (interface (implementation hash-table) &optional lisp-this) + "Implements a Java interface using closures in an hash-table keyed by Java method name." + (%jmake-proxy (jclass interface) + (jmake-invocation-handler + (lambda (obj method &rest args) + (let ((fn (gethash method implementation))) + (if fn + (apply fn obj args) + (error "Implementation for method ~A not found in ~A" + method implementation))))) + lisp-this)) + +(defun jobject-class (obj) + "Returns the Java class that OBJ belongs to" + (jcall (jmethod "java.lang.Object" "getClass") obj)) + +(defun jclass-superclass (class) + "Returns the superclass of CLASS, or NIL if it hasn't got one" + (jcall (jmethod "java.lang.Class" "getSuperclass") (jclass class))) + +(defun jclass-interfaces (class) + "Returns the vector of interfaces of CLASS" + (jcall (jmethod "java.lang.Class" "getInterfaces") (jclass class))) + +(defun jclass-interface-p (class) + "Returns T if CLASS is an interface" + (jcall (jmethod "java.lang.Class" "isInterface") (jclass class))) + +(defun jclass-superclass-p (class-1 class-2) + "Returns T if CLASS-1 is a superclass or interface of CLASS-2" + (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class") + (jclass class-1) + (jclass class-2))) + +(defun jclass-array-p (class) + "Returns T if CLASS is an array class" + (jcall (jmethod "java.lang.Class" "isArray") (jclass class))) + +(defun jarray-component-type (atype) + "Returns the component type of the array type ATYPE" + (assert (jclass-array-p atype)) + (jcall (jmethod "java.lang.Class" "getComponentType") atype)) + +(defun jarray-length (java-array) + (jstatic "getLength" "java.lang.reflect.Array" java-array) ) + +(defun (setf jarray-ref) (new-value java-array &rest indices) + (apply #'jarray-set java-array new-value indices)) + +(defun jnew-array-from-array (element-type array) + "Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) + initialized from ARRAY" + (flet + ((row-major-to-index (dimensions n) + (loop for dims on dimensions + with indices + do + (multiple-value-bind (m r) (floor n (apply #'* (cdr dims))) + (push m indices) + (setq n r)) + finally (return (nreverse indices))))) + (let* ((fill-pointer (when (array-has-fill-pointer-p array) (fill-pointer array))) + (dimensions (if fill-pointer (list fill-pointer) (array-dimensions array))) + (jarray (apply #'jnew-array element-type dimensions))) + (dotimes (i (if fill-pointer fill-pointer (array-total-size array)) jarray) + #+maybe_one_day + (setf (apply #'jarray-ref jarray (row-major-to-index dimensions i)) (row-major-aref array i)) + (apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i)))))) + +(defun jclass-constructors (class) + "Returns a vector of constructors for CLASS" + (jcall (jmethod "java.lang.Class" "getConstructors") (jclass class))) + +(defun jconstructor-params (constructor) + "Returns a vector of parameter types (Java classes) for CONSTRUCTOR" + (jcall (jmethod "java.lang.reflect.Constructor" "getParameterTypes") constructor)) + +(defun jclass-fields (class &key declared public) + "Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS" + (let* ((getter (if declared "getDeclaredFields" "getFields")) + (fields (jcall (jmethod "java.lang.Class" getter) (jclass class)))) + (if public (delete-if-not #'jmember-public-p fields) fields))) + +(defun jclass-field (class field-name) + "Returns the field named FIELD-NAME of CLASS" + (jcall (jmethod "java.lang.Class" "getField" "java.lang.String") + (jclass class) field-name)) + +(defun jfield-type (field) + "Returns the type (Java class) of FIELD" + (jcall (jmethod "java.lang.reflect.Field" "getType") field)) + +(defun jfield-name (field) + "Returns the name of FIELD as a Lisp string" + (jcall (jmethod "java.lang.reflect.Field" "getName") field)) + +(defun jclass-methods (class &key declared public) + "Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS" + (let* ((getter (if declared "getDeclaredMethods" "getMethods")) + (methods (jcall (jmethod "java.lang.Class" getter) (jclass class)))) + (if public (delete-if-not #'jmember-public-p methods) methods))) + +(defun jmethod-params (method) + "Returns a vector of parameter types (Java classes) for METHOD" + (jcall (jmethod "java.lang.reflect.Method" "getParameterTypes") method)) + +;; (defun jmethod-return-type (method) +;; "Returns the result type (Java class) of the METHOD" +;; (jcall (jmethod "java.lang.reflect.Method" "getReturnType") method)) + +(defun jmethod-name (method) + "Returns the name of METHOD as a Lisp string" + (jcall (jmethod "java.lang.reflect.Method" "getName") method)) + +(defun jinstance-of-p (obj class) + "OBJ is an instance of CLASS (or one of its subclasses)" + (and (java-object-p obj) + (jcall (jmethod "java.lang.Class" "isInstance" "java.lang.Object") (jclass class) obj))) + +(defun jmember-static-p (member) + "MEMBER is a static member of its declaring class" + (jstatic (jmethod "java.lang.reflect.Modifier" "isStatic" "int") + "java.lang.reflect.Modifier" + (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member))) + +(defun jmember-public-p (member) + "MEMBER is a public member of its declaring class" + (jstatic (jmethod "java.lang.reflect.Modifier" "isPublic" "int") + "java.lang.reflect.Modifier" + (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member))) + +(defun jmember-protected-p (member) + "MEMBER is a protected member of its declaring class" + (jstatic (jmethod "java.lang.reflect.Modifier" "isProtected" "int") + "java.lang.reflect.Modifier" + (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member))) + +(defmethod make-load-form ((object java-object) &optional environment) + (declare (ignore environment)) + (let ((class-name (jclass-name (jclass-of object)))) + (cond + ((string= class-name "java.lang.reflect.Constructor") + `(java:jconstructor ,(jclass-name + (jcall (jmethod "java.lang.reflect.Constructor" + "getDeclaringClass") object)) + ,@(loop for arg-type across + (jcall + (jmethod "java.lang.reflect.Constructor" + "getParameterTypes") + object) + collecting + (jclass-name arg-type)))) + ((string= class-name "java.lang.reflect.Method") + `(java:jmethod ,(jclass-name + (jcall (jmethod "java.lang.reflect.Method" + "getDeclaringClass") object)) + ,(jmethod-name object) + ,@(loop for arg-type across + (jcall + (jmethod "java.lang.reflect.Method" + "getParameterTypes") + object) + collecting + (jclass-name arg-type)))) + ((jinstance-of-p object "java.lang.Class") + `(java:jclass ,(jcall (jmethod "java.lang.Class" "getName") object))) + (t + (error "Unknown load-from for ~A" class-name))))) + +(defun jproperty-value (obj prop) + (%jget-property-value obj prop)) + +(defun (setf jproperty-value) (value obj prop) + (%jset-property-value obj prop value)) + +(provide "JAVA-EXTENSIONS") Added: branches/save-image/src/org/armedbear/lisp/java/awt/.cvsignore ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/.cvsignore Fri Mar 6 00:01:48 2009 @@ -0,0 +1,2 @@ +*.class +Makefile Added: branches/save-image/src/org/armedbear/lisp/java/awt/ActionListener.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/ActionListener.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,83 @@ +/* + * ActionListener.java + * + * Copyright (C) 2003 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import org.armedbear.lisp.JHandler; +import java.awt.event.ActionEvent; +import java.awt.Button; +import java.awt.List; +import java.awt.MenuItem; +import java.awt.TextField; +import javax.swing.AbstractButton; +import javax.swing.JTextField; + +public class ActionListener implements java.awt.event.ActionListener +{ + public void actionPerformed(ActionEvent actionevent) { + String as[] = { actionevent.paramString(), actionevent.getActionCommand() }; + int ai[] = { actionevent.getModifiers() }; + long al[] = { actionevent.getWhen() }; // not yet used + JHandler.callLisp("ACTIONPERFORMED", handle, as, ai); + } + + //AWT + + public static synchronized void addTo(Button button) { + ActionListener actionlistener = new ActionListener(); + actionlistener.handle = button; + button.addActionListener(actionlistener); + } + + public static synchronized void addTo(List list) { + ActionListener actionlistener = new ActionListener(); + actionlistener.handle = list; + list.addActionListener(actionlistener); + } + + public static synchronized void addTo(MenuItem menuitem) { + ActionListener actionlistener = new ActionListener(); + actionlistener.handle = menuitem; + menuitem.addActionListener(actionlistener); + } + + public static synchronized void addTo(TextField textfield) { + ActionListener actionlistener = new ActionListener(); + actionlistener.handle = textfield; + textfield.addActionListener(actionlistener); + } + + //Swing + + //takes care of JButton, JMenuItem, JToggleButton etc. + public static synchronized void addTo(AbstractButton ab) { + ActionListener actionlistener = new ActionListener(); + actionlistener.handle = ab; + ab.addActionListener(actionlistener); + } + + public static synchronized void addTo(JTextField textfield) { + ActionListener actionlistener = new ActionListener(); + actionlistener.handle = textfield; + textfield.addActionListener(actionlistener); + } + + private Object handle; +} Added: branches/save-image/src/org/armedbear/lisp/java/awt/ComponentAdapter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/ComponentAdapter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +/* + * ComponentAdapter.java + * + * Copyright (C) 2003 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import org.armedbear.lisp.JHandler; +import java.awt.Component; +import java.awt.event.ComponentEvent; + +public class ComponentAdapter extends java.awt.event.ComponentAdapter { + + public static synchronized void addTo(Component component) { + component.addComponentListener(new ComponentAdapter()); + } + + private void call(String s, ComponentEvent componentevent) { + JHandler.callLisp(s, componentevent.getComponent(), componentevent.paramString()); + } + + public void componentHidden(ComponentEvent componentevent) { + call("COMPONENTHIDDEN", componentevent); + } + + public void componentMoved(ComponentEvent componentevent) { + call("COMPONENTMOVED", componentevent); + } + + public void componentResized(ComponentEvent componentevent) { + call("COMPONENTRESIZED", componentevent); + } + + public void componentShown(ComponentEvent componentevent) { + call("COMPONENTSHOWN", componentevent); + } +} Added: branches/save-image/src/org/armedbear/lisp/java/awt/ItemListener.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/ItemListener.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,111 @@ +/* + * ItemListener.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: ItemListener.java 11297 2008-08-31 13:26:45Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import java.awt.Checkbox; +import java.awt.CheckboxMenuItem; +import java.awt.Choice; +import java.awt.ItemSelectable; +import java.awt.List; +import java.awt.event.ItemEvent; +import javax.swing.AbstractButton; +import javax.swing.ButtonModel; +import javax.swing.DefaultButtonModel; +import javax.swing.JComboBox; +import org.armedbear.lisp.JHandler; + +public class ItemListener implements java.awt.event.ItemListener +{ + public void itemStateChanged(ItemEvent itemevent) + { + String as[] = { itemevent.paramString(), itemevent.getItem().toString() }; + int ai[] = { itemevent.getStateChange() != ItemEvent.SELECTED ? 0 : 1 }; + JHandler.callLisp("ITEMSTATECHANGED", handle, as, ai); + } + + public static synchronized void addTo(Checkbox checkbox) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = checkbox; + checkbox.addItemListener(itemlistener); + } + + public static synchronized void addTo(CheckboxMenuItem checkboxmenuitem) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = checkboxmenuitem; + checkboxmenuitem.addItemListener(itemlistener); + } + + public static synchronized void addTo(Choice choice) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = choice; + choice.addItemListener(itemlistener); + } + + public static synchronized void addTo(ItemSelectable itemselectable) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = itemselectable; + itemselectable.addItemListener(itemlistener); + } + + public static synchronized void addTo(List list) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = list; + list.addItemListener(itemlistener); + } + + //Swing + + public static synchronized void addTo(AbstractButton abstractbutton) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = abstractbutton; + abstractbutton.addItemListener(itemlistener); + } + + public static synchronized void addTo(ButtonModel buttonmodel) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = buttonmodel; + buttonmodel.addItemListener(itemlistener); + } + + public static synchronized void addTo(DefaultButtonModel defaultbuttonmodel) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = defaultbuttonmodel; + defaultbuttonmodel.addItemListener(itemlistener); + } + + public static synchronized void addTo(JComboBox jcombobox) + { + ItemListener itemlistener = new ItemListener(); + itemlistener.handle = jcombobox; + jcombobox.addItemListener(itemlistener); + } + + private Object handle; +} Added: branches/save-image/src/org/armedbear/lisp/java/awt/KeyAdapter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/KeyAdapter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,53 @@ +/* + * KeyAdapter.java + * + * Copyright (C) 2003 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import org.armedbear.lisp.JHandler; +import java.awt.Component; +import java.awt.event.KeyEvent; + +public class KeyAdapter extends java.awt.event.KeyAdapter { + + public static synchronized void addTo(Component component) { + component.addKeyListener(new KeyAdapter()); + } + + private void call(String s, KeyEvent keyevent) { + int ai[] = { + keyevent.getModifiers(), + keyevent.isActionKey() ? 1 : 0, + keyevent.getKeyCode() + }; + JHandler.callLisp(s, keyevent.getComponent(), keyevent.paramString(), ai); + } + + public void keyPressed(KeyEvent keyevent) { + call("KEYPRESSED", keyevent); + } + + public void keyReleased(KeyEvent keyevent) { + call("KEYRELEASED", keyevent); + } + + public void keyTyped(KeyEvent keyevent) { + call("KEYTYPED", keyevent); + } +} Added: branches/save-image/src/org/armedbear/lisp/java/awt/Makefile.in ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/Makefile.in Fri Mar 6 00:01:48 2009 @@ -0,0 +1,44 @@ +# Makefile.in + +# Copyright (C) 2003 Peter Graves +# $Id: Makefile.in 11297 2008-08-31 13:26:45Z ehuelsmann $ + +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +JAVAC = @JAVAC@ +JAVACFLAGS = @JAVACFLAGS@ +COMPILER_CLASSPATH = @COMPILER_CLASSPATH@ + +CLASSFILES = ActionListener.class \ + ComponentAdapter.class \ + ItemListener.class \ + KeyAdapter.class \ + MouseAdapter.class \ + MouseMotionAdapter.class \ + WindowAdapter.class + +SOURCEFILES = $(patsubst %.class,%.java,$(CLASSFILES)) + +%.class : %.java + $(JAVAC) -classpath "$(COMPILER_CLASSPATH)" $(JAVACFLAGS) $< + touch ../../../../../../classes.stamp + +classes: $(CLASSFILES) + +clean: + -rm -f *.class + +Makefile: Makefile.in ../../../../../../config.status + cd ../../../../../.. && $(SHELL) ./config.status Added: branches/save-image/src/org/armedbear/lisp/java/awt/MouseAdapter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/MouseAdapter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,63 @@ +/* + * MouseAdapter.java + * + * Copyright (C) 2003 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import org.armedbear.lisp.JHandler; +import java.awt.Component; +import java.awt.event.MouseEvent; + +public class MouseAdapter extends java.awt.event.MouseAdapter +{ + public static synchronized void addTo(Component component) { + component.addMouseListener(new MouseAdapter()); + } + + private void call(String s, MouseEvent mouseevent) { + int ai[] = { + mouseevent.getModifiers(), + mouseevent.isPopupTrigger() ? 1 : 0, + mouseevent.getClickCount(), + mouseevent.getX(), + mouseevent.getY() + }; + JHandler.callLisp(s, mouseevent.getComponent(), mouseevent.paramString(), ai); + } + + public void mouseClicked(MouseEvent mouseevent) { + call("MOUSECLICKED", mouseevent); + } + + public void mousePressed(MouseEvent mouseevent) { + call("MOUSEPRESSED", mouseevent); + } + + public void mouseReleased(MouseEvent mouseevent) { + call("MOUSERELEASED", mouseevent); + } + + public void mouseEntered(MouseEvent mouseevent) { + call("MOUSEENTERED", mouseevent); + } + + public void mouseExited(MouseEvent mouseevent) { + call("MOUSEEXITED", mouseevent); + } +} Added: branches/save-image/src/org/armedbear/lisp/java/awt/MouseMotionAdapter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/MouseMotionAdapter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,55 @@ +/* + * MouseMotionAdapter.java + * + * Copyright (C) 2003 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import org.armedbear.lisp.JHandler; +import java.awt.Component; +import java.awt.event.MouseEvent; + +public class MouseMotionAdapter extends java.awt.event.MouseMotionAdapter +{ + public static synchronized void addTo(Component component) { + component.addMouseMotionListener(new MouseMotionAdapter()); + } + + private void call(String s, MouseEvent mouseevent) { + int ai[] = { + mouseevent.getModifiers(), + mouseevent.isPopupTrigger() ? 1 : 0, + mouseevent.getClickCount(), + mouseevent.getX(), + mouseevent.getY() + }; + JHandler.callLisp(s, mouseevent.getComponent(), mouseevent.paramString(), ai); + } + + public void mouseDragged(MouseEvent mouseevent) { + call("MOUSEDRAGGED", mouseevent); + } + + public void mouseMoved(MouseEvent mouseevent) { + call("MOUSEMOVED", mouseevent); + } + + public void mouseWheel(MouseEvent mouseevent) { + call("MOUSEWHEEL", mouseevent); + } +} Added: branches/save-image/src/org/armedbear/lisp/java/awt/WindowAdapter.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/java/awt/WindowAdapter.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,72 @@ +/* + * WindowAdapter.java + * + * Copyright (C) 2003 Peter Graves + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.java.awt; + +import org.armedbear.lisp.JHandler; +import java.awt.Window; +import java.awt.event.WindowEvent; + +public class WindowAdapter extends java.awt.event.WindowAdapter +{ + private void call(String s, WindowEvent windowevent) { + JHandler.callLisp(s, windowevent.getWindow()); + } + + public static synchronized void addTo(Window window) { + window.addWindowListener(new WindowAdapter()); + } + + public void windowOpened(WindowEvent windowevent) { + call("WINDOWOPENED", windowevent); + } + + public void windowClosed(WindowEvent windowevent) { + call("WINDOWCLOSED", windowevent); + } + + public void windowClosing(WindowEvent windowevent) { + call("WINDOWCLOSING", windowevent); + } + + public void windowActivated(WindowEvent windowevent) { + call("WINDOWACTIVATED", windowevent); + } + + public void windowDeactivated(WindowEvent windowevent) { + call("WINDOWDEACTIVATED", windowevent); + } + + public void windowIconified(WindowEvent windowevent) { + call("WINDOWICONIFIED", windowevent); + } + + public void windowDeiconified(WindowEvent windowevent) { + call("WINDOWDEICONIFIED", windowevent); + } + + public void windowGainedFocus(WindowEvent windowevent) { + call("WINDOWGAINEDFOCUS", windowevent); + } + + public void windowLostFocus(WindowEvent windowevent) { + call("WINDOWLOSTFOCUS", windowevent); + } +} Added: branches/save-image/src/org/armedbear/lisp/jclass_name.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/jclass_name.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,102 @@ +/* + * jclass_name.java + * + * Copyright (C) 2005 Peter Graves + * $Id: jclass_name.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### jclass-name class-ref &optional name +public final class jclass_name extends Primitive +{ + private jclass_name() + { + super(Symbol.JCLASS_NAME, "class-ref &optional name", +"When called with one argument, returns the name of the Java class\n" + +" designated by CLASS-REF. When called with two arguments, tests\n" + +" whether CLASS-REF matches NAME."); + } + + // When called with one argument, JCLASS-NAME returns the name of the class + // referenced by CLASS-REF. + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + if (arg instanceof AbstractString) { + String s = arg.getStringValue(); + try { + return new SimpleString((Class.forName(s)).getName()); + } + catch (ClassNotFoundException e) { + // Fall through. + } + } else if (arg instanceof JavaObject) { + Object obj = ((JavaObject)arg).getObject(); + if (obj instanceof Class) + return new SimpleString(((Class)obj).getName()); + // Fall through. + } + return error(new LispError(arg.writeToString() + " does not designate a Java class.")); + } + + // When called with two arguments, JCLASS-NAME tests whether CLASS-REF + // matches NAME. + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + String className = null; + if (first instanceof AbstractString) { + String s = first.getStringValue(); + try { + className = (Class.forName(s)).getName(); + } + catch (ClassNotFoundException e) {} + } else if (first instanceof JavaObject) { + Object obj = ((JavaObject)first).getObject(); + if (obj instanceof Class) + className = ((Class)obj).getName(); + } + if (className == null) + return error(new LispError(first.writeToString() + " does not designate a Java class.")); + final AbstractString name; + try { + name = (AbstractString) second; + } + catch (ClassCastException e) { + return type_error(second, Symbol.STRING); + } + return LispThread.currentThread().setValues(name.getStringValue().equals(className) ? T : NIL, + new SimpleString(className)); + } + + private static final Primitive JCLASS_NAME = new jclass_name(); +} Added: branches/save-image/src/org/armedbear/lisp/jclass_of.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/jclass_of.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,80 @@ +/* + * jclass_of.java + * + * Copyright (C) 2005 Peter Graves + * $Id: jclass_of.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### jclass-of object &optional name +public final class jclass_of extends Primitive +{ + private jclass_of() + { + super(Symbol.JCLASS_OF, "object &optional name", +"Returns the name of the Java class of OBJECT. If the NAME argument is\n" + +" supplied, verifies that OBJECT is an instance of the named class. The name\n" + +" of the class or nil is always returned as a second value."); + } + + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + final String className; + if (arg instanceof AbstractString) + className = "java.lang.String"; + else if (arg instanceof JavaObject) + className = ((JavaObject)arg).getObject().getClass().getName(); + else + className = null; + final LispObject value = + (className != null) ? new SimpleString(className) : NIL; + return LispThread.currentThread().setValues(value, value); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + final String className; + if (first instanceof AbstractString) + className = "java.lang.String"; + else if (first instanceof JavaObject) + className = ((JavaObject)first).getObject().getClass().getName(); + else + className = null; + String name = javaString(second); + return LispThread.currentThread().setValues(name.equals(className) ? T : NIL, + new SimpleString(className)); + } + + private static final Primitive JCLASS_OF = new jclass_of(); +} Added: branches/save-image/src/org/armedbear/lisp/jmethod_return_type.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/jmethod_return_type.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,62 @@ +/* + * jmethod_return_type.java + * + * Copyright (C) 2005 Peter Graves + * $Id: jmethod_return_type.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.lang.reflect.Method; + +// ### jmethod-return-type method => class +public final class jmethod_return_type extends Primitive +{ + private jmethod_return_type() + { + super(Symbol.JMETHOD_RETURN_TYPE, "method", +"Returns a reference to the Class object that represents the formal return type of METHOD."); + } + + @Override + public LispObject execute(LispObject arg) + throws ConditionThrowable + { + final Method method; + try { + method = (Method) ((JavaObject)arg).getObject(); + } + catch (ClassCastException e) { + return error(new LispError(arg.writeToString() + " does not designate a Java method.")); + } + return new JavaObject(method.getReturnType()); + } + + private static final Primitive JMETHOD_RETURN_TYPE = new jmethod_return_type(); +} Added: branches/save-image/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/jvm.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,424 @@ +;;; jvm.lisp +;;; +;;; Copyright (C) 2003-2008 Peter Graves +;;; $Id: jvm.lisp 11697 2009-03-05 23:12:24Z astalla $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "JVM") + +(export '(compile-defun *catch-errors* jvm-compile jvm-compile-package + derive-compiler-type)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "LOOP") + (require "FORMAT") + (require "CLOS") + (require "PRINT-OBJECT") + (require "COMPILER-TYPES") + (require "KNOWN-FUNCTIONS") + (require "KNOWN-SYMBOLS") + (require "DUMP-FORM") + (require "OPCODES") + (require "JAVA") + (require "COMPILER-PASS1") + (require "COMPILER-PASS2")) + +(defvar *closure-variables* nil) + +(defvar *enable-dformat* nil) + +#+nil +(defun dformat (destination control-string &rest args) + (when *enable-dformat* + (apply #'sys::%format destination control-string args))) + +(defmacro dformat (&rest ignored) + (declare (ignore ignored))) + + +(defmacro with-saved-compiler-policy (&body body) + "Saves compiler policy variables, restoring them after evaluating `body'." + `(let ((*speed* *speed*) + (*space* *space*) + (*safety* *safety*) + (*debug* *debug*) + (*explain* *explain*) + (*inline-declarations* *inline-declarations*)) + , at body)) + + + +(defvar *compiler-debug* nil) + +(defvar *pool* nil) +(defvar *pool-count* 1) +(defvar *pool-entries* nil) +(defvar *fields* ()) +(defvar *static-code* ()) + +(defvar *declared-symbols* nil) +(defvar *declared-functions* nil) +(defvar *declared-strings* nil) +(defvar *declared-integers* nil) +(defvar *declared-floats* nil) +(defvar *declared-doubles* nil) + +(defstruct (class-file (:constructor %make-class-file)) + pathname ; pathname of output file + lambda-name + class + superclass + lambda-list ; as advertised + pool + (pool-count 1) + (pool-entries (make-hash-table :test #'equal)) + fields + methods + static-code + (symbols (make-hash-table :test 'eq)) + (functions (make-hash-table :test 'equal)) + (strings (make-hash-table :test 'eq)) + (integers (make-hash-table :test 'eql)) + (floats (make-hash-table :test 'eql)) + (doubles (make-hash-table :test 'eql))) + +(defun class-name-from-filespec (filespec) + (let* ((name (pathname-name filespec))) + (declare (type string name)) + (dotimes (i (length name)) + (declare (type fixnum i)) + (when (char= (char name i) #\-) + (setf (char name i) #\_))) + (concatenate 'string "org/armedbear/lisp/ABCL_GENERATED_" name))) + +(defun make-class-file (&key pathname lambda-name lambda-list) + (aver (not (null pathname))) + (let ((class-file (%make-class-file :pathname pathname + :lambda-name lambda-name + :lambda-list lambda-list))) + (setf (class-file-class class-file) (class-name-from-filespec pathname)) + class-file)) + +(defmacro with-class-file (class-file &body body) + (let ((var (gensym))) + `(let* ((,var ,class-file) + (*pool* (class-file-pool ,var)) + (*pool-count* (class-file-pool-count ,var)) + (*pool-entries* (class-file-pool-entries ,var)) + (*fields* (class-file-fields ,var)) + (*static-code* (class-file-static-code ,var)) + (*declared-symbols* (class-file-symbols ,var)) + (*declared-functions* (class-file-functions ,var)) + (*declared-strings* (class-file-strings ,var)) + (*declared-integers* (class-file-integers ,var)) + (*declared-floats* (class-file-floats ,var)) + (*declared-doubles* (class-file-doubles ,var))) + (progn , at body) + (setf (class-file-pool ,var) *pool* + (class-file-pool-count ,var) *pool-count* + (class-file-pool-entries ,var) *pool-entries* + (class-file-fields ,var) *fields* + (class-file-static-code ,var) *static-code* + (class-file-symbols ,var) *declared-symbols* + (class-file-functions ,var) *declared-functions* + (class-file-strings ,var) *declared-strings* + (class-file-integers ,var) *declared-integers* + (class-file-floats ,var) *declared-floats* + (class-file-doubles ,var) *declared-doubles*)))) + +(defstruct compiland + name + (kind :external) ; :INTERNAL or :EXTERNAL + lambda-expression + arg-vars + arity ; NIL if the number of args can vary. + p1-result + parent + (children 0 :type fixnum) ; Number of local functions defined with FLET or LABELS. + argument-register + closure-register + class-file ; class-file object + (%single-valued-p t)) + +(defknown compiland-single-valued-p (t) t) +(defun compiland-single-valued-p (compiland) + (unless (compiland-parent compiland) + (let ((name (compiland-name compiland))) + (when name + (let ((result-type + (or (function-result-type name) + (and (proclaimed-ftype name) + (ftype-result-type (proclaimed-ftype name)))))) + (when result-type + (return-from compiland-single-valued-p + (cond ((eq result-type '*) + nil) + ((atom result-type) + t) + ((eq (%car result-type) 'VALUES) + (= (length result-type) 2)) + (t + t)))))))) + ;; Otherwise... + (compiland-%single-valued-p compiland)) + +(defvar *current-compiland* nil) + +(defvar *this-class* nil) + +(defvar *code* ()) + +;; All tags visible at the current point of compilation, some of which may not +;; be in the current compiland. +(defvar *visible-tags* ()) + +;; The next available register. +(defvar *register* 0) + +;; Total number of registers allocated. +(defvar *registers-allocated* 0) + +(defvar *handlers* ()) + +(defstruct handler + from + to + code + catch-type) + +;; Variables visible at the current point of compilation. +(defvar *visible-variables* nil) + +;; All variables seen so far. +(defvar *all-variables* nil) + +;; Undefined variables that we've already warned about. +(defvar *undefined-variables* nil) + +(defvar *dump-variables* nil) + +(defun dump-1-variable (variable) + (sys::%format t " ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%" + (variable-name variable) + (variable-special-p variable) + (variable-register variable) + (variable-index variable) + (variable-declared-type variable))) + +(defun dump-variables (list caption &optional (force nil)) + (when (or force *dump-variables*) + (write-string caption) + (if list + (dolist (variable list) + (dump-1-variable variable)) + (sys::%format t " None.~%")))) + +(defstruct (variable-info (:conc-name variable-) + (:constructor make-variable) + (:predicate variable-p)) + name + initform + temp-register + (declared-type :none) + (derived-type :none) + ignore-p + ignorable-p + representation + special-p ; indicates whether a variable is special + register ; register number for a local variable + index ; index number for a variable in the argument array + closure-index ; index number for a variable in the closure context array + ;; a variable can be either special-p *or* have a register *or* + ;; have an index *or a closure-index + reserved-register + (reads 0 :type fixnum) + (writes 0 :type fixnum) + references + used-non-locally-p + (compiland *current-compiland*)) + +(defstruct (var-ref (:constructor make-var-ref (variable))) + ;; The variable this reference refers to. Will be NIL if the VAR-REF has been + ;; rewritten to reference a constant value. + variable + ;; True if the VAR-REF has been rewritten to reference a constant value. + constant-p + ;; The constant value of this VAR-REF. + constant-value) + +;; obj can be a symbol or variable +;; returns variable or nil +(declaim (ftype (function (t) t) unboxed-fixnum-variable)) +(defun unboxed-fixnum-variable (obj) + (cond ((symbolp obj) + (let ((variable (find-visible-variable obj))) + (if (and variable + (eq (variable-representation variable) :int)) + variable + nil))) + ((variable-p obj) + (if (eq (variable-representation obj) :int) + obj + nil)) + (t + nil))) + +(defvar *child-p* nil + "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA") + +(defknown find-variable (symbol list) t) +(defun find-variable (name variables) + (dolist (variable variables) + (when (eq name (variable-name variable)) + (return variable)))) + +(defknown find-visible-variable (t) t) +(defun find-visible-variable (name) + (dolist (variable *visible-variables*) + (when (eq name (variable-name variable)) + (return variable)))) + +(defknown allocate-register () (integer 0 65535)) +(defun allocate-register () + (let* ((register *register*) + (next-register (1+ register))) + (declare (type (unsigned-byte 16) register next-register)) + (setf *register* next-register) + (when (< *registers-allocated* next-register) + (setf *registers-allocated* next-register)) + register)) + +(defknown allocate-register-pair () (integer 0 65535)) +(defun allocate-register-pair () + (let* ((register *register*) + (next-register (+ register 2))) + (declare (type (unsigned-byte 16) register next-register)) + (setf *register* next-register) + (when (< *registers-allocated* next-register) + (setf *registers-allocated* next-register)) + register)) + +(defstruct local-function + name + compiland + inline-expansion + function + class-file + variable) + +(defvar *local-functions* ()) + +(defknown find-local-function (t) t) +(defun find-local-function (name) + (dolist (local-function *local-functions* nil) + (when (equal name (local-function-name local-function)) + (return local-function)))) + +(defvar *using-arg-array* nil) +(defvar *hairy-arglist-p* nil) + +(defstruct node + ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND). + name + form + (compiland *current-compiland*)) + +;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as +;; BLOCKs per se. +(defstruct (block-node (:conc-name block-) (:include node) (:constructor make-block-node (name))) + (exit (gensym)) + target + catch-tag + ;; True if there is any RETURN from this block. + return-p + ;; True if there is a non-local RETURN from this block. + non-local-return-p + ;; True if a tag in this tagbody is the target of a non-local GO. + non-local-go-p + ;; If non-nil, register containing saved dynamic environment for this block. + environment-register + ;; Only used in LET/LET*/M-V-B nodes. + vars + free-specials + ) + +(defknown node-constant-p (t) boolean) +(defun node-constant-p (object) + (cond ((block-node-p object) + nil) + ((var-ref-p object) + nil) + ((constantp object) + t) + (t + nil))) + +(defvar *blocks* ()) + +(defun find-block (name) + (dolist (block *blocks*) + (when (eq name (block-name block)) + (return block)))) + +(defstruct tag + name + label + block + (compiland *current-compiland*)) + +(defun process-ignore/ignorable (declaration names variables) + (when (memq declaration '(IGNORE IGNORABLE)) + (let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable"))) + (dolist (name names) + (let ((variable (find-variable name variables))) + (cond ((null variable) + (compiler-style-warn "Declaring unknown variable ~S to be ~A." + name what)) + ((variable-special-p variable) + (compiler-style-warn "Declaring special variable ~S to be ~A." + name what)) + ((eq declaration 'IGNORE) + (setf (variable-ignore-p variable) t)) + (t + (setf (variable-ignorable-p variable) t)))))))) + +(defun compile (name &optional definition) + (jvm-compile name definition)) + +(defun finalize-generic-functions () + (dolist (sym '(make-instance + initialize-instance + shared-initialize)) + (let ((gf (and (fboundp sym) (fdefinition sym)))) + (when (typep gf 'generic-function) + (unless (compiled-function-p gf) + (mop::finalize-generic-function gf)))))) + +(finalize-generic-functions) + +(provide 'jvm) Added: branches/save-image/src/org/armedbear/lisp/known-functions.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/known-functions.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,463 @@ +;;; known-functions.lisp +;;; +;;; Copyright (C) 2005-2006 Peter Graves +;;; $Id: known-functions.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(require '#:compiler-types) + +;; (declaim (ftype (function * symbol) copy-symbol gensym)) +;; (declaim (ftype (function * symbol) fdefinition-block-name)) +(defknown (copy-symbol gensym fdefinition-block-name) * symbol) + +;; (declaim (ftype (function (t t) t) gethash1)) +(defknown gethash1 (t t) t) +;; (declaim (ftype (function (t) symbol) make-keyword)) +(defknown make-keyword (t) symbol) + +;; (declaim (ftype (function * list) +;; backq-list backq-list* backq-append backq-nconc +;; %class-precedence-list)) +(defknown (backq-list backq-list* backq-append backq-nconc %class-precedence-list) + * list) + +;; (declaim (ftype (function * cons) backq-cons)) +(defknown backq-cons * cons) + +;; (declaim (ftype (function (character) character) char-downcase char-upcase)) +(defknown (char-downcase char-upcase) (character) character) + +;; (declaim (ftype (function * t) finish-output force-output clear-output terpri fresh-line)) +(defknown (finish-output force-output clear-output terpri fresh-line) * t) + +;; (declaim (ftype (function (symbol) string) symbol-name)) +(defknown symbol-name (symbol) string) + +;; (declaim +;; (ftype (function * string) +;; get-output-stream-string +;; nstring-capitalize +;; nstring-downcase +;; nstring-upcase +;; string-capitalize +;; string-downcase +;; string-upcase +;; write-line +;; write-string +;; )) +(defknown (get-output-stream-string + nstring-capitalize + nstring-downcase + nstring-upcase + string-capitalize + string-downcase + string-upcase + write-line + write-string) * string) + +(defknown (%failed-aver + %ldb + %make-structure + %method-function + put + %set-cddr + %stream-terpri + %stream-write-char + alphanumericp + array-has-fill-pointer-p + aset + bit-and + bit-andc1 + bit-andc2 + bit-eqv + bit-ior + bit-nand + bit-nor + bit-not + bit-orc1 + bit-orc2 + bit-xor + both-case-p + built-in-function-p + caadr + char-equal + characterp + charpos + close + coerce + coerce-to-function + compile-file-pathname + complex + conjugate + count + count-if + count-if-not + delete-file + directory-namestring + eighth + enough-namestring + every + fifth + file-directory-p + file-namestring + file-position + fill + first + float + fmakunbound + fourth + fset + ftype-result-type + get-internal-real-time + getf + hash-table-count + hash-table-p + host-namestring + intersection + ldb + ldb-test + list-all-packages + list-find* + load-compiled-function + lower-case-p + make-string-output-stream + make-structure + map + merge-pathnames + namestring + neq + nintersection + ninth + normalize-type + nsubst + nsubst-if + nsubst-if-not + nth + pathname-type + pathname-type + pathnamep + phase + probe-file + proclaimed-ftype + random + read + read-char + read-sequence + reduce + replace + rest + scale-float + search + second + set + set-char + set-schar + set-std-slot-value + setf-function-name-p + seventh + simple-condition-format-arguments + simple-condition-format-control + simple-search + sixth + some + sort + stable-sort + standard-object-p + std-instance-layout + std-slot-value + stream-element-type + stream-line-number + string-find + string<= + structure-object-p + structure-ref + structure-set + subst + subst-if + subst-if-not + svref + svset + tenth + third + truename + upper-case-p + vector + vector-find* + vectorp + write-byte + write-sequence + zerop) + * t) + +(defknown length (sequence) (integer 0 #.(1- most-positive-fixnum))) + +(defknown (deposit-field dpb logand logcount lognor + mask-field + numerator denominator + boole + array-dimension + %dpb + ash) + * integer) + +;; (declaim (ftype (function (t) (integer 0 2147483647)) sxhash)) +(defknown sxhash (t) (integer 0 2147483647)) + +;; (declaim (ftype (function (character) (unsigned-byte 16)) char-code)) +(defknown char-code (character) (unsigned-byte 16)) + +;; (declaim (ftype (function (simple-string index) character) schar)) +(defknown schar (simple-string index) character) + +;; (declaim (ftype (function * character) char write-char)) +(defknown (char write-char) * character) + +(defknown (char= char/= char< char> char<= char>= char-equal char-not-equal + char-lessp char-greaterp char-not-greaterp char-not-lessp) + * t) + +;; (declaim +;; (ftype (function (real real) real) +;; mod rem)) +(defknown (mod rem) (real real) real) + +;; (declaim (ftype (function (number) rational) rational rationalize)) +(defknown (rational rationalize) (number) rational) + +;; (declaim (ftype (function * bit) bit sbit)) +(defknown (bit sbit) * bit) + +;; (declaim (ftype (function * function) make-macro)) +(defknown make-macro * function) + +;; (declaim (ftype (function * t) %set-arglist)) +(defknown %set-arglist * t) + +;; (declaim (ftype (function * t) %type-error check-sequence-bounds)) +(defknown (%type-error check-sequence-bounds) * t) + +;; (declaim (ftype (function * t) out-synonym-of)) +(defknown out-synonym-of * t) + +(defknown (error + compiler-style-warn + compiler-warn + compiler-error + compiler-unsupported) + * t) + +;; (declaim (ftype (function (symbol) function) resolve)) +(defknown resolve (symbol) function) + +;; (declaim (ftype (function (string fixnum character) character) %set-char)) +(defknown %set-char (string index character) character) + +;; (declaim (ftype (function (t t t) t) set-function-info-value)) +(defknown set-function-info-value (t t t) t) + +;; (declaim (ftype (function * hash-table) make-hash-table)) +(defknown make-hash-table * hash-table) + +(defknown %class-slots (class) t) +(defknown set-class-slots (class list) t) +(defknown %slot-definition-name * t) +(defknown %slot-definition-initargs * t) +(defknown %slot-definition-initfunction * t) +(defknown std-slot-boundp * t) +(defknown std-slot-value * t) +(defknown set-std-slot-value * t) +(defknown open * (or stream null)) +(defknown make-string-input-stream * stream) + +;; Boolean predicates that can return unboxed Java booleans. +(defknown (arrayp + atom + consp + endp + evenp + floatp + integerp + listp + minusp + numberp + oddp + packagep + plusp + rationalp + readtablep + realp + simple-bit-vector-p + simple-vector-p + stringp + symbolp + zerop) + (t) boolean) + +(defknown (constantp simple-typep typep sys::%typep) + * boolean) + +;; Boolean comparison operators. +(defknown (/= + < + <= + = + > + >= + eq + eql + equal + equalp) + * boolean) + +;; Boolean predicates that can not (currently) return unboxed Java booleans. +(defknown (bit-vector-p + compiled-function-p + complexp + fboundp + functionp + keywordp + simple-string-p + typep) + (t) t) + +(defknown (boundp special-operator-p special-variable-p) + (symbol) t) + +;; Moved here from jvm.lisp. +(defknown (+ - * / + 1+ 1- + car cdr caar cadr cdar cddr cadar caddr cdddr cddddr + first second third + list list* + macro-function + compiler-macro-function + sys::%defun + get + fdefinition + array-dimensions array-rank array-total-size + array-element-type upgraded-array-element-type + row-major-aref + quote function + map + mapcar + find position + append nconc subseq adjoin + revappend nreconc + copy-seq + assoc assoc-if assoc-if-not acons assq assql + char-int digit-char-p + member ext:memq + remove remove-if remove-if-not delete delete-if delete-if-not + symbol-function + coerce + reverse nreverse + last + cons rplaca rplacd + set-car set-cdr + copy-list copy-tree + make-sequence make-list make-array make-package + find-package + pathname make-pathname pathname-name directory + package-used-by-list package-shadowing-symbols + nthcdr + aref elt + not null concatenate + format sys::%format + prin1 princ print write + compute-restarts find-restart restart-name + string + string= + setq + multiple-value-list push pop + type-of class-of + abs + float-radix + logand logandc1 logandc2 logeqv logior lognand + lognot logorc1 logorc2 logxor + logbitp + slot-boundp slot-value slot-exists-p + allocate-instance + find-class + class-name + constantly + exp expt log + min max + realpart imagpart + integer-length + sqrt isqrt gcd lcm signum + open + svref + fill-pointer + symbol-value symbol-package package-name + fourth + vector-push vector-push-extend + union nunion + remove-duplicates delete-duplicates + read-byte + fresh-line terpri + lambda + ext:classp + ext:fixnump + ext:memql + sys:%generic-function-name + sys::puthash + precompiler::precompile1 + declare + go + inst + emit + label + maybe-emit-clear-values + single-valued-p + sys:read-8-bits + sys:write-8-bits + sys::require-type + sys::arg-count-error + sys:subclassp + sys:gf-required-args + sys:cache-emf + sys:get-cached-emf + ext:autoloadp + sys::proclaim-ftype-1 + sys::proclaim-ftype + ) + * t) + +(defknown make-string * simple-string) +(defknown concatenate-to-string * simple-string) + +(defknown code-char * (or character null)) + +(defknown lookup-known-symbol (symbol) t) +(defknown %class-name (class) symbol) + +(defknown adjoin-eql (t t) list) + +(provide '#:known-functions) Added: branches/save-image/src/org/armedbear/lisp/known-symbols.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/known-symbols.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +;;; known-symbols.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: known-symbols.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(export '(lookup-known-symbol lookup-known-keyword)) + +(let ((symbols (make-hash-table :test 'eq :size 1024)) + (keywords (make-hash-table :test 'eq :size 128))) + (defun initialize-known-symbols (source ht) + (clrhash ht) + (let* ((source-class (java:jclass source)) + (symbol-class (java:jclass "org.armedbear.lisp.Symbol")) + (fields (java:jclass-fields source-class :declared t :public t))) + (dotimes (i (length fields)) + (let* ((field (aref fields i)) + (type (java:jfield-type field))) + (when (equal type symbol-class) + (let* ((name (java:jfield-name field)) + (symbol (java:jfield source-class name))) + (puthash symbol ht name)))))) + (hash-table-count ht)) + + (initialize-known-symbols "org.armedbear.lisp.Symbol" symbols) + (initialize-known-symbols "org.armedbear.lisp.Keyword" keywords) + + (defun lookup-known-symbol (symbol) + (gethash1 symbol symbols)) + + (defun lookup-known-keyword (keyword) + (gethash1 keyword keywords))) + +(provide '#:known-symbols) Added: branches/save-image/src/org/armedbear/lisp/last.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/last.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,103 @@ +/* + * last.java + * + * Copyright (C) 2003-2006 Peter Graves + * $Id: last.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### last list &optional n => tail +public final class last extends Primitive +{ + public last() + { + super("last", "list &optional n"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg == NIL) + return NIL; + if (arg instanceof Cons) + { + while (true) + { + LispObject cdr = ((Cons)arg).cdr; + if (!(cdr instanceof Cons)) + return arg; + arg = cdr; + } + } + else + return type_error(arg, Symbol.LIST); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + LispObject list = checkList(first); + if (second instanceof Fixnum) + { + int n = ((Fixnum)second).value; + if (n >= 0) { + if (list == NIL) + return NIL; + LispObject result = list; + while (list instanceof Cons) + { + list = list.cdr(); + if (n-- <= 0) + result = result.cdr(); + } + return result; + } + } + else if (second instanceof Bignum) + { + if (list == NIL) + return NIL; + LispObject n = second; + LispObject result = list; + while (list instanceof Cons) + { + list = list.cdr(); + if (!n.plusp()) + result = result.cdr(); + n = n.decr(); + } + return result; + } + return type_error(second, Symbol.UNSIGNED_BYTE); + } + + private static final Primitive LAST = new last(); +} Added: branches/save-image/src/org/armedbear/lisp/late-setf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/late-setf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,113 @@ +;;; late-setf.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: late-setf.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From CMUCL/SBCL. + +(in-package #:system) + +(defmacro define-setf-expander (access-fn lambda-list &body body) + (require-type access-fn 'symbol) + (let ((whole (gensym "WHOLE-")) + (environment (gensym "ENV-"))) + (multiple-value-bind (body local-decs doc) + (parse-defmacro lambda-list whole body access-fn + 'define-setf-expander + :environment environment) + `(setf (get ',access-fn 'setf-expander) + #'(lambda (,whole ,environment) + , at local-decs + (block ,access-fn ,body)))))) + +(define-setf-expander values (&rest places &environment env) + (let ((setters ()) + (getters ()) + (all-dummies ()) + (all-vals ()) + (newvals ())) + (dolist (place places) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (setf all-dummies (append all-dummies dummies (cdr newval)) + all-vals (append all-vals vals + (mapcar (constantly nil) (cdr newval))) + newvals (append newvals (list (car newval)))) + (push setter setters) + (push getter getters))) + (values all-dummies all-vals newvals + `(values ,@(reverse setters)) `(values ,@(reverse getters))))) + +(defun make-gensym-list (n) + (let ((list ())) + (dotimes (i n list) + (push (gensym) list)))) + +(define-setf-expander getf (place prop &optional default &environment env) + (multiple-value-bind (temps values stores set get) + (get-setf-expansion place env) + (let ((newval (gensym)) + (ptemp (gensym)) + (def-temp (if default (gensym)))) + (values `(, at temps ,ptemp ,@(if default `(,def-temp))) + `(, at values ,prop ,@(if default `(,default))) + `(,newval) + `(let ((,(car stores) (%putf ,get ,ptemp ,newval))) + ,set + ,newval) + `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) + +(define-setf-expander apply (functionoid &rest args) + (unless (and (listp functionoid) + (= (length functionoid) 2) + (eq (first functionoid) 'function) + (memq (second functionoid) '(aref bit sbit))) + (error "SETF of APPLY is only defined for #'AREF, #'BIT and #'SBIT.")) + (let ((function (second functionoid)) + (new-var (gensym)) + (vars (make-gensym-list (length args)))) + (values vars args (list new-var) + `(apply #'(setf ,function) ,new-var , at vars) + `(apply #',function , at vars)))) + +(define-setf-expander the (type place &environment env) + (multiple-value-bind (temps subforms store-vars setter getter) + (get-setf-expansion place env) + (values temps subforms store-vars + `(multiple-value-bind ,store-vars + (the ,type (values , at store-vars)) + ,setter) + `(the ,type ,getter)))) + +(defun (setf macro-function) (new-function symbol &optional environment) + (declare (ignore environment)) + (let ((macro (make-macro symbol (or (precompile nil new-function) + new-function)))) + (fset symbol macro) + macro)) Added: branches/save-image/src/org/armedbear/lisp/lcm.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/lcm.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +;;; lcm.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: lcm.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun two-arg-lcm (n m) + (cond ((zerop n) 0) + ((zerop m) 0) + (t + (/ (abs (* n m)) (gcd n m))))) + +(defun lcm (&rest integers) + (unless (every #'integerp integers) + (error 'type-error :datum (find-if-not #'integerp integers) :expected-type 'integer)) + (case (length integers) + (0 1) + (1 (abs (car integers))) + (2 (two-arg-lcm (car integers) (cadr integers))) + (t + (do ((result (car integers) (two-arg-lcm result (car rest))) + (rest (cdr integers) (cdr rest))) + ((null rest) result))))) Added: branches/save-image/src/org/armedbear/lisp/ldb.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ldb.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,101 @@ +;;; ldb.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: ldb.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun byte (size position) + (cons size position)) + +(defun byte-size (bytespec) + (car bytespec)) + +(defun byte-position (bytespec) + (cdr bytespec)) + +(defun ldb (bytespec integer) + (logand (ash integer (- (byte-position bytespec))) + (1- (ash 1 (byte-size bytespec))))) + +(defun ldb-test (bytespec integer) + (not (zerop (ldb bytespec integer)))) + +(defun dpb (newbyte bytespec integer) + (let* ((size (byte-size bytespec)) + (position (byte-position bytespec)) + (mask (1- (ash 1 size)))) + (logior (logand integer (lognot (ash mask position))) + (ash (logand newbyte mask) position)))) + +;; From SBCL. +(define-setf-expander ldb (bytespec place &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (if (and (consp bytespec) (eq (car bytespec) 'byte)) + (let ((n-size (gensym)) + (n-pos (gensym)) + (n-new (gensym))) + (values (list* n-size n-pos dummies) + (list* (second bytespec) (third bytespec) vals) + (list n-new) + `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) + ,getter))) + ,setter + ,n-new) + `(ldb (byte ,n-size ,n-pos) ,getter))) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(ldb ,btemp ,getter)))))) + +;; Used by the LDB source transform. +(defun %ldb (size position integer) + (logand (ash integer (- position)) + (1- (ash 1 size)))) + +(define-setf-expander %ldb (size position place &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((n-size (gensym)) + (n-pos (gensym)) + (n-new (gensym))) + (values (list* n-size n-pos dummies) + (list* size position vals) + (list n-new) + `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) + ,getter))) + ,setter + ,n-new) + `(ldb (byte ,n-size ,n-pos) ,getter))))) Added: branches/save-image/src/org/armedbear/lisp/ldiff.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/ldiff.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,47 @@ +;;; ldiff.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: ldiff.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defun ldiff (list object) + (require-type list 'list) + (do* ((list list (cdr list)) + (result (list ())) + (splice result)) + ((atom list) + (if (eql list object) + (cdr result) + (progn (rplacd splice list) (cdr result)))) + (if (eql list object) + (return (cdr result)) + (setq splice (cdr (rplacd splice (list (car list)))))))) Added: branches/save-image/src/org/armedbear/lisp/lisp_implementation_type.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/lisp_implementation_type.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +/* + * lisp_implementation_type.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: lisp_implementation_type.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### lisp-implementation-type => description +public final class lisp_implementation_type extends Primitive +{ + private lisp_implementation_type() + { + super("lisp-implementation-type", ""); + } + + @Override + public LispObject execute() + { + return new SimpleString("Armed Bear Common Lisp"); + } + + private static final lisp_implementation_type LISP_IMPLEMENTATION_TYPE = + new lisp_implementation_type(); +} Added: branches/save-image/src/org/armedbear/lisp/lisp_implementation_version.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/lisp_implementation_version.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,55 @@ +/* + * lisp_implementation_version.java + * + * Copyright (C) 2003 Peter Graves + * $Id: lisp_implementation_version.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### lisp_implementation_version +// lisp_implementation_version => description +public final class lisp_implementation_version extends Primitive +{ + private lisp_implementation_version() + { + super("lisp-implementation-version",""); + } + + @Override + public LispObject execute() + { + return new SimpleString(Version.getVersion()); + } + + private static final lisp_implementation_version LISP_IMPLEMENTATION_VERSION = + new lisp_implementation_version(); +} Added: branches/save-image/src/org/armedbear/lisp/list-length.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/list-length.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,44 @@ +;;; list-length.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: list-length.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun list-length (list) + (do ((n 0 (+ n 2)) + (y list (cddr y)) + (z list (cdr z))) + (()) + (when (endp y) + (return n)) + (when (endp (cdr y)) + (return (+ n 1))) + (when (and (eq y z) (> n 0)) + (return nil)))) Added: branches/save-image/src/org/armedbear/lisp/list.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/list.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,62 @@ +;;; list.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: list.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun fifth (list) + (car (cddddr list))) +(defun sixth (list) + (cadr (cddddr list))) +(defun seventh (list) + (caddr (cddddr list))) +(defun eighth (list) + (cadddr (cddddr list))) +(defun ninth (list) + (car (cddddr (cddddr list)))) +(defun tenth (list) + (cadr (cddddr (cddddr list)))) + +(defun make-list (size &key initial-element) + (%make-list size initial-element)) + +(defmacro apply-key (key element) + `(if ,key + (funcall ,key ,element) + ,element)) + +(defun complement (f) + #'(lambda (&rest x) (not (apply f x)))) + +(defun constantly (x) + #'(lambda (&rest args) (declare (ignore args)) x)) + +(defun member (item list &key key test test-not) + (%member item list key test test-not)) Added: branches/save-image/src/org/armedbear/lisp/listen.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/listen.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,59 @@ +/* + * listen.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: listen.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### listen +public final class listen extends Primitive +{ + private listen() + { + super("listen", "&optional input-stream"); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + Stream stream = + checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()); + return stream.listen(); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return inSynonymOf(arg).listen(); + } + + private static final Primitive LISTEN = new listen(); +} Added: branches/save-image/src/org/armedbear/lisp/load.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/load.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,44 @@ +;;; load.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: load.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun load (filespec + &key + (verbose *load-verbose*) + (print *load-print*) + (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)) Added: branches/save-image/src/org/armedbear/lisp/logand.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logand.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,77 @@ +/* + * logand.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logand.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logand &rest integers => result-integer +public final class logand extends Primitive +{ + private logand() + { + super("logand", "&rest integers"); + } + + @Override + public LispObject execute() + { + return Fixnum.MINUS_ONE; + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum || arg instanceof Bignum) + return arg; + return type_error(arg, Symbol.INTEGER); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.LOGAND(second); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = Fixnum.MINUS_ONE; + for (int i = 0; i < args.length; i++) + result = result.LOGAND(args[i]); + return result; + } + + private static final Primitive LOGAND = new logand(); +} Added: branches/save-image/src/org/armedbear/lisp/logandc1.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logandc1.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,76 @@ +/* + * logandc1.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: logandc1.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class logandc1 extends Primitive +{ + private logandc1() + { + super("logandc1", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum) { + if (second instanceof Fixnum) + return new Fixnum(~((Fixnum)first).value & + ((Fixnum)second).value); + if (second instanceof Bignum) { + BigInteger n1 = ((Fixnum)first).getBigInteger(); + BigInteger n2 = ((Bignum)second).value; + return number(n1.not().and(n2)); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + if (first instanceof Bignum) { + BigInteger n1 = ((Bignum)first).value; + if (second instanceof Fixnum) { + BigInteger n2 = ((Fixnum)second).getBigInteger(); + return number(n1.not().and(n2)); + } + if (second instanceof Bignum) { + BigInteger n2 = ((Bignum)second).value; + return number(n1.not().and(n2)); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + return error(new TypeError(first, Symbol.INTEGER)); + } + + private static final Primitive LOGANDC1 = new logandc1(); +} Added: branches/save-image/src/org/armedbear/lisp/logandc2.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logandc2.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,79 @@ +/* + * logandc2.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: logandc2.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logandc2 +// logandc2 integer-1 integer-2 => result-integer +// and integer-1 with complement of integer-2 +public final class logandc2 extends Primitive +{ + private logandc2() + { + super("logandc2", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum) { + if (second instanceof Fixnum) + return new Fixnum(((Fixnum)first).value & + ~((Fixnum)second).value); + if (second instanceof Bignum) { + BigInteger n1 = ((Fixnum)first).getBigInteger(); + BigInteger n2 = ((Bignum)second).value; + return number(n1.and(n2.not())); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + if (first instanceof Bignum) { + BigInteger n1 = ((Bignum)first).value; + if (second instanceof Fixnum) { + BigInteger n2 = ((Fixnum)second).getBigInteger(); + return number(n1.and(n2.not())); + } + if (second instanceof Bignum) { + BigInteger n2 = ((Bignum)second).value; + return number(n1.and(n2.not())); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + return error(new TypeError(first, Symbol.INTEGER)); + } + + private static final Primitive LOGANDC2 = new logandc2(); +} Added: branches/save-image/src/org/armedbear/lisp/logbitp.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logbitp.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,75 @@ +/* + * logbitp.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logbitp.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logbitp index integer => generalized-boolean +public final class logbitp extends Primitive +{ + private logbitp() + { + super("logbitp", "index integer"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + int index = -1; + if (first instanceof Fixnum) { + index = ((Fixnum)first).value; + } else if (first instanceof Bignum) { + // FIXME If the number is really big, we're not checking the right + // bit... + if (((Bignum)first).value.signum() > 0) + index = Integer.MAX_VALUE; + } + if (index < 0) + return type_error(first, Symbol.UNSIGNED_BYTE); + BigInteger n; + if (second instanceof Fixnum) + n = ((Fixnum)second).getBigInteger(); + else if (second instanceof Bignum) + n = ((Bignum)second).value; + else + return type_error(second, Symbol.INTEGER); + // FIXME See above. + if (index == Integer.MAX_VALUE) + return n.signum() < 0 ? T : NIL; + return n.testBit(index) ? T : NIL; + } + + private static final Primitive LOGBITP = new logbitp(); +} Added: branches/save-image/src/org/armedbear/lisp/logcount.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logcount.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +/* + * logcount.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logcount.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logcount integer => number-of-on-bits +public final class logcount extends Primitive +{ + private logcount() + { + super("logcount","integer"); + } + + // FIXME Optimize fixnum case! + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + BigInteger n; + if (arg instanceof Fixnum) + n = ((Fixnum)arg).getBigInteger(); + else if (arg instanceof Bignum) + n = ((Bignum)arg).value; + else + return type_error(arg, Symbol.INTEGER); + return new Fixnum(n.bitCount()); + } + + private static final Primitive LOGCOUNT = new logcount(); +} Added: branches/save-image/src/org/armedbear/lisp/logeqv.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logeqv.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,86 @@ +/* + * logeqv.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logeqv.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logeqv +// logeqv &rest integers => result-integer +// equivalence (exclusive nor) +public final class logeqv extends Primitive +{ + private logeqv() + { + super("logeqv", "&rest integers"); + } + + @Override + public LispObject execute() + { + return Fixnum.MINUS_ONE; + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum) + return arg; + if (arg instanceof Bignum) + return arg; + return error(new TypeError(arg, Symbol.INTEGER)); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + BigInteger result = null; + for (int i = 0; i < args.length; i++) { + LispObject arg = args[i]; + BigInteger n; + if (arg instanceof Fixnum) + n = ((Fixnum)arg).getBigInteger(); + else if (arg instanceof Bignum) + n = ((Bignum)arg).value; + else + return error(new TypeError(arg, Symbol.INTEGER)); + if (result == null) + result = n; + else + result = result.xor(n).not(); + } + return number(result); + } + + private static final Primitive LOGEQV = new logeqv(); +} Added: branches/save-image/src/org/armedbear/lisp/logior.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logior.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,75 @@ +/* + * logior.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logior.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### logior &rest integers => result-integer +public final class logior extends Primitive +{ + private logior() + { + super("logior", "&rest integers"); + } + + @Override + public LispObject execute() + { + return Fixnum.ZERO; + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum || arg instanceof Bignum) + return arg; + return type_error(arg, Symbol.INTEGER); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.LOGIOR(second); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = Fixnum.ZERO; + for (int i = 0; i < args.length; i++) + result = result.LOGIOR(args[i]); + return result; + } + + private static final Primitive LOGIOR = new logior(); +} Added: branches/save-image/src/org/armedbear/lisp/lognand.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/lognand.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,76 @@ +/* + * lognand.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: lognand.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class lognand extends Primitive +{ + private lognand() + { + super("lognand", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum) { + if (second instanceof Fixnum) + return new Fixnum(~(((Fixnum)first).value & + ((Fixnum)second).value)); + if (second instanceof Bignum) { + BigInteger n1 = ((Fixnum)first).getBigInteger(); + BigInteger n2 = ((Bignum)second).value; + return number(n1.and(n2).not()); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + if (first instanceof Bignum) { + BigInteger n1 = ((Bignum)first).value; + if (second instanceof Fixnum) { + BigInteger n2 = ((Fixnum)second).getBigInteger(); + return number(n1.and(n2).not()); + } + if (second instanceof Bignum) { + BigInteger n2 = ((Bignum)second).value; + return number(n1.and(n2).not()); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + return error(new TypeError(first, Symbol.INTEGER)); + } + + private static final Primitive LOGNAND = new lognand(); +} Added: branches/save-image/src/org/armedbear/lisp/lognor.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/lognor.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,76 @@ +/* + * lognor.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: lognor.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +public final class lognor extends Primitive +{ + private lognor() + { + super("lognor", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum) { + if (second instanceof Fixnum) + return new Fixnum(~(((Fixnum)first).value | + ((Fixnum)second).value)); + if (second instanceof Bignum) { + BigInteger n1 = ((Fixnum)first).getBigInteger(); + BigInteger n2 = ((Bignum)second).value; + return number(n1.or(n2).not()); + } + return type_error(second, Symbol.INTEGER); + } + if (first instanceof Bignum) { + BigInteger n1 = ((Bignum)first).value; + if (second instanceof Fixnum) { + BigInteger n2 = ((Fixnum)second).getBigInteger(); + return number(n1.or(n2).not()); + } + if (second instanceof Bignum) { + BigInteger n2 = ((Bignum)second).value; + return number(n1.or(n2).not()); + } + return type_error(second, Symbol.INTEGER); + } + return type_error(first, Symbol.INTEGER); + } + + private static final Primitive LOGNOR = new lognor(); +} Added: branches/save-image/src/org/armedbear/lisp/lognot.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/lognot.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,53 @@ +/* + * lognot.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: lognot.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### lognot +public final class lognot extends Primitive +{ + private lognot(String name, String arglist) + { + super(name, arglist); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.LOGNOT(); + } + + private static final Primitive LOGNOT = new lognot("lognot", "integer"); +} Added: branches/save-image/src/org/armedbear/lisp/logorc1.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logorc1.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,79 @@ +/* + * logorc1.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: logorc1.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logorc1 +// logorc1 integer-1 integer-2 => result-integer +// or complement of integer-1 with integer-2 +public final class logorc1 extends Primitive +{ + private logorc1() + { + super("logorc1", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum) { + if (second instanceof Fixnum) + return new Fixnum(~((Fixnum)first).value | + ((Fixnum)second).value); + if (second instanceof Bignum) { + BigInteger n1 = ((Fixnum)first).getBigInteger(); + BigInteger n2 = ((Bignum)second).value; + return number(n1.not().or(n2)); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + if (first instanceof Bignum) { + BigInteger n1 = ((Bignum)first).value; + if (second instanceof Fixnum) { + BigInteger n2 = ((Fixnum)second).getBigInteger(); + return number(n1.not().or(n2)); + } + if (second instanceof Bignum) { + BigInteger n2 = ((Bignum)second).value; + return number(n1.not().or(n2)); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + return error(new TypeError(first, Symbol.INTEGER)); + } + + private static final Primitive LOGORC1 = new logorc1(); +} Added: branches/save-image/src/org/armedbear/lisp/logorc2.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logorc2.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,79 @@ +/* + * logorc2.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: logorc2.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logorc2 +// logorc2 integer-1 integer-2 => result-integer +// or integer-1 with complement of integer-2 +public final class logorc2 extends Primitive +{ + private logorc2() + { + super("logorc2", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum) { + if (second instanceof Fixnum) + return new Fixnum(((Fixnum)first).value | + ~((Fixnum)second).value); + if (second instanceof Bignum) { + BigInteger n1 = ((Fixnum)first).getBigInteger(); + BigInteger n2 = ((Bignum)second).value; + return number(n1.or(n2.not())); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + if (first instanceof Bignum) { + BigInteger n1 = ((Bignum)first).value; + if (second instanceof Fixnum) { + BigInteger n2 = ((Fixnum)second).getBigInteger(); + return number(n1.or(n2.not())); + } + if (second instanceof Bignum) { + BigInteger n2 = ((Bignum)second).value; + return number(n1.or(n2.not())); + } + return error(new TypeError(second, Symbol.INTEGER)); + } + return error(new TypeError(first, Symbol.INTEGER)); + } + + private static final Primitive LOGORC2 = new logorc2(); +} Added: branches/save-image/src/org/armedbear/lisp/logtest.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logtest.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,72 @@ +/* + * logtest.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logtest.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.math.BigInteger; + +// ### logtest integer-1 integer-2 => generalized-boolean +// (logtest x y) == (not (zerop (logand x y))) +public final class logtest extends Primitive +{ + private logtest() + { + super("logtest", "integer-1 integer-2"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + if (first instanceof Fixnum && second instanceof Fixnum) { + return (((Fixnum)first).value & ((Fixnum)second).value) == 0 ? NIL : T; + } else { + BigInteger n1, n2; + if (first instanceof Fixnum) + n1 = ((Fixnum)first).getBigInteger(); + else if (first instanceof Bignum) + n1 = ((Bignum)first).value; + else + return type_error(first, Symbol.INTEGER); + if (second instanceof Fixnum) + n2 = ((Fixnum)second).getBigInteger(); + else if (second instanceof Bignum) + n2 = ((Bignum)second).value; + else + return type_error(second, Symbol.INTEGER); + return n1.and(n2).signum() == 0 ? NIL : T; + } + } + + private static final Primitive LOGTEST = new logtest(); +} Added: branches/save-image/src/org/armedbear/lisp/logxor.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/logxor.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,75 @@ +/* + * logxor.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: logxor.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### logxor &rest integers => result-integer +public final class logxor extends Primitive +{ + private logxor() + { + super("logxor", "&rest integers"); + } + + @Override + public LispObject execute() + { + return Fixnum.ZERO; + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Fixnum || arg instanceof Bignum) + return arg; + return type_error(arg, Symbol.INTEGER); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.LOGXOR(second); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + LispObject result = Fixnum.ZERO; + for (int i = 0; i < args.length; i++) + result = result.LOGXOR(args[i]); + return result; + } + + private static final Primitive LOGXOR = new logxor(); +} Added: branches/save-image/src/org/armedbear/lisp/loop.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/loop.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,2095 @@ +;;; loop.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $Id: loop.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +;;;; the LOOP iteration macro + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. + +;;;; This code was modified by William Harold Newman beginning +;;;; 19981106, originally to conform to the new SBCL bootstrap package +;;;; system and then subsequently to address other cross-compiling +;;;; bootstrap issues, SBCLification (e.g. DECLARE used to check +;;;; argument types), and other maintenance. Whether or not it then +;;;; supported all the environments implied by the reader conditionals +;;;; in the source code (e.g. #!+CLOE-RUNTIME) before that +;;;; modification, it sure doesn't now. It might perhaps, by blind +;;;; luck, be appropriate for some other CMU-CL-derived system, but +;;;; really it only attempts to be appropriate for SBCL. + +;;;; This software is derived from software originally released by the +;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and +;;;; release statements follow. Later modifications to the software are in +;;;; the public domain and are provided with absolutely no warranty. See the +;;;; COPYING and CREDITS files for more information. + +;;;; Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute +;;;; of Technology. All Rights Reserved. +;;;; +;;;; Permission to use, copy, modify and distribute this software and its +;;;; documentation for any purpose and without fee is hereby granted, +;;;; provided that the M.I.T. copyright notice appear in all copies and that +;;;; both that copyright notice and this permission notice appear in +;;;; supporting documentation. The names "M.I.T." and "Massachusetts +;;;; Institute of Technology" may not be used in advertising or publicity +;;;; pertaining to distribution of the software without specific, written +;;;; prior permission. Notice must be given in supporting documentation that +;;;; copying distribution is by permission of M.I.T. M.I.T. makes no +;;;; representations about the suitability of this software for any purpose. +;;;; It is provided "as is" without express or implied warranty. +;;;; +;;;; Massachusetts Institute of Technology +;;;; 77 Massachusetts Avenue +;;;; Cambridge, Massachusetts 02139 +;;;; United States of America +;;;; +1-617-253-1000 + +;;;; Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, +;;;; Inc. All Rights Reserved. +;;;; +;;;; Permission to use, copy, modify and distribute this software and its +;;;; documentation for any purpose and without fee is hereby granted, +;;;; provided that the Symbolics copyright notice appear in all copies and +;;;; that both that copyright notice and this permission notice appear in +;;;; supporting documentation. The name "Symbolics" may not be used in +;;;; advertising or publicity pertaining to distribution of the software +;;;; without specific, written prior permission. Notice must be given in +;;;; supporting documentation that copying distribution is by permission of +;;;; Symbolics. Symbolics makes no representations about the suitability of +;;;; this software for any purpose. It is provided "as is" without express +;;;; or implied warranty. +;;;; +;;;; Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, +;;;; and Zetalisp are registered trademarks of Symbolics, Inc. +;;;; +;;;; Symbolics, Inc. +;;;; 8 New England Executive Park, East +;;;; Burlington, Massachusetts 01803 +;;;; United States of America +;;;; +1-617-221-1000 + +(in-package #:system) + +(defpackage "LOOP" (:use "COMMON-LISP")) + +(in-package "LOOP") + +;;;; The design of this LOOP is intended to permit, using mostly the same +;;;; kernel of code, up to three different "loop" macros: +;;;; +;;;; (1) The unextended, unextensible ANSI standard LOOP; +;;;; +;;;; (2) A clean "superset" extension of the ANSI LOOP which provides +;;;; functionality similar to that of the old LOOP, but "in the style of" +;;;; the ANSI LOOP. For instance, user-definable iteration paths, with a +;;;; somewhat cleaned-up interface. +;;;; +;;;; (3) Extensions provided in another file which can make this LOOP +;;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, +;;;; with only a small addition of code (instead of two whole, separate, +;;;; LOOP macros). +;;;; +;;;; Each of the above three LOOP variations can coexist in the same LISP +;;;; environment. +;;;; +;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality +;;;; for the other variants is wasted. -- WHN 20000121 + +;;;; FIXME: the STEP-FUNCTION stuff in the code seems to've been +;;;; intended to support code which was conditionalized with +;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been +;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too. + +;;;; list collection macrology + +(defmacro with-loop-list-collection-head + ((head-var tail-var &optional user-head-var) &body body) + (let ((l (and user-head-var (list (list user-head-var nil))))) + `(let* ((,head-var (list nil)) (,tail-var ,head-var) , at l) + , at body))) + +(defmacro loop-collect-rplacd + (&environment env (head-var tail-var &optional user-head-var) form) + (setq form (macroexpand form env)) + (flet ((cdr-wrap (form n) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) + (let ((tail-form form) (ncdrs nil)) + ;; Determine whether the form being constructed is a list of known + ;; length. + (when (consp form) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form))))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) + (let ((answer + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;; @@@@ Here we have a choice of two idioms: + ;; (RPLACD TAIL (SETQ TAIL TAIL-FORM)) + ;; (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)). + ;; Genera and most others I have seen do better with the + ;; former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) + ,tail-form) + ncdrs)))))) + ;; If not using locatives or something similar to update the + ;; user's head variable, we've got to set it... It's harmless + ;; to repeatedly set it unconditionally, and probably faster + ;; than checking. + (when user-head-var + (setq answer + `(progn ,answer + (setq ,user-head-var (cdr ,head-var))))) + answer)))) + +(defmacro loop-collect-answer (head-var + &optional user-head-var) + (or user-head-var + `(cdr ,head-var))) + +;;;; maximization technology + +#| +The basic idea of all this minimax randomness here is that we have to +have constructed all uses of maximize and minimize to a particular +"destination" before we can decide how to code them. The goal is to not +have to have any kinds of flags, by knowing both that (1) the type is +something which we can provide an initial minimum or maximum value for +and (2) know that a MAXIMIZE and MINIMIZE are not being combined. + +SO, we have a datastructure which we annotate with all sorts of things, +incrementally updating it as we generate loop body code, and then use +a wrapper and internal macros to do the coding when the loop has been +constructed. +|# + +(defstruct (loop-minimax + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) + answer-variable + type + temp-variable + flag-variable + operations + infinity-data) + +(defvar *loop-minimax-type-infinities-alist* + ;; FIXME: Now that SBCL supports floating point infinities again, we + ;; should have floating point infinities here, as cmucl-2.4.8 did. + '((fixnum most-positive-fixnum most-negative-fixnum))) + +(defun make-loop-minimax (answer-variable type) + (let ((infinity-data (cdr (assoc type + *loop-minimax-type-infinities-alist* + :test #'subtypep)))) + (make-loop-minimax-internal + :answer-variable answer-variable + :type type + :temp-variable (gensym "LOOP-MAXMIN-TEMP-") + :flag-variable (and (not infinity-data) + (gensym "LOOP-MAXMIN-FLAG-")) + :operations nil + :infinity-data infinity-data))) + +(defun loop-note-minimax-operation (operation minimax) + (pushnew (the symbol operation) (loop-minimax-operations minimax)) + (when (and (cdr (loop-minimax-operations minimax)) + (not (loop-minimax-flag-variable minimax))) + (setf (loop-minimax-flag-variable minimax) + (gensym "LOOP-MAXMIN-FLAG-"))) + operation) + +(defmacro with-minimax-value (lm &body body) + (let ((init (loop-typed-init (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) + (if flag-var + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + , at body) + `(let ((,answer-var ,(if (eq which 'min) + (first infinity-data) + (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + , at body)))) + +(defmacro loop-accumulate-minimax-value (lm operation form) + (let* ((answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var))) + `(progn + (setq ,temp-var ,form) + (when ,(if flag-var `(or (not ,flag-var) ,test) test) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) + +;;;; LOOP keyword tables + +#| +LOOP keyword tables are hash tables string keys and a test of EQUAL. + +The actual descriptive/dispatch structure used by LOOP is called a "loop +universe" contains a few tables and parameterizations. The basic idea is +that we can provide a non-extensible ANSI-compatible loop environment, +an extensible ANSI-superset loop environment, and (for such environments +as CLOE) one which is "sufficiently close" to the old Genera-vintage +LOOP for use by old user programs without requiring all of the old LOOP +code to be loaded. +|# + +;;;; token hackery + +;;; Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, +;;; the second a symbol to check against. +(defun loop-tequal (x1 x2) + (and (symbolp x1) (string= x1 x2))) + +(defun loop-tassoc (kwd alist) + (and (symbolp kwd) (assoc kwd alist :test #'string=))) + +(defun loop-tmember (kwd list) + (and (symbolp kwd) (member kwd list :test #'string=))) + +(defun loop-lookup-keyword (loop-token table) + (and (symbolp loop-token) + (values (gethash (symbol-name (the symbol loop-token)) table)))) + +(defmacro loop-store-table-data (symbol table datum) + `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) + +(defstruct (loop-universe + (:copier nil) + (:predicate nil)) + keywords ; hash table, value = (fn-name . extra-data) + iteration-keywords ; hash table, value = (fn-name . extra-data) + for-keywords ; hash table, value = (fn-name . extra-data) + path-keywords ; hash table, value = (fn-name . extra-data) + type-symbols ; hash table of type SYMBOLS, test EQ, + ; value = CL type specifier + type-keywords ; hash table of type STRINGS, test EQUAL, + ; value = CL type spec + ansi ; NIL, T, or :EXTENDED + implicit-for-required) ; see loop-hack-iteration + +#+sbcl +(sb!int:def!method print-object ((u loop-universe) stream) + (let ((string (case (loop-universe-ansi u) + ((nil) "non-ANSI") + ((t) "ANSI") + (:extended "extended-ANSI") + (t (loop-universe-ansi u))))) + (print-unreadable-object (u stream :type t) + (write-string string stream)))) + +;;; This is the "current" loop context in use when we are expanding a +;;; loop. It gets bound on each invocation of LOOP. +(defvar *loop-universe*) + +(defun make-standard-loop-universe (&key keywords for-keywords + iteration-keywords path-keywords + type-keywords type-symbols ansi) + (declare (type (member nil t :extended) ansi)) + (flet ((maketable (entries) + (let* ((size (length entries)) + (ht (make-hash-table :size (if (< size 10) 10 size) + :test 'equal))) + (dolist (x entries) + (setf (gethash (symbol-name (car x)) ht) (cadr x))) + ht))) + (make-loop-universe + :keywords (maketable keywords) + :for-keywords (maketable for-keywords) + :iteration-keywords (maketable iteration-keywords) + :path-keywords (maketable path-keywords) + :ansi ansi + :implicit-for-required (not (null ansi)) + :type-keywords (maketable type-keywords) + :type-symbols (let* ((size (length type-symbols)) + (ht (make-hash-table :size (if (< size 10) 10 size) + :test 'eq))) + (dolist (x type-symbols) + (if (atom x) + (setf (gethash x ht) x) + (setf (gethash (car x) ht) (cadr x)))) + ht)))) + +;;;; SETQ hackery, including destructuring ("DESETQ") + +(defun loop-make-psetq (frobs) + (and frobs + (loop-make-desetq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) + +(defun loop-make-desetq (var-val-pairs) + (if (null var-val-pairs) + nil + (cons 'loop-really-desetq var-val-pairs))) + +(defvar *loop-desetq-temporary* + (make-symbol "LOOP-DESETQ-TEMP")) + +(defmacro loop-really-desetq (&environment env + &rest var-val-pairs) + (labels ((find-non-null (var) + ;; See whether there's any non-null thing here. Recurse + ;; if the list element is itself a list. + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; Don't lose possible side effects. + (if (eq (car val) 'prog1) + ;; These can come from PSETQ or DESETQ below. + ;; Throw away the value, keep the side effects. + ;; Special case is for handling an expanded POP. + (mapcan (lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body `(,@(loop-desetq-internal car + `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr + temp + temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + , at body) + `((let ((,temp ,val)) + , at body)))) + ;; no CDRing to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) + (do ((actions)) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + (setq actions (revappend + (loop-desetq-internal (pop var-val-pairs) + (pop var-val-pairs)) + actions))))) + +;;;; LOOP-local variables + +;;; This is the "current" pointer into the LOOP source code. +(defvar *loop-source-code*) + +;;; This is the pointer to the original, for things like NAMED that +;;; insist on being in a particular position +(defvar *loop-original-source-code*) + +;;; This is *loop-source-code* as of the "last" clause. It is used +;;; primarily for generating error messages (see loop-error, loop-warn). +(defvar *loop-source-context*) + +;;; list of names for the LOOP, supplied by the NAMED clause +(defvar *loop-names*) + +;;; The macroexpansion environment given to the macro. +(defvar *loop-macro-environment*) + +;;; This holds variable names specified with the USING clause. +;;; See LOOP-NAMED-VAR. +(defvar *loop-named-vars*) + +;;; LETlist-like list being accumulated for one group of parallel bindings. +(defvar *loop-vars*) + +;;; list of declarations being accumulated in parallel with *LOOP-VARS* +(defvar *loop-declarations*) + +;;; This is used by LOOP for destructuring binding, if it is doing +;;; that itself. See LOOP-MAKE-VAR. +(defvar *loop-desetq-crocks*) + +;;; list of wrapping forms, innermost first, which go immediately +;;; inside the current set of parallel bindings being accumulated in +;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably have as its value +;;; ((WITH-OPEN-FILE (G0001 G0002 ...))), +;;; with G0002 being one of the bindings in *LOOP-VARS* (This is +;;; why the wrappers go inside of the variable bindings). +(defvar *loop-wrappers*) + +;;; This accumulates lists of previous values of *LOOP-VARS* and +;;; the other lists above, for each new nesting of bindings. See +;;; LOOP-BIND-BLOCK. +(defvar *loop-bind-stack*) + +;;; This is simply a list of LOOP iteration variables, used for +;;; checking for duplications. +(defvar *loop-iteration-vars*) + +;;; list of prologue forms of the loop, accumulated in reverse order +(defvar *loop-prologue*) + +(defvar *loop-before-loop*) +(defvar *loop-body*) +(defvar *loop-after-body*) + +;;; This is T if we have emitted any body code, so that iteration +;;; driving clauses can be disallowed. This is not strictly the same +;;; as checking *LOOP-BODY*, because we permit some clauses such as +;;; RETURN to not be considered "real" body (so as to permit the user +;;; to "code" an abnormal return value "in loop"). +(defvar *loop-emitted-body*) + +;;; list of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order +(defvar *loop-epilogue*) + +;;; list of epilogue forms which are supplied after the above "user" +;;; epilogue. "Normal" termination return values are provide by +;;; putting the return form in here. Normally this is done using +;;; LOOP-EMIT-FINAL-VALUE, q.v. +(defvar *loop-after-epilogue*) + +;;; the "culprit" responsible for supplying a final value from the +;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple +;;; return values being supplied. +(defvar *loop-final-value-culprit*) + +;;; If this is true, we are in some branch of a conditional. Some +;;; clauses may be disallowed. +(defvar *loop-inside-conditional*) + +;;; If not NIL, this is a temporary bound around the loop for holding +;;; the temporary value for "it" in things like "when (f) collect it". +;;; It may be used as a supertemporary by some other things. +(defvar *loop-when-it-var*) + +;;; Sometimes we decide we need to fold together parts of the loop, +;;; but some part of the generated iteration code is different for the +;;; first and remaining iterations. This variable will be the +;;; temporary which is the flag used in the loop to tell whether we +;;; are in the first or remaining iterations. +(defvar *loop-never-stepped-var*) + +;;; list of all the value-accumulation descriptor structures in the +;;; loop. See LOOP-GET-COLLECTION-INFO. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc.) + +;;;; code analysis stuff + +(defun loop-constant-fold-if-possible (form &optional expected-type) + (let ((new-form form) (constantp nil) (constant-value nil)) + (when (setq constantp (constantp new-form)) + (setq constant-value (eval new-form))) + (when (and constantp expected-type) + (unless (typep constant-value expected-type) + (loop-warn "~@" + form constant-value expected-type) + (setq constantp nil constant-value nil))) + (values new-form constantp constant-value))) + +(defun loop-constantp (form) + (constantp form)) + +;;;; LOOP iteration optimization + +(defvar *loop-duplicate-code* + nil) + +(defvar *loop-iteration-flag-var* + (make-symbol "LOOP-NOT-FIRST-TIME")) + +(defun loop-code-duplication-threshold (env) + (declare (ignore env)) + (let (;; If we could read optimization declaration information (as + ;; with the DECLARATION-INFORMATION function (present in + ;; CLTL2, removed from ANSI standard) we could set these + ;; values flexibly. Without DECLARATION-INFORMATION, we have + ;; to set them to constants. + ;; + ;; except FIXME: we've lost all pretence of portability, + ;; considering this instead an internal implementation, so + ;; we're free to couple to our own representation of the + ;; environment. + (speed 1) + (space 1)) + (+ 40 (* (- speed space) 10)))) + +(defmacro loop-body (&environment env + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) + (unless (= (length before-loop) (length after-loop)) + (error "LOOP-BODY called with non-synched before- and after-loop lists")) + ;;All our work is done from these copies, working backwards from the end: + (setq rbefore (reverse before-loop) rafter (reverse after-loop)) + (labels ((psimp (l) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) + (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn , at l))) + (makebody () + (let ((form `(tagbody + ,@(psimp (append prologue (nreverse rbefore))) + next-loop + ,@(psimp (append main-body + (nreconc rafter + `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (when (or *loop-duplicate-code* (not rbefore)) + (return-from loop-body (makebody))) + ;; This outer loop iterates once for each not-first-time flag test + ;; generated plus once more for the forms that don't need a flag test. + (do ((threshold (loop-code-duplication-threshold env))) (nil) + (declare (fixnum threshold)) + ;; Go backwards from the ends of before-loop and after-loop + ;; merging all the equivalent forms into the body. + (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) + (push (pop rbefore) main-body) + (pop rafter)) + (unless rbefore (return (makebody))) + ;; The first forms in RBEFORE & RAFTER (which are the + ;; chronologically last forms in the list) differ, therefore + ;; they cannot be moved into the main body. If everything that + ;; chronologically precedes them either differs or is equal but + ;; is okay to duplicate, we can just put all of rbefore in the + ;; prologue and all of rafter after the body. Otherwise, there + ;; is something that is not okay to duplicate, so it and + ;; everything chronologically after it in rbefore and rafter + ;; must go into the body, with a flag test to distinguish the + ;; first time around the loop from later times. What + ;; chronologically precedes the non-duplicatable form will be + ;; handled the next time around the outer loop. + (do ((bb rbefore (cdr bb)) + (aa rafter (cdr aa)) + (lastdiff nil) + (count 0) + (inc nil)) + ((null bb) (return-from loop-body (makebody))) ; Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. + ;; Everything chronologically after it must be in the + ;; central body. Everything chronologically at and + ;; after LASTDIFF goes into the central body under a + ;; flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-var*) + t) + else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the + ;; non-duplicatable form (CAR BB) is the same in + ;; RBEFORE and RAFTER, so just copy it into the body. + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) + +(defun duplicatable-code-p (expr env) + (if (null expr) 0 + (let ((ans (estimate-code-size expr env))) + (declare (fixnum ans)) + ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to + ;; get an alist of optimize quantities back to help quantify + ;; how much code we are willing to duplicate. + ans))) + +(defvar *special-code-sizes* + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) + (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + +(defvar *estimate-code-size-punt* + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) + +(defun destructuring-size (x) + (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) + ((atom x) (+ n (if (null x) 0 1))))) + +(defun estimate-code-size (x env) + (catch 'estimate-code-size + (estimate-code-size-1 x env))) + +(defun estimate-code-size-1 (x env) + (flet ((list-size (l) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + ;;@@@@ ???? (declare (function list-size (list) fixnum)) + (cond ((constantp x) 1) + ((symbolp x) (multiple-value-bind (new-form expanded-p) + (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + 1))) + ((atom x) 1) ;; ??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum + (list-size ,(if args-p + args + '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) + (f (second tem))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) + (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n + (destructuring-size (car l)) + (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + (if #+sbcl + (sb!int:legal-fun-name-p (cadr x)) + #+armedbear + (or (symbolp (cadr x)) + (and (consp (cadr x)) (eq (caadr x) 'setf))) + 1 + ;; FIXME: This tag appears not to be present + ;; anywhere. + (throw 'duplicatable-code-p nil))) + ((eq fn 'multiple-value-setq) + (f (length (second x)) (cddr x))) + ((eq fn 'return-from) + (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) + (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) + (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) + +;;;; loop errors + +(defun loop-context () + (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) + ((eq l (cdr *loop-source-code*)) (nreverse new)))) + +(defun loop-error (format-string &rest format-args) + (error 'program-error + :format-control "~?~%Current LOOP context:~{ ~S~}." + :format-arguments (list format-string format-args (loop-context)))) + +(defun loop-warn (format-string &rest format-args) + (warn "~?~%Current LOOP context:~{ ~S~}." + format-string + format-args + (loop-context))) + +(defun loop-check-data-type (specified-type required-type + &optional (default-type required-type)) + (if (null specified-type) + default-type + (multiple-value-bind (a b) (subtypep specified-type required-type) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "The specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) + +(defun subst-gensyms-for-nil (tree) + (declare (special *ignores*)) + (cond + ((null tree) + (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*))) + ((atom tree) + tree) + (t + (cons (subst-gensyms-for-nil (car tree)) + (subst-gensyms-for-nil (cdr tree)))))) + +(defmacro loop-destructuring-bind + (lambda-list arg-list &rest body) + (let ((*ignores* nil)) + (declare (special *ignores*)) + (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list))) + `(destructuring-bind ,d-var-lambda-list + ,arg-list + (declare (ignore ,@*ignores*)) + , at body)))) + +(defun loop-build-destructuring-bindings (crocks forms) + (if crocks + `((loop-destructuring-bind ,(car crocks) ,(cadr crocks) + ,@(loop-build-destructuring-bindings (cddr crocks) forms))) + forms)) + +(defun loop-translate (*loop-source-code* + *loop-macro-environment* + *loop-universe*) + (let ((*loop-original-source-code* *loop-source-code*) + (*loop-source-context* nil) + (*loop-iteration-vars* nil) + (*loop-vars* nil) + (*loop-named-vars* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-var* nil) + (*loop-never-stepped-var* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) + (loop-iteration-driver) + (loop-bind-block) + (let ((answer `(loop-body + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* + (nreverse *loop-after-epilogue*))))) + (dolist (entry *loop-bind-stack*) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare , at dcls) forms)) + (setq answer `(,(if vars 'let 'locally) + ,vars + ,@(loop-build-destructuring-bindings crocks + forms))))))) + (do () (nil) + (setq answer `(block ,(pop *loop-names*) ,answer)) + (unless *loop-names* (return nil))) + answer))) + +(defun loop-iteration-driver () + (do () ((null *loop-source-code*)) + (let ((keyword (car *loop-source-code*)) (tem nil)) + (cond ((not (symbolp keyword)) + (loop-error "~S found where LOOP keyword expected" keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem + (loop-lookup-keyword keyword + (loop-universe-keywords + *loop-universe*))) + ;; It's a "miscellaneous" toplevel LOOP keyword (DO, + ;; COLLECT, NAMED, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem + (loop-lookup-keyword keyword + (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; The alternative is to ignore it, i.e. let it go + ;; around to the next keyword... + (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword + (car *loop-source-code*) + (cadr *loop-source-code*))) + (t (loop-error "unknown LOOP keyword: ~S" keyword)))))))) + +(defun loop-pop-source () + (if *loop-source-code* + (pop *loop-source-code*) + (loop-error "LOOP source code ran out when another token was expected."))) + +(defun loop-get-form () + (if *loop-source-code* + (loop-pop-source) + (loop-error "LOOP code ran out where a form was expected."))) + +(defun loop-get-compound-form () + (let ((form (loop-get-form))) + (unless (consp form) + (loop-error "A compound form was expected, but ~S found." form)) + form)) + +(defun loop-get-progn () + (do ((forms (list (loop-get-compound-form)) + (cons (loop-get-compound-form) forms)) + (nextform (car *loop-source-code*) + (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + +(defun loop-construct-return (form) + `(return-from ,(car *loop-names*) ,form)) + +(defun loop-pseudo-body (form) + (cond ((or *loop-emitted-body* *loop-inside-conditional*) + (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + +(defun loop-emit-body (form) + (setq *loop-emitted-body* t) + (loop-pseudo-body form)) + +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) + (when *loop-final-value-culprit* + (loop-warn "The LOOP clause is providing a value for the iteration;~@ + however, one was already established by a ~S clause." + *loop-final-value-culprit*)) + (setq *loop-final-value-culprit* (car *loop-source-context*))) + +(defun loop-disallow-conditional (&optional kwd) + (when *loop-inside-conditional* + (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) + +;;;; loop types + +(defun loop-typed-init (data-type &optional step-var-p) + (when (and data-type (subtypep data-type 'number)) + (if (or (subtypep data-type 'float) + (subtypep data-type '(complex float))) + (coerce (if step-var-p 1 0) data-type) + (if step-var-p 1 0)))) + +(defun loop-optional-type (&optional variable) + ;; No variable specified implies that no destructuring is permissible. + (and *loop-source-code* ; Don't get confused by NILs.. + (let ((z (car *loop-source-code*))) + (cond ((loop-tequal z 'of-type) + ;; This is the syntactically unambigous form in that + ;; the form of the type specifier does not matter. + ;; Also, it is assumed that the type specifier is + ;; unambiguously, and without need of translation, a + ;; common lisp type specifier or pattern (matching the + ;; variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;; This is the (sort of) "old" syntax, even though we + ;; didn't used to support all of these type symbols. + (let ((type-spec (or (gethash z + (loop-universe-type-symbols + *loop-universe*)) + (gethash (symbol-name z) + (loop-universe-type-keywords + *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;; This is our sort-of old syntax. But this is only + ;; valid for when we are destructuring, so we will be + ;; compulsive (should we really be?) and require that + ;; we in fact be doing variable destructuring here. We + ;; must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type + ;; specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected" + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k + (loop-universe-type-symbols + *loop-universe*)) + (gethash (symbol-name k) + (loop-universe-type-keywords + *loop-universe*)) + (loop-error + "The destructuring type pattern ~S contains the unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "The destructuring type pattern ~S doesn't match the variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) + (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) + typ + (cons (replicate typ (car v)) + (replicate typ (cdr v)))))) + (translate z variable))))))) + +;;;; loop variables + +(defun loop-bind-block () + (when (or *loop-vars* *loop-declarations* *loop-wrappers*) + (push (list (nreverse *loop-vars*) + *loop-declarations* + *loop-desetq-crocks* + *loop-wrappers*) + *loop-bind-stack*) + (setq *loop-vars* nil + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) + +(defun loop-var-p (name) + (do ((entry *loop-bind-stack* (cdr entry))) + (nil) + (cond + ((null entry) (return nil)) + ((assoc name (caar entry) :test #'eq) (return t))))) + +(defun loop-make-var (name initialization dtype &optional iteration-var-p step-var-p) + (cond ((null name) + (setq name (gensym "LOOP-IGNORE-")) + (push (list name initialization) *loop-vars*) + (if (null initialization) + (push `(ignore ,name) *loop-declarations*) + (loop-declare-var name dtype))) + ((atom name) + (cond (iteration-var-p + (if (member name *loop-iteration-vars*) + (loop-error "duplicated LOOP iteration variable ~S" name) + (push name *loop-iteration-vars*))) + ((assoc name *loop-vars*) + (loop-error "duplicated variable ~S in LOOP parallel binding" + name))) + (unless (symbolp name) + (loop-error "bad variable ~S somewhere in LOOP" name)) + (loop-declare-var name dtype step-var-p) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name (or initialization (loop-typed-init dtype step-var-p))) + *loop-vars*)) + (initialization + (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) + (loop-declare-var name dtype) + (push (list newvar initialization) *loop-vars*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-var (car name) nil tcar iteration-var-p) + (loop-make-var (cdr name) nil tcdr iteration-var-p)))) + name) + +(defun loop-make-iteration-var (name initialization dtype) + (when (and name (loop-var-p name)) + (loop-error "Variable ~S has already been used." name)) + (loop-make-var name initialization dtype t)) + +(defun loop-declare-var (name dtype &optional step-var-p) + (cond ((or (null name) (null dtype) (eq dtype t)) nil) + ((symbolp name) + (unless (subtypep t dtype) + (let ((dtype (let ((init (loop-typed-init dtype step-var-p))) + (if (typep init dtype) + dtype + `(or (member ,init) ,dtype))))) + (push `(type ,dtype ,name) *loop-declarations*)))) + ((consp name) + (cond ((consp dtype) + (loop-declare-var (car name) (car dtype)) + (loop-declare-var (cdr name) (cdr dtype))) + (t (loop-declare-var (car name) dtype) + (loop-declare-var (cdr name) dtype)))) + (t (error "invalid LOOP variable passed in: ~S" name)))) + +(defun loop-maybe-bind-form (form data-type) + (if (loop-constantp form) + form + (loop-make-var (gensym "LOOP-BIND-") form data-type))) + +(defun loop-do-if (for negatep) + (let ((form (loop-get-form)) + (*loop-inside-conditional* t) + (it-p nil) + (first-clause-p t)) + (flet ((get-clause (for) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S" + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p + (setq it-p + (loop-when-it-var))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) + (cdr data)) + (null *loop-body*))) + (loop-error + "~S does not introduce a LOOP clause that can follow ~S." + key for)) + (t (setq body (nreconc *loop-body* body))))))) + (setq first-clause-p nil) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (if (cdr body) + `(progn ,@(nreverse body)) + (car body))))))) + (let ((then (get-clause for)) + (else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) + (when (loop-tequal (car *loop-source-code*) :end) + (loop-pop-source)) + (when it-p (setq form `(setq ,it-p ,form))) + (loop-pseudo-body + `(if ,(if negatep `(not ,form) form) + ,then + , at else)))))) + +(defun loop-do-initially () + (loop-disallow-conditional :initially) + (push (loop-get-progn) *loop-prologue*)) + +(defun loop-do-finally () + (loop-disallow-conditional :finally) + (push (loop-get-progn) *loop-epilogue*)) + +(defun loop-do-do () + (loop-emit-body (loop-get-progn))) + +(defun loop-do-named () + (let ((name (loop-pop-source))) + (unless (symbolp name) + (loop-error "~S is an invalid name for your LOOP" name)) + (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) + (loop-error "The NAMED ~S clause occurs too late." name)) + (when *loop-names* + (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." + (car *loop-names*) name)) + (setq *loop-names* (list name)))) + +(defun loop-do-return () + (loop-emit-body (loop-construct-return (loop-get-form)))) + +;;;; value accumulation: LIST + +(defstruct (loop-collector + (:copier nil) + (:predicate nil)) + name + class + (history nil) + (tempvars nil) + dtype + (data nil)) ;collector-specific data + +(defun loop-get-collection-info (collector class default-type) + (let ((form (loop-get-form)) + (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) + (when (not (symbolp name)) + (loop-error "The value accumulation recipient name, ~S, is not a symbol." name)) + (unless name + (loop-disallow-aggregate-booleans)) + (unless dtype + (setq dtype (or (loop-optional-type) default-type))) + (let ((cruft (find (the symbol name) *loop-collection-cruft* + :key #'loop-collector-name))) + (cond ((not cruft) + (when (and name (loop-var-p name)) + (loop-error "Variable ~S in INTO clause is a duplicate" name)) + (push (setq cruft (make-loop-collector + :name name :class class + :history (list collector) :dtype dtype)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "incompatible kinds of LOOP value accumulation specified for collecting~@ + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "unequal datatypes specified in different LOOP value accumulations~@ + into ~S: ~S and ~S" + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) + (values cruft form)))) + +(defun loop-list-collection (specifically) ; NCONC, LIST, or APPEND + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'list 'list) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (gensym "LOOP-LIST-HEAD-") + (gensym "LOOP-LIST-TAIL-") + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) + ,@(cddr tempvars))))) + (ecase specifically + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(copy-list ,form))))) + (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) + +;;;; value accumulation: MAX, MIN, SUM, COUNT + +(defun loop-sum-collection (specifically required-type default-type);SUM, COUNT + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'sum default-type) + (loop-check-data-type (loop-collector-dtype lc) required-type) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-var + (or (loop-collector-name lc) + (gensym "LOOP-SUM-")) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (loop-emit-body + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + (1+ ,(car tempvars)))) + `(setq ,(car tempvars) + (+ ,(car tempvars) + ,form))))))) + +(defun loop-maxmin-collection (specifically) + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'maxmin 'real) + (loop-check-data-type (loop-collector-dtype lc) 'real) + (let ((data (loop-collector-data lc))) + (unless data + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) + (gensym "LOOP-MAXMIN-")) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) + (loop-note-minimax-operation specifically data) + (push `(with-minimax-value ,data) *loop-wrappers*) + (loop-emit-body `(loop-accumulate-minimax-value ,data + ,specifically + ,form))))) + +;;;; value accumulation: aggregate booleans + +;;; handling the ALWAYS and NEVER loop keywords +;;; +;;; Under ANSI these are not permitted to appear under conditionalization. +(defun loop-do-always (restrictive negate) + (let ((form (loop-get-form))) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-body `(,(if negate 'when 'unless) ,form + ,(loop-construct-return nil))) + (loop-emit-final-value t))) + +;;; handling the THEREIS loop keyword +;;; +;;; Under ANSI this is not permitted to appear under conditionalization. +(defun loop-do-thereis (restrictive) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-final-value) + (loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form)) + ,(loop-construct-return *loop-when-it-var*)))) + +(defun loop-do-while (negate kwd &aux (form (loop-get-form))) + (loop-disallow-conditional kwd) + (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) + +(defun loop-do-repeat () + (loop-disallow-conditional :repeat) + (let ((form (loop-get-form)) + (type 'integer)) + (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type))) + (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*) + (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*) + ;; FIXME: What should + ;; (loop count t into a + ;; repeat 3 + ;; count t into b + ;; finally (return (list a b))) + ;; return: (3 3) or (4 3)? PUSHes above are for the former + ;; variant, L-P-B below for the latter. + #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop)))))) + +(defun loop-do-with () + (loop-disallow-conditional :with) + (do ((var) (val) (dtype)) (nil) + (setq var (loop-pop-source) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (loop-pop-source) + (loop-get-form)) + (t nil))) + (when (and var (loop-var-p var)) + (loop-error "Variable ~S has already been used" var)) + (loop-make-var var val dtype) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (loop-bind-block))))) + +;;;; the iteration driver + +(defun loop-hack-iteration (entry) + (flet ((make-endtest (list-of-forms) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms + (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) + (do ((pre-step-tests nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) + ;; Note that we collect endtests in reverse order, but steps in correct + ;; order. MAKE-ENDTEST does the nreverse for us. + (setq tem (setq data + (apply (symbol-function (first entry)) (rest entry)))) + (and (car tem) (push (car tem) pre-step-tests)) + (setq steps (nconc steps (copy-list (car (setq tem (cdr tem)))))) + (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) + (setq pseudo-steps + (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) + (setq tem (cdr tem)) + (when *loop-emitted-body* + (loop-error "iteration in LOOP follows body code")) + (unless tem (setq tem data)) + (when (car tem) (push (car tem) pre-loop-pre-step-tests)) + ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough + ;; that it might be worth making it into an NCONCF macro. + (setq pre-loop-steps + (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) + (when (car (setq tem (cdr tem))) + (push (car tem) pre-loop-post-step-tests)) + (setq pre-loop-pseudo-steps + (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) + (unless (loop-tequal (car *loop-source-code*) :and) + (setq *loop-before-loop* + (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*)) + (setq *loop-after-body* + (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source) ; Flush the "AND". + (when (and (not (loop-universe-implicit-for-required *loop-universe*)) + (setq tem + (loop-lookup-keyword + (car *loop-source-code*) + (loop-universe-iteration-keywords *loop-universe*)))) + ;; The latest ANSI clarification is that the FOR/AS after the AND must + ;; NOT be supplied. + (loop-pop-source) + (setq entry tem))))) + +;;;; main iteration drivers + +;;; FOR variable keyword ..args.. +(defun loop-do-for () + (let* ((var (loop-pop-source)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) + (setq first-arg (loop-get-form)) + (unless (and (symbolp keyword) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) + (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." + keyword)) + (apply (car tem) var first-arg data-type (cdr tem)))) + +(defun loop-when-it-var () + (or *loop-when-it-var* + (setq *loop-when-it-var* + (loop-make-var (gensym "LOOP-IT-") nil nil)))) + +;;;; various FOR/AS subdispatches + +;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when +;;; the THEN is omitted (other than being more stringent in its +;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN +;;; is present. I.e., the first initialization occurs in the loop body +;;; (first-step), not in the variable binding phase. +(defun loop-ansi-for-equals (var val data-type) + (loop-make-iteration-var var nil data-type) + (cond ((loop-tequal (car *loop-source-code*) :then) + ;; Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;; We are the same as "FOR x = y". + `(() (,var ,val) () ())))) + +(defun loop-for-across (var val data-type) + (loop-make-iteration-var var nil data-type) + (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-")) + (index-var (gensym "LOOP-ACROSS-INDEX-"))) + (multiple-value-bind (vector-form constantp vector-value) + (loop-constant-fold-if-possible val 'vector) + (loop-make-var + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) + (loop-make-var index-var 0 'fixnum) + (let* ((length 0) + (length-form (cond ((not constantp) + (let ((v (gensym "LOOP-ACROSS-LIMIT-"))) + (push `(setq ,v (length ,vector-var)) + *loop-prologue*) + (loop-make-var v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) + `(,first-test ,step () ,pstep))))))) + +;;;; list iteration + +(defun loop-list-step (listvar) + ;; We are not equipped to analyze whether 'FOO is the same as #'FOO + ;; here in any sensible fashion, so let's give an obnoxious warning + ;; whenever 'FOO is used as the stepping function. + ;; + ;; While a Discerning Compiler may deal intelligently with + ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP + ;; optimizations. + (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) + (cond ((and (consp stepper) (eq (car stepper) 'quote)) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + `(funcall ,stepper ,listvar)) + ((and (consp stepper) (eq (car stepper) 'function)) + (list (cadr stepper) listvar)) + (t + `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) + ,listvar))))) + +(defun loop-for-on (var val data-type) + (multiple-value-bind (list constantp list-value) + (loop-constant-fold-if-possible val) + (let ((listvar var)) + (cond ((and var (symbolp var)) + (loop-make-iteration-var var list data-type)) + (t (loop-make-var (setq listvar (gensym)) list 'list) + (loop-make-iteration-var var nil data-type))) + (let ((list-step (loop-list-step listvar))) + (let* ((first-endtest + ;; mysterious comment from original CMU CL sources: + ;; the following should use `atom' instead of `endp', + ;; per [bug2428] + `(atom ,listvar)) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;; The contour of the loop is different because we + ;; use the user's variable... + `(() (,listvar ,list-step) + ,other-endtest () () () ,first-endtest ())) + (t (let ((step `(,var ,listvar)) + (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) + +(defun loop-for-in (var val data-type) + (multiple-value-bind (list constantp list-value) + (loop-constant-fold-if-possible val) + (let ((listvar (gensym "LOOP-LIST-"))) + (loop-make-iteration-var var nil data-type) + (loop-make-var listvar list 'list) + (let ((list-step (loop-list-step listvar))) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) + +;;;; iteration paths + +(defstruct (loop-path + (:copier nil) + (:predicate nil)) + names + preposition-groups + inclusive-permitted + function + user-data) + +(defun add-loop-path (names function universe + &key preposition-groups inclusive-permitted user-data) + (declare (type loop-universe universe)) + (unless (listp names) + (setq names (list names))) + (let ((ht (loop-universe-path-keywords universe)) + (lp (make-loop-path + :names (mapcar #'symbol-name names) + :function function + :user-data user-data + :preposition-groups (mapcar (lambda (x) + (if (listp x) x (list x))) + preposition-groups) + :inclusive-permitted inclusive-permitted))) + (dolist (name names) + (setf (gethash (symbol-name name) ht) lp)) + lp)) + +;;; Note: Path functions are allowed to use LOOP-MAKE-VAR, hack +;;; the prologue, etc. +(defun loop-for-being (var val data-type) + ;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the = + ;; EACH or THE. Not clear if it is optional, so I guess we'll warn. + (let ((path nil) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) + (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) + '(:its :each :his :her)) + (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?"))) + (cond ((not (symbolp path)) + (loop-error + "~S was found where a LOOP iteration path name was expected." + path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (let ((fun (loop-path-function data)) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases + (loop-path-preposition-groups data) + t))) + (user-data (loop-path-user-data data))) + (when (symbolp fun) (setq fun (symbol-function fun))) + (setq stuff (if inclusive + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) + (when *loop-named-vars* + (loop-error "Unused USING vars: ~S." *loop-named-vars*)) + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). + ;; Protect the system from the user and the user from himself. + (unless (member (length stuff) '(6 10)) + (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." + path)) + (do ((l (car stuff) (cdr l)) (x)) ((null l)) + (if (atom (setq x (car l))) + (loop-make-iteration-var x nil nil) + (loop-make-iteration-var (car x) (cadr x) (caddr x)))) + (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) + (cddr stuff))) + +(defun loop-named-var (name) + (let ((tem (loop-tassoc name *loop-named-vars*))) + (declare (list tem)) + (cond ((null tem) (values (gensym) nil)) + (t (setq *loop-named-vars* (delete tem *loop-named-vars*)) + (values (cdr tem) t))))) + +(defun loop-collect-prepositional-phrases (preposition-groups + &optional + using-allowed + initial-phrases) + (flet ((in-group-p (x group) (car (loop-tmember x group)))) + (do ((token nil) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan (lambda (x) + (copy-list + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) + (declare (symbol this-prep)) + (setq token (car *loop-source-code*)) + (dolist (group preposition-groups) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) + (cond (this-group + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S was used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and using-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-vars*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ + with ~S and ~S." + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-vars*))) + (when (or (null *loop-source-code*) + (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) + +;;;; master sequencer function + +(defun loop-sequencer (indexv indexv-type + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) + (let ((endform nil) ; form (constant or variable) with limit value + (sequencep nil) ; T if sequence arg has been provided + (testfn nil) ; endtest function + (test nil) ; endtest form + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment + (stepby-constantp t) + (step nil) ; step form + (dir nil) ; direction of stepping: NIL, :UP, :DOWN + (inclusive-iteration nil) ; T if include last index + (start-given nil) ; T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ; T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) + (flet ((assert-index-for-arithmetic (index) + (unless (atom index) + (loop-error "Arithmetic index must be an atom.")))) + (when variable (loop-make-iteration-var variable nil variable-type)) + (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) + (setq prep (caar l) form (cadar l)) + (case prep + ((:of :in) + (setq sequencep t) + (loop-make-var sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (assert-index-for-arithmetic indexv) + ;; KLUDGE: loop-make-var generates a temporary symbol for + ;; indexv if it is NIL. We have to use it to have the index + ;; actually count + (setq indexv (loop-make-iteration-var indexv form indexv-type))) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration + (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration + (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form `(and ,indexv-type real))) + (setq endform (if limit-constantp + `',limit-value + (loop-make-var + (gensym "LOOP-LIMIT-") form + `(and ,indexv-type real))))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form `(and ,indexv-type (real (0))))) + (unless stepby-constantp + (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) + form + `(and ,indexv-type (real (0))) + nil t))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path;~@ + maybe invalid prepositions were specified in iteration path descriptor?" + prep))) + (when (and odir dir (not (eq dir odir))) + (loop-error "conflicting stepping directions in LOOP sequencing path")) + (setq odir dir)) + (when (and sequence-variable (not sequencep)) + (loop-error "missing OF or IN phrase in sequence path")) + ;; Now fill in the defaults. + (if start-given + (when limit-given + ;; if both start and limit are given, they had better both + ;; be REAL. We already enforce the REALness of LIMIT, + ;; above; here's the KLUDGE to enforce the type of START. + (flet ((type-declaration-of (x) + (and (eq (car x) 'type) (caddr x)))) + (let ((decl (find indexv *loop-declarations* + :key #'type-declaration-of)) + (%decl (find indexv *loop-declarations* + :key #'type-declaration-of + :from-end t))) + #+sbcl (aver (eq decl %decl)) + #-sbcl (declare (ignore %decl)) + (setf (cadr decl) + `(and real ,(cadr decl)))))) + ;; default start + ;; DUPLICATE KLUDGE: loop-make-var generates a temporary + ;; symbol for indexv if it is NIL. See also the comment in + ;; the (:from :downfrom :upfrom) case + (progn + (assert-index-for-arithmetic indexv) + (setq indexv + (loop-make-iteration-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real))))) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-")) + nil + indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "don't know where to start stepping")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) + inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step + (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn + (setq test + `(,testfn ,indexv ,endform))) + (when step-hack + (setq step-hack + `(,variable ,step-hack))) + (let ((first-test test) (remaining-tests test)) + (when (and stepby-constantp start-constantp limit-constantp + (realp start-value) (realp limit-value)) + (when (setq first-test + (funcall (symbol-function testfn) + start-value + limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,step) + ,remaining-tests ,step-hack () () ,first-test ,step-hack))))) + +;;;; interfaces to the master sequencer + +(defun loop-for-arithmetic (var val data-type kwd) + (loop-sequencer + var (loop-check-data-type data-type 'number) + nil nil nil nil nil nil + (loop-collect-prepositional-phrases + '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) + nil (list (list kwd val))))) + +(defun loop-sequence-elements-path (variable data-type prep-phrases + &key + fetch-function + size-function + sequence-type + element-type) + (multiple-value-bind (indexv) (loop-named-var 'index) + (let ((sequencev (loop-named-var 'sequence))) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) + `(,size-function ,sequencev) + prep-phrases))))) + +;;;; builtin LOOP iteration paths + +#|| +(loop for v being the hash-values of ht do (print v)) +(loop for k being the hash-keys of ht do (print k)) +(loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) +(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) +||# + +(defun loop-hash-table-iteration-path (variable data-type prep-phrases + &key which) + (declare (type (member :hash-key :hash-value) which)) + (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "too many prepositions!")) + ((null prep-phrases) + (loop-error "missing OF or IN in ~S iteration path"))) + (let ((ht-var (gensym "LOOP-HASHTAB-")) + (next-fn (gensym "LOOP-HASHTAB-NEXT-")) + (dummy-predicate-var nil) + (post-steps nil)) + (multiple-value-bind (other-var other-p) + (loop-named-var (ecase which + (:hash-key 'hash-value) + (:hash-value 'hash-key))) + ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name was + ;; actually specified, so clever code can throw away the GENSYM'ed-up + ;; variable if it isn't really needed. + (unless other-p + (push `(ignorable ,other-var) *loop-declarations*)) + ;; The following is for those implementations in which we cannot put + ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists. + (setq other-p t + dummy-predicate-var (loop-when-it-var)) + (let* ((key-var nil) + (val-var nil) + (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-"))) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (ecase which + (:hash-key (setq key-var variable + val-var (and other-p other-var))) + (:hash-value (setq key-var (and other-p other-var) + val-var variable))) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (when (or (consp key-var) data-type) + (setq post-steps + `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-")) + , at post-steps)) + (push `(,key-var nil) bindings)) + (when (or (consp val-var) data-type) + (setq post-steps + `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-")) + , at post-steps)) + (push `(,val-var nil) bindings)) + (push `(ignorable ,dummy-predicate-var) *loop-declarations*) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) + (,next-fn))) ;post-test + ,post-steps))))) + +(defun loop-package-symbols-iteration-path (variable data-type prep-phrases + &key symbol-types) + (cond ((and prep-phrases (cdr prep-phrases)) + (loop-error "Too many prepositions!")) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Unknown preposition ~S." (caar prep-phrases)))) + (unless (symbolp variable) + (loop-error "Destructuring is not valid for package symbol iteration.")) + (let ((pkg-var (gensym "LOOP-PKGSYM-")) + (next-fn (gensym "LOOP-PKGSYM-NEXT-")) + (variable (or variable (gensym "LOOP-PKGSYM-VAR-"))) + (package (or (cadar prep-phrases) '*package*))) + (push `(with-package-iterator (,next-fn ,pkg-var , at symbol-types)) + *loop-wrappers*) + (push `(ignorable ,(loop-when-it-var)) *loop-declarations*) + `(((,variable nil ,data-type) (,pkg-var ,package)) + () + () + () + (not (multiple-value-setq (,(loop-when-it-var) + ,variable) + (,next-fn))) + ()))) + +;;;; ANSI LOOP + +(defun make-ansi-loop-universe (extended-p) + (let ((w (make-standard-loop-universe + :keywords '((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count + real + fixnum)) + (counting (loop-sum-collection count + real + fixnum)) + (sum (loop-sum-collection sum number number)) + (summing (loop-sum-collection sum number number)) + (maximize (loop-maxmin-collection max)) + (minimize (loop-maxmin-collection min)) + (maximizing (loop-maxmin-collection max)) + (minimizing (loop-maxmin-collection min)) + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ;Negate test on while + (when (loop-do-if when nil)) ; Normal, do when + (if (loop-do-if if nil)) ; synonymous + (unless (loop-do-if unless t)) ; Negate test on when + (with (loop-do-with)) + (repeat (loop-do-repeat))) + :for-keywords '((= (loop-ansi-for-equals)) + (across (loop-for-across)) + (in (loop-for-in)) + (on (loop-for-on)) + (from (loop-for-arithmetic :from)) + (downfrom (loop-for-arithmetic :downfrom)) + (upfrom (loop-for-arithmetic :upfrom)) + (below (loop-for-arithmetic :below)) + (above (loop-for-arithmetic :above)) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (by (loop-for-arithmetic :by)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (as (loop-do-for))) + :type-symbols '(array atom bignum bit bit-vector character + compiled-function complex cons double-float + fixnum float function hash-table integer + keyword list long-float nil null number + package pathname random-state ratio rational + readtable sequence short-float simple-array + simple-bit-vector simple-string simple-vector + single-float standard-char stream string + base-char symbol t vector) + :type-keywords nil + :ansi (if extended-p :extended t)))) + (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which :hash-key)) + (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which :hash-value)) + (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal + :external + :inherited))) + (add-loop-path '(external-symbol external-symbols) + 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:external))) + (add-loop-path '(present-symbol present-symbols) + 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal + :external))) + w)) + +(defparameter *loop-ansi-universe* + (make-ansi-loop-universe nil)) + +(defun loop-standard-expansion (keywords-and-forms environment universe) + (if (and keywords-and-forms (symbolp (car keywords-and-forms))) + (loop-translate keywords-and-forms environment universe) + (let ((tag (gensym))) + `(block nil (tagbody ,tag (progn , at keywords-and-forms) (go ,tag)))))) + +(defmacro loop (&environment env &rest keywords-and-forms) + (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) + +(defmacro loop-finish () + "Cause the iteration to terminate \"normally\", the same as implicit +termination by an iteration driving clause, or by use of WHILE or +UNTIL -- the epilogue code (if any) will be run, and any implicitly +collected result will be returned as the value of the LOOP." + '(go end-loop)) + +(provide "LOOP") Added: branches/save-image/src/org/armedbear/lisp/machine_type.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/machine_type.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * machine_type.java + * + * Copyright (C) 2004-2007 Peter Graves + * $Id: machine_type.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### machine-type +public final class machine_type extends Primitive +{ + private machine_type() + { + super("machine-type"); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + String s = System.getProperty("os.arch"); + if (s.equals("amd64")) + s = "X86-64"; + else + s = s.toUpperCase(); + return new SimpleString(s); + } + + private static final Primitive MACHINE_TYPE = new machine_type(); +} Added: branches/save-image/src/org/armedbear/lisp/machine_version.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/machine_version.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,82 @@ +/* + * machine_version.java + * + * Copyright (C) 2004 Peter Graves + * $Id: machine_version.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.BufferedReader; +import java.io.FileInputStream; +import java.io.IOException; +import java.io.InputStreamReader; + +// ### machine-version +public final class machine_version extends Primitive +{ + private machine_version() + { + super("machine-version"); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + String osName = System.getProperty("os.name"); + if (osName != null && osName.toLowerCase().startsWith("linux")) { + try { + FileInputStream in = new FileInputStream("/proc/cpuinfo"); + if (in != null) { + BufferedReader reader = + new BufferedReader(new InputStreamReader(in)); + try { + String s; + while ((s = reader.readLine()) != null) { + int start = s.indexOf("model name"); + if (start >= 0) { + start = s.indexOf(':', start); + if (start >= 0) { + return new SimpleString(s.substring(start + 1).trim()); + } + } + } + } + finally { + reader.close(); + } + } + } + catch (IOException e) {} + } + return NIL; + } + + private static final Primitive MACHINE_VERSION = new machine_version(); +} Added: branches/save-image/src/org/armedbear/lisp/macros.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/macros.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,189 @@ +;;; macros.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: macros.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export 'defconst) + +(defmacro in-package (name) + `(%in-package ,(string name))) + +(defmacro when (test-form &rest body) + (if (cdr body) + `(if ,test-form (progn , at body)) + `(if ,test-form ,(car body)))) + +(defmacro unless (test-form &rest body) + (if (cdr body) + `(if (not ,test-form) (progn , at body)) + `(if (not ,test-form) ,(car body)))) + +(defmacro return (&optional result) + `(return-from nil ,result)) + +(defmacro defconstant (name initial-value &optional docstring) + `(%defconstant ',name ,initial-value ,docstring)) + +(defmacro defparameter (name initial-value &optional docstring) + `(%defparameter ',name ,initial-value ,docstring)) + +(defmacro %car (x) + `(car (truly-the cons ,x))) + +(defmacro %cdr (x) + `(cdr (truly-the cons ,x))) + +(defmacro %cadr (x) + `(%car (%cdr ,x))) + +(defmacro %caddr (x) + `(%car (%cdr (%cdr ,x)))) + +(defmacro prog1 (first-form &rest forms) + (let ((result (gensym))) + `(let ((,result ,first-form)) + , at forms + ,result))) + +(defmacro prog2 (first-form second-form &rest forms) + `(prog1 (progn ,first-form ,second-form) , at forms)) + +;; Adapted from SBCL. +(defmacro push (&environment env item place) + (if (and (symbolp place) + (eq place (macroexpand place env))) + `(setq ,place (cons ,item ,place)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((g (gensym))) + `(let* ((,g ,item) + ,@(mapcar #'list dummies vals) + (,(car newval) (cons ,g ,getter))) + ,setter))))) + +;; Adapted from SBCL. +(defmacro pushnew (&environment env item place &rest keys) + (if (and (symbolp place) + (eq place (macroexpand place env))) + `(setq ,place (adjoin ,item ,place , at keys)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((g (gensym))) + `(let* ((,g ,item) + ,@(mapcar #'list dummies vals) + (,(car newval) (adjoin ,g ,getter , at keys))) + ,setter))))) + +;; Adapted from SBCL. +(defmacro pop (&environment env place) + (if (and (symbolp place) + (eq place (macroexpand place env))) + `(prog1 (car ,place) + (setq ,place (cdr ,place))) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (push (list (car newval) getter) let-list) + `(let* ,(nreverse let-list) + (prog1 (car ,(car newval)) + (setq ,(car newval) (cdr ,(car newval))) + ,setter))) + (push (list (car d) (car v)) let-list))))) + +(defmacro psetq (&environment env &rest args) + (do ((l args (cddr l)) + (forms nil) + (bindings nil)) + ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms)))) + (if (and (symbolp (car l)) + (eq (car l) (macroexpand-1 (car l) env))) + (let ((sym (gensym))) + (push (list sym (cadr l)) bindings) + (push (list 'setq (car l) sym) forms)) + (multiple-value-bind + (dummies vals newval setter getter) + (get-setf-expansion (macroexpand-1 (car l) env) env) + (declare (ignore getter)) + (do ((d dummies (cdr d)) + (v vals (cdr v))) + ((null d)) + (push (list (car d) (car v)) bindings)) + (push (list (car newval) (cadr l)) bindings) + (push setter forms))))) + +(defmacro time (form) + `(%time #'(lambda () ,form))) + +(defmacro with-open-stream (&rest args) + (let ((var (caar args)) + (stream (cadar args)) + (forms (cdr args)) + (abortp (gensym))) + `(let ((,var ,stream) + (,abortp t)) + (unwind-protect + (multiple-value-prog1 + (progn , at forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp)))))) + +(defun ansi-loop (exps) + (let ((*warn-on-redefinition* nil)) + (require 'loop)) + (fmakunbound 'ansi-loop) + `(loop , at exps)) + +(defmacro loop (&rest exps) + (dolist (exp exps) + (when (atom exp) + (return-from loop (ansi-loop exps)))) + (let ((tag (gensym))) + `(block nil (tagbody ,tag , at exps (go ,tag))))) + +(defmacro defvar (var &optional (val nil valp) (doc nil docp)) + `(progn + (%defvar ',var) + ,@(when valp + `((unless (boundp ',var) + (setq ,var ,val)))) + ,@(when docp + `((%set-documentation ',var 'variable ',doc))) + ',var)) + +(defmacro defconst (name value) + `(defconstant ,name + (if (boundp ',name) + (symbol-value ',name) + ,value))) Added: branches/save-image/src/org/armedbear/lisp/make-hash-table.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make-hash-table.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,40 @@ +;;; make-hash-table.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: make-hash-table.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun make-hash-table (&key (test 'eql) (size 11) (rehash-size 1.5) + (rehash-threshold 0.75)) + (setf test (coerce-to-function test)) + (unless (and (integerp size) (>= size 0)) + (error 'type-error :datum size :expected-type '(integer 0))) + (let ((size (max 11 (min size array-dimension-limit)))) + (%make-hash-table test size rehash-size rehash-threshold))) Added: branches/save-image/src/org/armedbear/lisp/make-load-form-saving-slots.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make-load-form-saving-slots.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +;;; make-load-form-saving-slots.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: make-load-form-saving-slots.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(resolve 'defstruct) + +(defun make-load-form-saving-slots (object &key slot-names environment) + (declare (ignore environment)) + (let ((class (class-of object)) + (inits ()) + (instance (gensym "INSTANCE-"))) + (cond ((typep object 'structure-object) + (let ((index 0)) + (dolist (slot (%class-slots class)) + (let ((slot-name (dsd-name slot))) + (when (or (memq slot-name slot-names) + (null slot-names)) + (let ((value (structure-ref object index))) + (push `(structure-set ,instance ,index ',value) inits)))) + (incf index)))) + ((typep object 'standard-object) + (dolist (slot (%class-slots class)) + (let ((slot-name (%slot-definition-name slot))) + (when (or (memq slot-name slot-names) + (null slot-names)) + (when (slot-boundp object slot-name) + (let ((value (slot-value object slot-name))) + (push `(setf (slot-value ,instance ',slot-name) ',value) inits)))))))) + (values `(let ((,instance (allocate-instance (find-class ',(%class-name class))))) + (progn , at inits) + ,instance) + nil))) Added: branches/save-image/src/org/armedbear/lisp/make-sequence.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make-sequence.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,114 @@ +;;; make-sequence.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: make-sequence.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; Adapted from ECL. + +(defun size-mismatch-error (type size) + (error 'simple-type-error + :format-control "The requested length (~D) does not match the specified type ~A." + :format-arguments (list size type))) + +(defun make-sequence (type size &key (initial-element nil iesp)) + (let (element-type sequence) + (setf type (normalize-type type)) + (cond ((atom type) + (when (classp type) + (setf type (%class-name type))) + (cond ((memq type '(LIST CONS)) + (when (zerop size) + (if (eq type 'CONS) + (size-mismatch-error type size) + (return-from make-sequence nil))) + (return-from make-sequence + (if iesp + (make-list size :initial-element initial-element) + (make-list size)))) + ((memq type '(STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING)) + (return-from make-sequence + (if iesp + (make-string size :initial-element initial-element) + (make-string size)))) + ((eq type 'NULL) + (if (zerop size) + (return-from make-sequence nil) + (size-mismatch-error type size))) + (t + (setq element-type + (cond ((memq type '(BIT-VECTOR SIMPLE-BIT-VECTOR)) 'BIT) + ((memq type '(VECTOR SIMPLE-VECTOR)) t) + (t + (error 'simple-type-error + :format-control "~S is not a sequence type." + :format-arguments (list type)))))))) + (t + (let ((name (%car type)) + (args (%cdr type))) + (when (eq name 'LIST) + (return-from make-sequence + (if iesp + (make-list size :initial-element initial-element) + (make-list size)))) + (when (eq name 'CONS) + (unless (plusp size) + (size-mismatch-error name size)) + (return-from make-sequence + (if iesp + (make-list size :initial-element initial-element) + (make-list size)))) + (unless (memq name '(ARRAY SIMPLE-ARRAY VECTOR SIMPLE-VECTOR + BIT-VECTOR SIMPLE-BIT-VECTOR STRING SIMPLE-STRING + BASE-STRING SIMPLE-BASE-STRING)) + (error 'simple-type-error + :format-control "~S is not a sequence type." + :format-arguments (list type))) + (let ((len nil)) + (cond ((memq name '(STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING)) + (setf element-type 'character + len (car args))) + ((memq name '(ARRAY SIMPLE-ARRAY)) + (setf element-type (or (car args) t) + len (if (consp (cadr args)) (caadr args) '*))) + ((memq name '(BIT-VECTOR SIMPLE-BIT-VECTOR)) + (setf element-type 'bit + len (car args))) + (t + (setf element-type (or (car args) t) + len (cadr args)))) + (unless (or (null len) (eq len '*) (equal len '(*))) + (when (/= size len) + (size-mismatch-error type size))))))) + (setq sequence + (if iesp + (make-array size :element-type element-type :initial-element initial-element) + (make-array size :element-type element-type))) + sequence)) Added: branches/save-image/src/org/armedbear/lisp/make-string-output-stream.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make-string-output-stream.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,35 @@ +;;; make-string-output-stream.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: make-string-output-stream.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun make-string-output-stream (&key (element-type 'character)) + (%make-string-output-stream element-type)) Added: branches/save-image/src/org/armedbear/lisp/make-string.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make-string.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,35 @@ +;;; make-string.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: make-string.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun make-string (size &key initial-element element-type) + (%make-string size initial-element element-type)) Added: branches/save-image/src/org/armedbear/lisp/make_array.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make_array.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,316 @@ +/* + * make_array.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: make_array.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### %make-array dimensions element-type initial-element initial-element-p +// initial-contents adjustable fill-pointer displaced-to displaced-index-offset +// => new-array +public final class make_array extends Primitive +{ + public make_array() + { + super("%make-array", PACKAGE_SYS, false); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length != 9) + return error(new WrongNumberOfArgumentsException(this)); + LispObject dimensions = args[0]; + LispObject elementType = args[1]; + LispObject initialElement = args[2]; + LispObject initialElementProvided = args[3]; + LispObject initialContents = args[4]; + LispObject adjustable = args[5]; + LispObject fillPointer = args[6]; + LispObject displacedTo = args[7]; + LispObject displacedIndexOffset = args[8]; + if (initialElementProvided != NIL && initialContents != NIL) + { + return error(new LispError("MAKE-ARRAY: cannot specify both " + + "initial element and initial contents.")); + } + final int rank = dimensions.listp() ? dimensions.length() : 1; + int[] dimv = new int[rank]; + if (dimensions.listp()) + { + for (int i = 0; i < rank; i++) + { + LispObject dim = dimensions.car(); + dimv[i] = Fixnum.getValue(dim); + dimensions = dimensions.cdr(); + } + } + else + dimv[0] = Fixnum.getValue(dimensions); + if (displacedTo != NIL) + { + // FIXME Make sure element type (if specified) is compatible with + // displaced-to array. + final AbstractArray array = checkArray(displacedTo); + if (initialElementProvided != NIL) + return error(new LispError("Initial element must not be specified for a displaced array.")); + if (initialContents != NIL) + return error(new LispError("Initial contents must not be specified for a displaced array.")); + final int displacement; + if (displacedIndexOffset != NIL) + displacement = Fixnum.getValue(displacedIndexOffset); + else + displacement = 0; + if (rank == 1) + { + AbstractVector v; + LispObject arrayElementType = array.getElementType(); + if (arrayElementType == Symbol.CHARACTER) + v = new ComplexString(dimv[0], array, displacement); + else if (arrayElementType == Symbol.BIT) + v = new ComplexBitVector(dimv[0], array, displacement); + else if (arrayElementType.equal(UNSIGNED_BYTE_8)) + v = new ComplexVector_UnsignedByte8(dimv[0], array, displacement); + else if (arrayElementType.equal(UNSIGNED_BYTE_32)) + v = new ComplexVector_UnsignedByte32(dimv[0], array, displacement); + else + v = new ComplexVector(dimv[0], array, displacement); + if (fillPointer != NIL) + v.setFillPointer(fillPointer); + return v; + } + return new ComplexArray(dimv, array, displacement); + } + LispObject upgradedType = getUpgradedArrayElementType(elementType); + if (rank == 0) + { + LispObject data; + if (initialElementProvided != NIL) + data = initialElement; + else + data = initialContents; + return new ZeroRankArray(upgradedType, data, adjustable != NIL); + } + if (rank == 1) + { + final int size = dimv[0]; + if (size < 0 || size >= ARRAY_DIMENSION_MAX) + { + FastStringBuffer sb = new FastStringBuffer(); + sb.append("The size specified for this array ("); + sb.append(size); + sb.append(')'); + if (size >= ARRAY_DIMENSION_MAX) + { + sb.append(" is >= ARRAY-DIMENSION-LIMIT ("); + sb.append(ARRAY_DIMENSION_MAX); + sb.append(")."); + } + else + sb.append(" is negative."); + return error(new LispError(sb.toString())); + } + final AbstractVector v; + if (upgradedType == Symbol.CHARACTER) + { + if (fillPointer != NIL || adjustable != NIL) + v = new ComplexString(size); + else + v = new SimpleString(size); + } + else if (upgradedType == Symbol.BIT) + { + if (fillPointer != NIL || adjustable != NIL) + v = new ComplexBitVector(size); + else + v = new SimpleBitVector(size); + } + else if (upgradedType.equal(UNSIGNED_BYTE_8)) + { + if (fillPointer != NIL || adjustable != NIL) + v = new ComplexVector_UnsignedByte8(size); + else + v = new BasicVector_UnsignedByte8(size); + } + else if (upgradedType.equal(UNSIGNED_BYTE_16) && + fillPointer == NIL && adjustable == NIL) + { + v = new BasicVector_UnsignedByte16(size); + } + else if (upgradedType.equal(UNSIGNED_BYTE_32)) + { + if (fillPointer != NIL || adjustable != NIL) + v = new ComplexVector_UnsignedByte32(size); + else + v = new BasicVector_UnsignedByte32(size); + } + else if (upgradedType == NIL) + v = new NilVector(size); + else + { + if (fillPointer != NIL || adjustable != NIL) + v = new ComplexVector(size); + else + v = new SimpleVector(size); + } + if (initialElementProvided != NIL) + { + // Initial element was specified. + v.fill(initialElement); + } + else if (initialContents != NIL) + { + if (initialContents.listp()) + { + LispObject list = initialContents; + for (int i = 0; i < size; i++) + { + v.aset(i, list.car()); + list = list.cdr(); + } + } + else if (initialContents.vectorp()) + { + for (int i = 0; i < size; i++) + v.aset(i, initialContents.elt(i)); + } + else + return type_error(initialContents, Symbol.SEQUENCE); + } + if (fillPointer != NIL) + v.setFillPointer(fillPointer); + return v; + } + // rank > 1 + AbstractArray array; + if (adjustable == NIL) + { + if (upgradedType.equal(UNSIGNED_BYTE_8)) + { + if (initialContents != NIL) + { + array = new SimpleArray_UnsignedByte8(dimv, initialContents); + } + else + { + array = new SimpleArray_UnsignedByte8(dimv); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + else if (upgradedType.equal(UNSIGNED_BYTE_16)) + { + if (initialContents != NIL) + { + array = new SimpleArray_UnsignedByte16(dimv, initialContents); + } + else + { + array = new SimpleArray_UnsignedByte16(dimv); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + else if (upgradedType.equal(UNSIGNED_BYTE_32)) + { + if (initialContents != NIL) + { + array = new SimpleArray_UnsignedByte32(dimv, initialContents); + } + else + { + array = new SimpleArray_UnsignedByte32(dimv); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + else + { + if (initialContents != NIL) + { + array = new SimpleArray_T(dimv, upgradedType, initialContents); + } + else + { + array = new SimpleArray_T(dimv, upgradedType); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + } + else + { + // Adjustable. + if (upgradedType.equal(UNSIGNED_BYTE_8)) + { + if (initialContents != NIL) + { + array = new ComplexArray_UnsignedByte8(dimv, initialContents); + } + else + { + array = new ComplexArray_UnsignedByte8(dimv); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + else if (upgradedType.equal(UNSIGNED_BYTE_32)) + { + if (initialContents != NIL) + { + array = new ComplexArray_UnsignedByte32(dimv, initialContents); + } + else + { + array = new ComplexArray_UnsignedByte32(dimv); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + else + { + if (initialContents != NIL) + { + array = new ComplexArray(dimv, upgradedType, initialContents); + } + else + { + array = new ComplexArray(dimv, upgradedType); + if (initialElementProvided != NIL) + array.fill(initialElement); + } + } + } + return array; + } + + private static final Primitive _MAKE_ARRAY = new make_array(); +} Added: branches/save-image/src/org/armedbear/lisp/make_condition.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make_condition.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,129 @@ +/* + * make_condition.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: make_condition.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +public final class make_condition extends Primitive +{ + private make_condition() + { + super("%make-condition", PACKAGE_SYS, true); + } + + // ### %make-condition + // %make-condition type slot-initializations => condition + @Override + public LispObject execute(LispObject type, LispObject initArgs) + throws ConditionThrowable + { + final Symbol symbol; + if (type instanceof Symbol) + symbol = (Symbol) type; + else if (type instanceof LispClass) + symbol = ((LispClass)type).getSymbol(); + else { + // This function only works on symbols and classes. + return NIL; + } + + if (symbol == Symbol.ARITHMETIC_ERROR) + return new ArithmeticError(initArgs); + if (symbol == Symbol.CELL_ERROR) + return new CellError(initArgs); + if (symbol == Symbol.CONDITION) + return new Condition(initArgs); + if (symbol == Symbol.CONTROL_ERROR) + return new ControlError(initArgs); + if (symbol == Symbol.DIVISION_BY_ZERO) + return new DivisionByZero(initArgs); + if (symbol == Symbol.END_OF_FILE) + return new EndOfFile(initArgs); + if (symbol == Symbol.ERROR) + return new LispError(initArgs); + if (symbol == Symbol.FILE_ERROR) + return new FileError(initArgs); + if (symbol == Symbol.FLOATING_POINT_INEXACT) + return new FloatingPointInexact(initArgs); + if (symbol == Symbol.FLOATING_POINT_INVALID_OPERATION) + return new FloatingPointInvalidOperation(initArgs); + if (symbol == Symbol.FLOATING_POINT_OVERFLOW) + return new FloatingPointOverflow(initArgs); + if (symbol == Symbol.FLOATING_POINT_UNDERFLOW) + return new FloatingPointUnderflow(initArgs); + if (symbol == Symbol.PACKAGE_ERROR) + return new PackageError(initArgs); + if (symbol == Symbol.PARSE_ERROR) + return new ParseError(initArgs); + if (symbol == Symbol.PRINT_NOT_READABLE) + return new PrintNotReadable(initArgs); + if (symbol == Symbol.PROGRAM_ERROR) + return new ProgramError(initArgs); + if (symbol == Symbol.READER_ERROR) + return new ReaderError(initArgs); + if (symbol == Symbol.SERIOUS_CONDITION) + return new SeriousCondition(initArgs); + if (symbol == Symbol.SIMPLE_CONDITION) + return new SimpleCondition(initArgs); + if (symbol == Symbol.SIMPLE_ERROR) + return new SimpleError(initArgs); + if (symbol == Symbol.SIMPLE_TYPE_ERROR) + return new SimpleTypeError(initArgs); + if (symbol == Symbol.SIMPLE_WARNING) + return new SimpleWarning(initArgs); + if (symbol == Symbol.STORAGE_CONDITION) + return new StorageCondition(initArgs); + if (symbol == Symbol.STREAM_ERROR) + return new StreamError(initArgs); + if (symbol == Symbol.STYLE_WARNING) + return new StyleWarning(initArgs); + if (symbol == Symbol.TYPE_ERROR) + return new TypeError(initArgs); + if (symbol == Symbol.UNBOUND_SLOT) + return new UnboundSlot(initArgs); + if (symbol == Symbol.UNBOUND_VARIABLE) + return new UnboundVariable(initArgs); + if (symbol == Symbol.UNDEFINED_FUNCTION) + return new UndefinedFunction(initArgs); + if (symbol == Symbol.WARNING) + return new Warning(initArgs); + + if (symbol == Symbol.COMPILER_ERROR) + return new CompilerError(initArgs); + if (symbol == Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR) + return new CompilerUnsupportedFeatureError(initArgs); + + return NIL; + } + + private static final Primitive MAKE_CONDITION = new make_condition(); +} Added: branches/save-image/src/org/armedbear/lisp/make_server_socket.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make_server_socket.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +/* + * make_server_socket.java + * + * Copyright (C) 2004 Peter Graves + * $Id: make_server_socket.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.ServerSocket; + +// ### %make-server-socket +public final class make_server_socket extends Primitive +{ + private make_server_socket() + { + super("%make-server-socket", PACKAGE_SYS, false, "port element-type"); + } + + @Override + public LispObject execute(LispObject first) + throws ConditionThrowable + { + int port = Fixnum.getValue(first); + try { + ServerSocket socket = new ServerSocket(port); + return new JavaObject(socket); + } + catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + private static final Primitive MAKE_SERVER_SOCKET = new make_server_socket(); +} Added: branches/save-image/src/org/armedbear/lisp/make_socket.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/make_socket.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,62 @@ +/* + * make_socket.java + * + * Copyright (C) 2004 Peter Graves + * $Id: make_socket.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.Socket; + +// ### %make-socket +public final class make_socket extends Primitive +{ + private make_socket() + { + super("%make-socket", PACKAGE_SYS, false, "host port"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + String host = first.getStringValue(); + int port = Fixnum.getValue(second); + try { + Socket socket = new Socket(host, port); + return new JavaObject(socket); + } + catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + private static final Primitive MAKE_SOCKET = new make_socket(); +} Added: branches/save-image/src/org/armedbear/lisp/map-into.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/map-into.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +;;; map-into.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: map-into.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "COMMON-LISP") + +(export 'map-into) + +;;; MAP-INTO (from CMUCL) + +(defun map-into (result-sequence function &rest sequences) + (let* ((fp-result + (and (arrayp result-sequence) + (array-has-fill-pointer-p result-sequence))) + (len (apply #'min + (if fp-result + (array-dimension result-sequence 0) + (length result-sequence)) + (mapcar #'length sequences)))) + + (when fp-result + (setf (fill-pointer result-sequence) len)) + + (dotimes (index len) + (setf (elt result-sequence index) + (apply function + (mapcar #'(lambda (seq) (elt seq index)) + sequences))))) + result-sequence) Added: branches/save-image/src/org/armedbear/lisp/map.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/map.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +;;; map.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: map.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun map (result-type function sequence &rest more-sequences) + (let* ((sequences (cons sequence more-sequences)) + (limit (apply #'min (mapcar #'length sequences)))) + (declare (type index limit)) + (cond ((null result-type) + (dotimes (i limit nil) + (apply function (mapcar #'(lambda (z) (elt z i)) sequences)))) + ((eq result-type 'LIST) + (let (result) + (dotimes (i limit (nreverse result)) + (push (apply function (mapcar #'(lambda (z) (elt z i)) sequences)) + result)))) + (t + (let ((result (case result-type + (STRING + (make-string limit)) + (VECTOR + (make-array limit)) + (t + (make-sequence result-type limit))))) + (dotimes (i limit result) + (setf (elt result i) + (apply function (mapcar #'(lambda (z) (elt z i)) sequences))))))))) Added: branches/save-image/src/org/armedbear/lisp/map1.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/map1.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,66 @@ +;;; map1.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: map1.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package #:system) + +(defun map1 (function original-arglists accumulate take-car) + (let* ((arglists (copy-list original-arglists)) + (ret-list (list nil)) + (temp ret-list)) + (do ((res nil) + (args '() '())) + ((dolist (x arglists nil) (if (null x) (return t))) + (if accumulate + (cdr ret-list) + (car original-arglists))) + (do ((l arglists (cdr l))) + ((null l)) + (push (if take-car (caar l) (car l)) args) + (setf (car l) (cdar l))) + (setq res (apply function (nreverse args))) + (case accumulate + (:nconc (setq temp (last (nconc temp res)))) + (:list (rplacd temp (list res)) + (setq temp (cdr temp))))))) + +(defun mapcan (function list &rest more-lists) + (map1 function (cons list more-lists) :nconc t)) + +(defun mapl (function list &rest more-lists) + (map1 function (cons list more-lists) nil nil)) + +(defun maplist (function list &rest more-lists) + (map1 function (cons list more-lists) :list nil)) + +(defun mapcon (function list &rest more-lists) + (map1 function (cons list more-lists) :nconc nil)) Added: branches/save-image/src/org/armedbear/lisp/mask-field.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/mask-field.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +;;; mask-field.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: mask-field.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From CMUCL. + +(defun mask-field (bytespec integer) + (let ((size (byte-size bytespec)) + (pos (byte-position bytespec))) + (logand integer (ash (1- (ash 1 size)) pos)))) + +(define-setf-expander mask-field (bytespec place &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(mask-field ,btemp ,getter))))) Added: branches/save-image/src/org/armedbear/lisp/member-if.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/member-if.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,44 @@ +;;; member-if.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: member-if.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun member-if (test list &key key) + (do ((list list (cdr list))) + ((endp list) nil) + (if (funcall test (apply-key key (car list))) + (return list)))) + +(defun member-if-not (test list &key key) + (do ((list list (cdr list))) + ((endp list) ()) + (if (not (funcall test (apply-key key (car list)))) + (return list)))) Added: branches/save-image/src/org/armedbear/lisp/mismatch.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/mismatch.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,96 @@ +;;; mismatch.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: mismatch.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. +;;; MISMATCH (from ECL) + +(in-package "COMMON-LISP") + +(export 'mismatch) + +;;; From ECL. + +(defun bad-seq-limit (x &optional y) + (error "bad sequence limit ~a" (if y (list x y) x))) + +(defun the-end (x y) + (cond ((sys::fixnump x) + (unless (<= x (length y)) + (bad-seq-limit x)) + x) + ((null x) + (length y)) + (t (bad-seq-limit x)))) + +(defun the-start (x) + (cond ((sys::fixnump x) + (unless (>= x 0) + (bad-seq-limit x)) + x) + ((null x) 0) + (t (bad-seq-limit x)))) + +(defmacro with-start-end (start end seq &body body) + `(let* ((,start (if ,start (the-start ,start) 0)) + (,end (the-end ,end ,seq))) + (unless (<= ,start ,end) (bad-seq-limit ,start ,end)) + ,@ body)) + +(defun call-test (test test-not item keyx) + (cond (test (funcall test item keyx)) + (test-not (not (funcall test-not item keyx))) + (t (eql item keyx)))) + +(defun test-error() + (error "both test and test are supplied")) + +(defun mismatch (sequence1 sequence2 &key from-end test test-not + (key #'identity) start1 start2 end1 end2) + (and test test-not (test-error)) + (with-start-end + start1 end1 sequence1 + (with-start-end + start2 end2 sequence2 + (if (not from-end) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (>= i1 end1) (>= i2 end2)) + (if (and (>= i1 end1) (>= i2 end2)) nil i1)) + (unless (call-test test test-not + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (return i1))) + (do ((i1 (1- end1) (1- i1)) + (i2 (1- end2) (1- i2))) + ((or (< i1 start1) (< i2 start2)) + (if (and (< i1 start1) (< i2 start2)) nil (1+ i1))) + (unless (call-test test test-not + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (return (1+ i1)))))))) Added: branches/save-image/src/org/armedbear/lisp/mod.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/mod.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +/* + * mod.java + * + * Copyright (C) 2004 Peter Graves + * $Id: mod.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### mod number divisor +public final class mod extends Primitive +{ + private mod() + { + super("mod", "number divisor"); + } + + @Override + public LispObject execute(LispObject number, LispObject divisor) + throws ConditionThrowable + { + return number.MOD(divisor); + } + + private static final Primitive MOD = new mod(); +} Added: branches/save-image/src/org/armedbear/lisp/multiple-value-bind.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/multiple-value-bind.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +;;; multiple-value-bind.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: multiple-value-bind.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package "SYSTEM") + +;; The traditional implementation of M-V-B in terms of M-V-C. ABCL implements +;; M-V-B as a special form in the interpreter, and ABCL's compiler handles it +;; specifically too, so this code is only here to support code walkers and the +;; like, as required by ANSI. +(defmacro multiple-value-bind (varlist value-form &body body) + (unless (and (listp varlist) (every #'symbolp varlist)) + (error 'program-error + :format-control "Variable list is not a list of symbols: ~S." + :format-arguments (list varlist))) + (if (= (length varlist) 1) + `(let ((,(car varlist) ,value-form)) + , at body) + (let ((ignore (gensym))) + `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list varlist) &rest ,ignore) + (declare (ignore ,ignore)) + , at body) + ,value-form)))) Added: branches/save-image/src/org/armedbear/lisp/multiple-value-list.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/multiple-value-list.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,35 @@ +;;; multiple-value-list.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: multiple-value-list.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defmacro multiple-value-list (form) + `(multiple-value-call #'list ,form)) Added: branches/save-image/src/org/armedbear/lisp/multiple-value-setq.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/multiple-value-setq.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,43 @@ +;;; multiple-value-setq.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $Id: multiple-value-setq.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;; Adapted from CMUCL. + +(in-package "SYSTEM") + +(defmacro multiple-value-setq (varlist value-form) + (unless (and (listp varlist) (every #'symbolp varlist)) + (error "~S is not a list of symbols." varlist)) + ;; MULTIPLE-VALUE-SETQ is required always to return the primary value of the + ;; value-form, even if varlist is empty. + (if varlist + `(values (setf (values , at varlist) ,value-form)) + `(values ,value-form))) Added: branches/save-image/src/org/armedbear/lisp/nsubstitute.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/nsubstitute.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,148 @@ +;;; nsubstitute.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: nsubstitute.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. +;;; NSUBSTITUTE (from CMUCL) + +(in-package "SYSTEM") + +;;; From CMUCL. + +(defmacro real-count (count) + `(cond ((null ,count) most-positive-fixnum) + ((fixnump ,count) (if (minusp ,count) 0 ,count)) + ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum)) + (t ,count))) + +(defun nlist-substitute* (new old sequence test test-not start end count key) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (= index end) (null list) (= count 0)) sequence) + (when (if test-not + (not (funcall test-not old (apply-key key (car list)))) + (funcall test old (apply-key key (car list)))) + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute* (new old sequence incrementer + test test-not start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (if test-not + (not (funcall test-not old (apply-key key (aref sequence index)))) + (funcall test old (apply-key key (aref sequence index)))) + (setf (aref sequence index) new) + (setq count (1- count))))) + +(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not + end count key (start 0)) + (let ((end (or end (length sequence))) + (count (real-count count))) + (if (listp sequence) + (if from-end + (let ((length (length sequence))) + (nreverse (nlist-substitute* + new old (nreverse sequence) + test test-not (- length end) (- length start) count key))) + (nlist-substitute* new old sequence + test test-not start end count key)) + (if from-end + (nvector-substitute* new old sequence -1 + test test-not (1- end) (1- start) count key) + (nvector-substitute* new old sequence 1 + test test-not start end count key))))) + + +(defun nlist-substitute-if* (new test sequence start end count key) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (= index end) (null list) (= count 0)) sequence) + (when (funcall test (apply-key key (car list))) + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute-if* (new test sequence incrementer + start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (funcall test (apply-key key (aref sequence index))) + (setf (aref sequence index) new) + (setq count (1- count))))) + +(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key) + (let ((end (or end (length sequence))) + (count (real-count count))) + (if (listp sequence) + (if from-end + (let ((length (length sequence))) + (nreverse (nlist-substitute-if* + new test (nreverse sequence) + (- length end) (- length start) count key))) + (nlist-substitute-if* new test sequence + start end count key)) + (if from-end + (nvector-substitute-if* new test sequence -1 + (1- end) (1- start) count key) + (nvector-substitute-if* new test sequence 1 + start end count key))))) + + +(defun nlist-substitute-if-not* (new test sequence start end count key) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (= index end) (null list) (= count 0)) sequence) + (when (not (funcall test (apply-key key (car list)))) + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute-if-not* (new test sequence incrementer + start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (not (funcall test (apply-key key (aref sequence index)))) + (setf (aref sequence index) new) + (setq count (1- count))))) + +(defun nsubstitute-if-not (new test sequence &key from-end (start 0) + end count key) + (let ((end (or end (length sequence))) + (count (real-count count))) + (if (listp sequence) + (if from-end + (let ((length (length sequence))) + (nreverse (nlist-substitute-if-not* + new test (nreverse sequence) + (- length end) (- length start) count key))) + (nlist-substitute-if-not* new test sequence + start end count key)) + (if from-end + (nvector-substitute-if-not* new test sequence -1 + (1- end) (1- start) count key) + (nvector-substitute-if-not* new test sequence 1 + start end count key))))) Added: branches/save-image/src/org/armedbear/lisp/nth-value.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/nth-value.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,35 @@ +;;; nth-value.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: nth-value.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defmacro nth-value (n form) + `(nth ,n (multiple-value-list ,form))) Added: branches/save-image/src/org/armedbear/lisp/numbers.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/numbers.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,192 @@ +;;; numbers.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: numbers.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL/SBCL. + +(in-package "SYSTEM") + +(defun signum (number) + "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." + (if (zerop number) + number + (if (rationalp number) + (if (plusp number) 1 -1) + (/ number (abs number))))) + +(defun round (number &optional (divisor 1)) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (multiple-value-bind (tru rem) (truncate number divisor) + (if (zerop rem) + (values tru rem) + (let ((thresh (/ (abs divisor) 2))) + (cond ((or (> rem thresh) + (and (= rem thresh) (oddp tru))) + (if (minusp divisor) + (values (- tru 1) (+ rem divisor)) + (values (+ tru 1) (- rem divisor)))) + ((let ((-thresh (- thresh))) + (or (< rem -thresh) + (and (= rem -thresh) (oddp tru)))) + (if (minusp divisor) + (values (+ tru 1) (- rem divisor)) + (values (- tru 1) (+ rem divisor)))) + (t (values tru rem))))))) + +(defun ffloor (number &optional (divisor 1)) + "Same as FLOOR, but returns first value as a float." + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (1- tru) (+ rem divisor)) + (values tru rem)))) + +(defun fceiling (number &optional (divisor 1)) + "Same as CEILING, but returns first value as a float." + (multiple-value-bind (tru rem) (ftruncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (+ tru 1) (- rem divisor)) + (values tru rem)))) + +(defun fround (number &optional (divisor 1)) + "Same as ROUND, but returns first value as a float." + (multiple-value-bind (res rem) + (round number divisor) + (values (float res (if (floatp rem) rem 1.0)) rem))) + +;;; FIXME +(defun rationalize (number) + (rational number)) + +(defun gcd (&rest integers) + (cond ((null integers) + 0) + ((null (cdr integers)) + (let ((n (car integers))) + (if (integerp n) + (abs n) + (error 'type-error :datum n :expected-type 'integer)))) + (t + (do ((gcd (car integers) (gcd-2 gcd (car rest))) + (rest (cdr integers) (cdr rest))) + ((null rest) gcd))))) + +;;; From discussion on comp.lang.lisp and Akira Kurihara. +(defun isqrt (natural) + "Returns the root of the nearest integer less than natural which is a perfect + square." + (unless (and (integerp natural) (not (minusp natural))) + (error 'simple-type-error + :format-control "The value ~A is not a non-negative real number." + :format-arguments (list natural))) + (if (and (fixnump natural) (<= natural 24)) + (cond ((> natural 15) 4) + ((> natural 8) 3) + ((> natural 3) 2) + ((> natural 0) 1) + (t 0)) + (let* ((n-len-quarter (ash (integer-length natural) -2)) + (n-half (ash natural (- (ash n-len-quarter 1)))) + (n-half-isqrt (isqrt n-half)) + (init-value (ash (1+ n-half-isqrt) n-len-quarter))) + (loop + (let ((iterated-value + (ash (+ init-value (truncate natural init-value)) -1))) + (unless (< iterated-value init-value) + (return init-value)) + (setq init-value iterated-value)))))) + +;; FIXME Need to add support for denormalized floats! + +;; "FLOAT-PRECISION returns the number of significant radix b digits present in +;; FLOAT; if FLOAT is a float zero, then the result is an integer zero." + +;; "For normalized floats, the results of FLOAT-DIGITS and FLOAT-PRECISION are +;; the same, but the precision is less than the number of representation digits +;; for a denormalized or zero number. +(defun float-precision (float) + (if (floatp float) + (cond ((zerop float) + 0) + ((typep float 'single-float) + 24) + ((typep float 'double-float) + 53) + (t + ;; Shouldn't get here! + (aver nil))) + (error 'simple-type-error + :format-control "~S is not of type FLOAT." + :format-arguments (list float)))) + +(defun decode-float (float) + (multiple-value-bind (significand exponent sign) + (integer-decode-float float) + (values (coerce (/ significand (expt 2 53)) 'float) + (+ exponent 53) + (if (minusp sign) -1.0 1.0)))) + +(defun conjugate (number) + (etypecase number + (complex + (complex (realpart number) (- (imagpart number)))) + (number + number))) + +(defun phase (number) + "Returns the angle part of the polar representation of a complex number. + For complex numbers, this is (atan (imagpart number) (realpart number)). + For non-complex positive numbers, this is 0. For non-complex negative + numbers this is PI." + (etypecase number + (rational + (if (minusp number) + (coerce pi 'single-float) + 0.0f0)) + (single-float + (if (minusp (float-sign number)) + (coerce pi 'single-float) + 0.0f0)) + (double-float + (if (minusp (float-sign number)) + (coerce pi 'double-float) + 0.0d0)) + (complex + (if (zerop (realpart number)) + (coerce (* (/ pi 2) (signum (imagpart number))) + (if (typep (imagpart number) 'double-float) + 'double-float 'single-float)) + (atan (imagpart number) (realpart number)))))) Added: branches/save-image/src/org/armedbear/lisp/opcodes.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/opcodes.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,289 @@ +;;; opcodes.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: opcodes.lisp 11639 2009-02-08 08:43:46Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:jvm) + +(defconst *opcode-table* (make-array 256)) + +(defconst *opcodes* (make-hash-table :test 'equalp)) + +(defstruct jvm-opcode name number size stack-effect) + +(defun %define-opcode (name number size stack-effect) + (declare (type fixnum number size)) + (let* ((name (string name)) + (opcode (make-jvm-opcode :name name + :number number + :size size + :stack-effect stack-effect))) + (setf (svref *opcode-table* number) opcode) + (setf (gethash name *opcodes*) opcode) + (setf (gethash number *opcodes*) opcode))) + +(defmacro define-opcode (name number size stack-effect) + `(%define-opcode ',name ,number ,size ,stack-effect)) + +;; name number size stack-effect (nil if unknown) +(define-opcode nop 0 1 0) +(define-opcode aconst_null 1 1 1) +(define-opcode iconst_m1 2 1 1) +(define-opcode iconst_0 3 1 1) +(define-opcode iconst_1 4 1 1) +(define-opcode iconst_2 5 1 1) +(define-opcode iconst_3 6 1 1) +(define-opcode iconst_4 7 1 1) +(define-opcode iconst_5 8 1 1) +(define-opcode lconst_0 9 1 2) +(define-opcode lconst_1 10 1 2) +(define-opcode fconst_0 11 1 1) +(define-opcode fconst_1 12 1 1) +(define-opcode fconst_2 13 1 1) +(define-opcode dconst_0 14 1 2) +(define-opcode dconst_1 15 1 2) +(define-opcode bipush 16 2 1) +(define-opcode sipush 17 3 1) +(define-opcode ldc 18 2 1) +(define-opcode ldc_w 19 3 1) +(define-opcode ldc2_w 20 3 2) +(define-opcode iload 21 2 1) +(define-opcode lload 22 2 2) +(define-opcode fload 23 2 nil) +(define-opcode dload 24 2 nil) +(define-opcode aload 25 2 1) +(define-opcode iload_0 26 1 1) +(define-opcode iload_1 27 1 1) +(define-opcode iload_2 28 1 1) +(define-opcode iload_3 29 1 1) +(define-opcode lload_0 30 1 2) +(define-opcode lload_1 31 1 2) +(define-opcode lload_2 32 1 2) +(define-opcode lload_3 33 1 2) +(define-opcode fload_0 34 1 nil) +(define-opcode fload_1 35 1 nil) +(define-opcode fload_2 36 1 nil) +(define-opcode fload_3 37 1 nil) +(define-opcode dload_0 38 1 nil) +(define-opcode dload_1 39 1 nil) +(define-opcode dload_2 40 1 nil) +(define-opcode dload_3 41 1 nil) +(define-opcode aload_0 42 1 1) +(define-opcode aload_1 43 1 1) +(define-opcode aload_2 44 1 1) +(define-opcode aload_3 45 1 1) +(define-opcode iaload 46 1 nil) +(define-opcode laload 47 1 nil) +(define-opcode faload 48 1 nil) +(define-opcode daload 49 1 nil) +(define-opcode aaload 50 1 -1) +(define-opcode baload 51 1 nil) +(define-opcode caload 52 1 nil) +(define-opcode saload 53 1 nil) +(define-opcode istore 54 2 -1) +(define-opcode lstore 55 2 -2) +(define-opcode fstore 56 2 nil) +(define-opcode dstore 57 2 nil) +(define-opcode astore 58 2 -1) +(define-opcode istore_0 59 1 -1) +(define-opcode istore_1 60 1 -1) +(define-opcode istore_2 61 1 -1) +(define-opcode istore_3 62 1 -1) +(define-opcode lstore_0 63 1 -2) +(define-opcode lstore_1 64 1 -2) +(define-opcode lstore_2 65 1 -2) +(define-opcode lstore_3 66 1 -2) +(define-opcode fstore_0 67 1 nil) +(define-opcode fstore_1 68 1 nil) +(define-opcode fstore_2 69 1 nil) +(define-opcode fstore_3 70 1 nil) +(define-opcode dstore_0 71 1 nil) +(define-opcode dstore_1 72 1 nil) +(define-opcode dstore_2 73 1 nil) +(define-opcode dstore_3 74 1 nil) +(define-opcode astore_0 75 1 -1) +(define-opcode astore_1 76 1 -1) +(define-opcode astore_2 77 1 -1) +(define-opcode astore_3 78 1 -1) +(define-opcode iastore 79 1 nil) +(define-opcode lastore 80 1 nil) +(define-opcode fastore 81 1 nil) +(define-opcode dastore 82 1 nil) +(define-opcode aastore 83 1 -3) +(define-opcode bastore 84 1 nil) +(define-opcode castore 85 1 nil) +(define-opcode sastore 86 1 nil) +(define-opcode pop 87 1 -1) +(define-opcode pop2 88 1 -2) +(define-opcode dup 89 1 1) +(define-opcode dup_x1 90 1 1) +(define-opcode dup_x2 91 1 1) +(define-opcode dup2 92 1 2) +(define-opcode dup2_x1 93 1 2) +(define-opcode dup2_x2 94 1 2) +(define-opcode swap 95 1 0) +(define-opcode iadd 96 1 -1) +(define-opcode ladd 97 1 -2) +(define-opcode fadd 98 1 -1) +(define-opcode dadd 99 1 -2) +(define-opcode isub 100 1 -1) +(define-opcode lsub 101 1 -2) +(define-opcode fsub 102 1 -1) +(define-opcode dsub 103 1 -2) +(define-opcode imul 104 1 -1) +(define-opcode lmul 105 1 -2) +(define-opcode fmul 106 1 -1) +(define-opcode dmul 107 1 -2) +(define-opcode idiv 108 1 nil) +(define-opcode ldiv 109 1 nil) +(define-opcode fdiv 110 1 nil) +(define-opcode ddiv 111 1 nil) +(define-opcode irem 112 1 nil) +(define-opcode lrem 113 1 nil) +(define-opcode frem 114 1 nil) +(define-opcode drem 115 1 nil) +(define-opcode ineg 116 1 0) +(define-opcode lneg 117 1 0) +(define-opcode fneg 118 1 0) +(define-opcode dneg 119 1 0) +(define-opcode ishl 120 1 -1) +(define-opcode lshl 121 1 -1) +(define-opcode ishr 122 1 -1) +(define-opcode lshr 123 1 -1) +(define-opcode iushr 124 1 nil) +(define-opcode lushr 125 1 nil) +(define-opcode iand 126 1 -1) +(define-opcode land 127 1 -2) +(define-opcode ior 128 1 -1) +(define-opcode lor 129 1 -2) +(define-opcode ixor 130 1 -1) +(define-opcode lxor 131 1 -2) +(define-opcode iinc 132 3 0) +(define-opcode i2l 133 1 1) +(define-opcode i2f 134 1 0) +(define-opcode i2d 135 1 1) +(define-opcode l2i 136 1 -1) +(define-opcode l2f 137 1 -1) +(define-opcode l2d 138 1 0) +(define-opcode f2i 139 1 nil) +(define-opcode f2l 140 1 nil) +(define-opcode f2d 141 1 1) +(define-opcode d2i 142 1 nil) +(define-opcode d2l 143 1 nil) +(define-opcode d2f 144 1 -1) +(define-opcode i2b 145 1 nil) +(define-opcode i2c 146 1 nil) +(define-opcode i2s 147 1 nil) +(define-opcode lcmp 148 1 -3) +(define-opcode fcmpl 149 1 -1) +(define-opcode fcmpg 150 1 -1) +(define-opcode dcmpl 151 1 -3) +(define-opcode dcmpg 152 1 -3) +(define-opcode ifeq 153 3 -1) +(define-opcode ifne 154 3 -1) +(define-opcode iflt 155 3 -1) +(define-opcode ifge 156 3 -1) +(define-opcode ifgt 157 3 -1) +(define-opcode ifle 158 3 -1) +(define-opcode if_icmpeq 159 3 -2) +(define-opcode if_icmpne 160 3 -2) +(define-opcode if_icmplt 161 3 -2) +(define-opcode if_icmpge 162 3 -2) +(define-opcode if_icmpgt 163 3 -2) +(define-opcode if_icmple 164 3 -2) +(define-opcode if_acmpeq 165 3 -2) +(define-opcode if_acmpne 166 3 -2) +(define-opcode goto 167 3 0) +(define-opcode jsr 168 3 1) +(define-opcode ret 169 2 0) +(define-opcode tableswitch 170 0 nil) +(define-opcode lookupswitch 171 0 nil) +(define-opcode ireturn 172 1 nil) +(define-opcode lreturn 173 1 nil) +(define-opcode freturn 174 1 nil) +(define-opcode dreturn 175 1 nil) +(define-opcode areturn 176 1 -1) +(define-opcode return 177 1 0) +(define-opcode getstatic 178 3 1) +(define-opcode putstatic 179 3 -1) +(define-opcode getfield 180 3 0) +(define-opcode putfield 181 3 -2) +(define-opcode invokevirtual 182 3 nil) +(define-opcode invokespecial 183 3 nil) +(define-opcode invokestatic 184 3 nil) +(define-opcode invokeinterface 185 5 nil) +(define-opcode unused 186 0 nil) +(define-opcode new 187 3 1) +(define-opcode newarray 188 2 nil) +(define-opcode anewarray 189 3 0) +(define-opcode arraylength 190 1 0) +(define-opcode athrow 191 1 0) +(define-opcode checkcast 192 3 0) +(define-opcode instanceof 193 3 0) +(define-opcode monitorenter 194 1 nil) +(define-opcode monitorexit 195 1 nil) +(define-opcode wide 196 0 nil) +(define-opcode multianewarray 197 4 nil) +(define-opcode ifnull 198 3 -1) +(define-opcode ifnonnull 199 3 nil) +(define-opcode goto_w 200 5 nil) +(define-opcode jsr_w 201 5 nil) +(define-opcode label 202 0 0) +;; (define-opcode push-value 203 nil 1) +;; (define-opcode store-value 204 nil -1) +(define-opcode clear-values 205 0 0) +;;(define-opcode var-ref 206 0 0) + +(defparameter *last-opcode* 206) + +(declaim (ftype (function (t) t) opcode-name)) +(defun opcode-name (opcode-number) + (let ((opcode (gethash opcode-number *opcodes*))) + (and opcode (jvm-opcode-name opcode)))) + +(declaim (ftype (function (t) (integer 0 255)) opcode-number)) +(defun opcode-number (opcode-name) + (declare (optimize speed)) + (let ((opcode (gethash (string opcode-name) *opcodes*))) + (if opcode + (jvm-opcode-number opcode) + (error "Unknown opcode ~S." opcode-name)))) + +(declaim (ftype (function (t) fixnum) opcode-size)) +(defun opcode-size (opcode-number) + (declare (optimize speed (safety 0))) + (declare (type (integer 0 255) opcode-number)) + (jvm-opcode-size (svref *opcode-table* opcode-number))) + +(declaim (ftype (function (t) t) opcode-stack-effect)) +(defun opcode-stack-effect (opcode-number) + (declare (optimize speed)) + (jvm-opcode-stack-effect (svref *opcode-table* opcode-number))) + +(provide '#:opcodes) Added: branches/save-image/src/org/armedbear/lisp/open.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/open.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,219 @@ +;;; open.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: open.lisp 11434 2008-12-07 23:24:31Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defun upgraded-element-type-bits (bits) + (if (zerop (mod bits 8)) + bits + (+ bits (- 8 (mod bits 8))))) + +(defun upgraded-element-type (element-type) + (setf element-type (normalize-type element-type)) + (let ((ok nil)) + (if (atom element-type) + (case element-type + ((character base-char) + (setf ok t)) + ((unsigned-byte signed-byte) + (setf element-type (list element-type 8) + ok t)) + (bit + (setf element-type (list 'unsigned-byte (upgraded-element-type-bits 1)) + ok t)) + (integer + (setf element-type '(signed-byte 8) + ok t))) + (cond ((eq (%car element-type) 'or) + (let ((types (mapcar #'upgraded-element-type (%cdr element-type))) + (result '(unsigned-byte 8))) + (dolist (type types) + (when (eq (car type) 'signed-byte) + (setf (car result) 'signed-byte)) + (setf (cadr result) (max (cadr result) (cadr type)))) + (setf element-type result + ok t))) + ((and (= (length element-type) 2) + (memq (%car element-type) '(unsigned-byte signed-byte))) + (let ((type (car element-type)) + (width (cadr element-type))) + (setf element-type (list type + (upgraded-element-type-bits width)) + ok t))) + ((eq (car element-type) 'integer) + (case (length element-type) + (2 + (setf element-type '(signed-byte 8) + ok t)) + (3 + (let ((low (cadr element-type)) + (high (caddr element-type))) + (when (consp low) + (setf low (1+ (%car low)))) + (when (consp high) + (setf high (1- (%car high)))) + (setf element-type + (cond ((eq high '*) + (if (minusp low) '(signed-byte 8) '(unsigned-byte 8))) + ((minusp low) + (list 'signed-byte + (upgraded-element-type-bits (max (1+ (integer-length low)) + (integer-length high))))) + (t + (list 'unsigned-byte + (upgraded-element-type-bits (integer-length high))))) + ok t))))))) + (if ok + element-type + (error 'file-error + :format-control "Unsupported element type ~S." + :format-arguments (list element-type))))) + +(defun open (filename + &key + (direction :input) + (element-type 'character) + (if-exists nil if-exists-given) + (if-does-not-exist nil if-does-not-exist-given) + (external-format :default)) +; (declare (ignore external-format)) ; FIXME + (setf element-type (case element-type + ((character base-char) + 'character) + (:default + '(unsigned-byte 8)) + (t + (upgraded-element-type element-type)))) + (let* ((pathname (merge-pathnames filename)) + (namestring (namestring (if (typep pathname 'logical-pathname) + (translate-logical-pathname pathname) + pathname)))) + (when (memq direction '(:output :io)) + (unless if-exists-given + (setf if-exists + (if (eq (pathname-version pathname) :newest) + :new-version + :error)))) + (unless if-does-not-exist-given + (setf if-does-not-exist + (cond ((eq direction :input) :error) + ((and (memq direction '(:output :io)) + (memq if-exists '(:overwrite :append))) + :error) + ((eq direction :probe) + nil) + (t + :create)))) + (case direction + (:input + (case if-does-not-exist + (:error + (unless (probe-file pathname) + (error 'file-error + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list namestring))))) + (make-file-stream pathname namestring element-type :input nil external-format)) + (:probe + (case if-does-not-exist + (:error + (unless (probe-file pathname) + (error 'file-error + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list namestring)))) + (:create + ;; CREATE-NEW-FILE "atomically creates a new, empty file named by + ;; this abstract pathname if and only if a file with this name does + ;; not yet exist." See java.io.File.createNewFile(). + (create-new-file namestring))) + (let ((stream (make-file-stream pathname namestring element-type + :input nil external-format))) + (when stream + (close stream)) + stream)) + ((:output :io) + (case if-does-not-exist + (:error + (unless (probe-file pathname) + (error 'file-error + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list namestring)))) + ((nil) + (unless (probe-file pathname) + (return-from open nil)))) + (case if-exists + (:error + (when (probe-file pathname) + (error 'file-error + :pathname pathname + :format-control "The file ~S already exists." + :format-arguments (list namestring)))) + ((nil) + (when (probe-file pathname) + (return-from open nil))) + ((:rename :rename-and-delete) + (when (probe-file pathname) + ;; Make sure the original file is not a directory. + (when (probe-directory pathname) + (error 'file-error + :pathname pathname + :format-control "The file ~S is a directory." + :format-arguments (list namestring))) + (let ((backup-name (concatenate 'string namestring ".bak"))) + (when (probe-file backup-name) + (when (probe-directory backup-name) + (error 'file-error + :pathname pathname + :format-control "Unable to rename ~S." + :format-arguments (list namestring))) + (delete-file backup-name)) + (rename-file pathname backup-name)))) + ((:new-version :supersede :overwrite :append)) ; OK to proceed. + (t + (error 'simple-error + :format-control "Option not supported: ~S." + :format-arguments (list if-exists)))) + (let ((stream (make-file-stream pathname namestring element-type + direction if-exists external-format))) + (unless stream + (error 'file-error + :pathname pathname + :format-control "Unable to open ~S." + :format-arguments (list namestring))) + stream)) + (t + (error 'simple-error + :format-control ":DIRECTION ~S not supported." + :format-arguments (list direction)))))) Added: branches/save-image/src/org/armedbear/lisp/open_stream_p.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/open_stream_p.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * open_stream_p.java + * + * Copyright (C) 2004 Peter Graves + * $Id: open_stream_p.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### open-stream-p +public final class open_stream_p extends Primitive +{ + private open_stream_p() + { + super("open-stream-p"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((Stream)arg).isOpen() ? T : NIL; + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.STREAM)); + } + } + + private static final Primitive OPEN_STREAM_P = new open_stream_p(); +} Added: branches/save-image/src/org/armedbear/lisp/or.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/or.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,44 @@ +;;; or.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: or.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package "SYSTEM") + +(defmacro or (&rest forms) + (cond ((endp forms) nil) + ((endp (rest forms)) (first forms)) + (t + (let ((n-result (gensym))) + `(let ((,n-result ,(first forms))) + (if ,n-result + ,n-result + (or ,@(rest forms)))))))) Added: branches/save-image/src/org/armedbear/lisp/output_stream_p.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/output_stream_p.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * output_stream_p.java + * + * Copyright (C) 2004 Peter Graves + * $Id: output_stream_p.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### output-stream-p +public final class output_stream_p extends Primitive +{ + private output_stream_p() + { + super("output-stream-p"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((Stream)arg).isOutputStream() ? T : NIL; + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.STREAM)); + } + } + + private static final Primitive OUTPUT_STREAM_P = new output_stream_p(); +} Added: branches/save-image/src/org/armedbear/lisp/package.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/package.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,94 @@ +;;; package.lisp +;;; +;;; Copyright (C) 2008 Erik Huelsmann +;;; $Id: package.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;; Redefines make-package from boot.lisp + +(defun make-package (name &key nicknames use) + (restart-case + (progn + (when (find-package name) + (error 'simple-error "Package ~A already exists." name)) + (dolist (nick nicknames) + (when (find-package nick) + (error 'package-error :package nick))) + (%make-package name nicknames use)) + (use-existing-package () + :report "Use existing package" + (return-from make-package (find-package name))))) + +;; Redefines function from defpackage.lisp, because there it's lacking restart-case + +(defun ensure-available-symbols (imports) + (remove nil + (mapcar #'(lambda (package-and-symbols) + (let* ((package (find-package (designated-package-name (car package-and-symbols)))) + (new-symbols + (remove nil + (mapcar #'(lambda (sym) + (restart-case + (progn + (unless (find-symbol sym package) + (error 'package-error + "The symbol ~A is not present in package ~A." sym (package-name package))) + sym) + (skip () + :report "Skip this symbol." + nil))) + (cdr package-and-symbols))))) + (when new-symbols + (cons package new-symbols)))) + imports))) + + + + +(defun import (symbols &optional (package *package* package-supplied-p)) + (dolist (symbol (if (listp symbols) symbols (list symbols))) + (let* ((sym-name (string symbol)) + (local-sym (find-symbol sym-name package))) + (restart-case + (progn + (when (and local-sym (not (eql symbol local-sym))) + (error 'package-error + "Different symbol (~A) with the same name already accessible in package ~A." + local-sym (package-name package))) + (if package-supplied-p + (%import (list symbol) package) ;; in order to pass NIL, wrap in a list + (%import (list symbol)))) + (unintern-existing () + :report (lambda (s) (format s "Unintern ~S and continue" local-sym)) + (unintern local-sym) + (%import symbol)) + (skip () + :report "Skip symbol")))) + T) Added: branches/save-image/src/org/armedbear/lisp/package_error_package.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/package_error_package.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,57 @@ +/* + * package_error_package.java + * + * Copyright (C) 2003-2004 Peter Graves + * $Id: package_error_package.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### package-error-package +public final class package_error_package extends Primitive +{ + private package_error_package() + { + super("package-error-package"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((PackageError)arg).getPackage(); + } + catch (ClassCastException e) { + return error(new TypeError(arg, Symbol.PACKAGE_ERROR)); + } + } + + private static final Primitive PACKAGE_ERROR_PACKAGE = + new package_error_package(); +} Added: branches/save-image/src/org/armedbear/lisp/parse-integer.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/parse-integer.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,80 @@ +;;; parse-integer.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: parse-integer.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; From OpenMCL. + +(defun parse-integer-error (string) + (error 'parse-error "not an integer string: ~S" string)) + +(defun parse-integer (string &key (start 0) end + (radix 10) junk-allowed) + (when (null end) + (setq end (length string))) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (parse-integer-error string))) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (setq index (1+ index))) + ((char= char #\+) + (setq index (1+ index))))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) + (do () ((= (setq index (1+ index)) end)) + (unless (whitespacep (char string index)) + (parse-integer-error string))) + (return nil)) + (t + (parse-integer-error string)))) + (setq index (1+ index))) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (parse-integer-error string))) + index))) Added: branches/save-image/src/org/armedbear/lisp/parse-lambda-list.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/parse-lambda-list.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,170 @@ +;;; parse-lambda-list.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: parse-lambda-list.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package "SYSTEM") + +(require '#:collect) + +;;; Break something like a lambda list (but not necessarily actually a +;;; lambda list, e.g. the representation of argument types which is +;;; used within an FTYPE specification) into its component parts. We +;;; return 10 values: +;;; 1. a list of the required args; +;;; 2. a list of the &OPTIONAL arg specs; +;;; 3. true if a &REST arg was specified; +;;; 4. the &REST arg; +;;; 5. true if &KEY args are present; +;;; 6. a list of the &KEY arg specs; +;;; 7. true if &ALLOW-OTHER-KEYS was specified.; +;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL); +;;; 9. a list of the &AUX specifiers; +;;; 10. true if any lambda list keyword is present (only for +;;; PARSE-LAMBDA-LIST-LIKE-THING). +;;; +;;; The top level lambda list syntax is checked for validity, but the +;;; arg specifiers are just passed through untouched. If something is +;;; wrong, we signal an error. + +(defun parse-lambda-list-like-thing (list) + (collect ((required) + (optional) + (keys) + (aux)) + (let ((restp nil) + (rest nil) + (keyp nil) + (auxp nil) + (allowp nil) + (state :required)) + (declare (type (member :allow-other-keys :aux + :key + :optional + :post-rest + :required :rest) + state)) + (dolist (arg list) + (if (and (symbolp arg) + (let ((name (symbol-name (the symbol arg)))) + (and (plusp (length name)) + (char= (char name 0) #\&)))) + (case arg + (&optional + (unless (eq state :required) + (error "misplaced &OPTIONAL in lambda list: ~S" list)) + (setq state :optional)) + (&rest + (unless (member state '(:required :optional)) + (error "misplaced &REST in lambda list: ~S" list)) + (setq state :rest)) + (&key + (unless (member state + '(:required :optional :post-rest)) + (error "misplaced &KEY in lambda list: ~S" list)) + (setq keyp t + state :key)) + (&allow-other-keys + (unless (eq state ':key) + (error "misplaced &ALLOW-OTHER-KEYS in lambda list: ~S" list)) + (setq allowp t + state :allow-other-keys)) + (&aux + (when (eq state :rest) + (error "misplaced &AUX in lambda list: ~S" list)) + (setq auxp t + state :aux)) + ;; FIXME: I don't think ANSI says this is an error. (It + ;; should certainly be good for a STYLE-WARNING, + ;; though.) + (t + (error "unknown &KEYWORD in lambda list: ~S" arg))) + (case state + (:required (required arg)) + (:optional (optional arg)) + (:rest + (setq restp t + rest arg + state :post-rest)) + (:key (keys arg)) + (:aux (aux arg)) + (t + (error "found garbage in lambda list when expecting a keyword: ~S" + arg))))) + (when (eq state :rest) + (error "&REST without rest variable")) + + (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) + (neq state :required))))) + +;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument +;;; really *is* a lambda list, not just a "lambda-list-like thing", so +;;; can barf on things which're illegal as arguments in lambda lists +;;; even if they could conceivably be legal in not-quite-a-lambda-list +;;; weirdosities +(defun parse-lambda-list (lambda-list) + ;; Classify parameters without checking their validity individually. + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) + (parse-lambda-list-like-thing lambda-list) + ;; Check validity of parameters. + (flet ((need-symbol (x why) + (unless (symbolp x) + (error "~A is not a symbol: ~S" why x)))) + (dolist (i required) + (need-symbol i "Required argument")) + (dolist (i optional) + (typecase i + (symbol) + (cons + (destructuring-bind (var &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (need-symbol var "&OPTIONAL parameter name"))) + (t + (error "&OPTIONAL parameter is not a symbol or cons: ~S" i)))) + (when restp + (need-symbol rest "&REST argument")) + (when keyp + (dolist (i keys) + (typecase i + (symbol) + (cons + (destructuring-bind (var-or-kv &optional init-form supplied-p) i + (declare (ignore init-form supplied-p)) + (if (consp var-or-kv) + (destructuring-bind (keyword-name var) var-or-kv + (declare (ignore keyword-name)) + (need-symbol var "&KEY parameter name")) + (need-symbol var-or-kv "&KEY parameter name")))) + (t + (error "&KEY parameter is not a symbol or cons: ~S" i)))))) + + ;; Voila. + (values required optional restp rest keyp keys allowp auxp aux))) Added: branches/save-image/src/org/armedbear/lisp/pathnames.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/pathnames.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,404 @@ +;;; pathnames.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: pathnames.lisp 11577 2009-01-23 19:37:18Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export '(logical-host-p)) + +(defun pathname-host (pathname &key (case :local)) + (%pathname-host pathname case)) + +(defun pathname-device (pathname &key (case :local)) + (%pathname-device pathname case)) + +(defun pathname-directory (pathname &key (case :local)) + (%pathname-directory pathname case)) + +(defun pathname-name (pathname &key (case :local)) + (%pathname-name pathname case)) + +(defun pathname-type (pathname &key (case :local)) + (%pathname-type pathname case)) + +(defun wild-pathname-p (pathname &optional field-key) + (%wild-pathname-p pathname field-key)) + +(defun component-match-wild-p (thing wild ignore-case) + (let ((testfunc (if ignore-case #'equalp #'equal))) + (labels ((split-string (delim str) + (flet ((finder (char) (find char delim))) + (loop for x = (position-if-not #'finder str) then + (position-if-not #'finder str :start (or y (length str))) + for y = (position-if #'finder str :start x) then + (position-if #'finder str :start (or x (length str))) while x + collect (subseq str x y)))) + (positions-larger (thing substrings previous-pos) + (let ((new-pos (search (car substrings) + thing + :start2 previous-pos + :test testfunc))) + (or + (not substrings) + (and new-pos + (>= new-pos previous-pos) + (positions-larger thing + (cdr substrings) + new-pos)))))) + (let ((split-result (split-string "*" wild))) + (and (positions-larger thing split-result 0) + (if (eql (elt wild 0) #\*) + t + (eql (search (first split-result) thing :test testfunc) 0)) + (if (eql (elt wild (1- (length wild))) #\*) + t + (let ((last-split-result (first (last split-result)))) + (eql (search last-split-result thing :from-end t + :test testfunc) + (- (length thing) (length last-split-result)))))))))) + +(defun component-match-p (thing wild ignore-case) + (cond ((eq wild :wild) + t) + ((null wild) + t) + ((and (stringp wild) (position #\* wild)) + (component-match-wild-p thing wild ignore-case)) + (ignore-case + (equalp thing wild)) + (t + (equal thing wild)))) + +(defun directory-match-components (thing wild ignore-case) + (loop + (cond ((endp thing) + (return (or (endp wild) (equal wild '(:wild-inferiors))))) + ((endp wild) + (return nil))) + (let ((x (car thing)) + (y (car wild))) + (when (eq y :wild-inferiors) + (return t)) + (unless (component-match-p x y ignore-case) + (return nil)) + (setf thing (cdr thing) + wild (cdr wild))))) + +(defun directory-match-p (thing wild ignore-case) + (cond ((eq wild :wild) + t) + ((null wild) + t) + ((and ignore-case (equalp thing wild)) + t) + ((equal thing wild) + t) + ((and (null thing) (equal wild '(:absolute :wild-inferiors))) + t) + ((and (consp thing) (consp wild)) + (if (eq (%car thing) (%car wild)) + (directory-match-components (%cdr thing) (%cdr wild) ignore-case) + nil)) + (t + nil))) + +(defun pathname-match-p (pathname wildcard) + (setf pathname (pathname pathname) + wildcard (pathname wildcard)) + (unless (component-match-p (pathname-host pathname) (pathname-host wildcard) nil) + (return-from pathname-match-p nil)) + (let* ((windows-p (featurep :windows)) + (ignore-case (or windows-p (typep pathname 'logical-pathname)))) + (cond ((and windows-p + (not (component-match-p (pathname-device pathname) + (pathname-device wildcard) + ignore-case))) + nil) + ((not (directory-match-p (pathname-directory pathname) + (pathname-directory wildcard) + ignore-case)) + nil) + ((not (component-match-p (pathname-name pathname) + (pathname-name wildcard) + ignore-case)) + nil) + ((not (component-match-p (pathname-type pathname) + (pathname-type wildcard) + ignore-case)) + nil) + (t + t)))) + +(defun wild-p (component) + (or (eq component :wild) + (and (stringp component) + (position #\* component)))) + +(defun casify (thing case) + (typecase thing + (string + (case case + (:upcase (string-upcase thing)) + (:downcase (string-downcase thing)) + (t thing))) + (list + (let (result) + (dolist (component thing (nreverse result)) + (push (casify component case) result)))) + (t + thing))) + +(defun split-directory-components (directory) + (declare (optimize safety)) + (declare (type list directory)) + (unless (memq (car directory) '(:absolute :relative)) + (error "Ill-formed directory list: ~S" directory)) + (let (result sublist) + (push (car directory) result) + (dolist (component (cdr directory)) + (cond ((memq component '(:wild :wild-inferiors)) + (when sublist + (push (nreverse sublist) result) + (setf sublist nil)) + (push component result)) + (t + (push component sublist)))) + (when sublist + (push (nreverse sublist) result)) + (nreverse result))) + +(defun translate-component (source from to &optional case) + (declare (ignore from)) + (cond ((or (eq to :wild) (null to)) + ;; "If the piece in TO-WILDCARD is :WILD or NIL, the piece in source + ;; is copied into the result." + (casify source case)) + ((and to (not (wild-p to))) + ;; "If the piece in TO-WILDCARD is present and not wild, it is copied + ;; into the result." + to) + (t + ;; "Otherwise, the piece in TO-WILDCARD might be a complex wildcard + ;; such as "foo*bar" and the piece in FROM-WILDCARD should be wild; + ;; the portion of the piece in SOURCE that matches the wildcard + ;; portion of the piece in FROM-WILDCARD replaces the wildcard portion + ;; of the piece in TO-WILDCARD and the value produced is used in the + ;; result." + ;; FIXME + (error "Unsupported wildcard pattern: ~S" to)))) + +(defun translate-directory-components (source from to case) + (cond ((null to) + nil + ) + ((memq (car to) '(:absolute :relative)) + (cons (car to) + (translate-directory-components (cdr source) (cdr from) (cdr to) case)) + ) + ((eq (car to) :wild) + (if (eq (car from) :wild) + ;; Grab the next chunk from SOURCE. + (append (casify (car source) case) + (translate-directory-components (cdr source) (cdr from) (cdr to) case)) + (error "Unsupported case 1: ~S ~S ~S" source from to)) + ) + ((eq (car to) :wild-inferiors) + ;; Grab the next chunk from SOURCE. + (append (casify (car source) case) + (translate-directory-components (cdr source) (cdr from) (cdr to) case)) + ) + (t + ;; "If the piece in TO-WILDCARD is present and not wild, it is copied + ;; into the result." + (append (casify (car to) case) + (translate-directory-components source from (cdr to) case)) + ) + )) + +(defun translate-directory (source from to case) + ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on + ;; Windows or if the source pathname is a logical pathname. + ;; FIXME We can canonicalize logical pathnames to upper case, so we only need + ;; IGNORE-CASE for Windows. + (cond ((null source) + to) + ((equal source '(:absolute)) + (remove :wild-inferiors to)) + (t + (translate-directory-components (split-directory-components source) + (split-directory-components from) + (split-directory-components to) + case)))) + +;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field +;; replaced by a portion of SOURCE." +(defun translate-pathname (source from-wildcard to-wildcard &key) + (unless (pathname-match-p source from-wildcard) + (error "~S and ~S do not match." source from-wildcard)) + (let* ((source (pathname source)) + (from (pathname from-wildcard)) + (to (pathname to-wildcard)) + (device (if (typep 'to 'logical-pathname) + :unspecific + (translate-component (pathname-device source) + (pathname-device from) + (pathname-device to)))) + (case (and (typep source 'logical-pathname) + (or (featurep :unix) (featurep :windows)) + :downcase))) + (make-pathname :host (pathname-host to) + :device (cond ((typep to 'logical-pathname) + :unspecific) + ((eq device :unspecific) + nil) + (t + device)) + :directory (translate-directory (pathname-directory source) + (pathname-directory from) + (pathname-directory to) + case) + :name (translate-component (pathname-name source) + (pathname-name from) + (pathname-name to) + case) + :type (translate-component (pathname-type source) + (pathname-type from) + (pathname-type to) + case) + :version (if (null (pathname-host from)) + (if (eq (pathname-version to) :wild) + (pathname-version from) + (pathname-version to)) + (translate-component (pathname-version source) + (pathname-version from) + (pathname-version to)))))) + +(defun logical-host-p (canonical-host) + (multiple-value-bind (translations present) + (gethash canonical-host *logical-pathname-translations*) + (declare (ignore translations)) + present)) + +(defun logical-pathname-translations (host) + (multiple-value-bind (translations present) + (gethash (canonicalize-logical-host host) *logical-pathname-translations*) + (unless present + (error 'type-error + :datum host + :expected-type '(and string (satisfies logical-host-p)))) + translations)) + +(defun canonicalize-logical-pathname-translations (translations host) + (let (result) + (dolist (translation translations (nreverse result)) + (let ((from (car translation)) + (to (cadr translation))) + (push (list (if (typep from 'logical-pathname) + from + (parse-namestring from host)) + (pathname to)) + result))))) + +(defun %set-logical-pathname-translations (host translations) + (setf host (canonicalize-logical-host host)) + ;; Avoid undefined host error in CANONICALIZE-LOGICAL-PATHNAME-TRANSLATIONS. + (unless (logical-host-p host) + (setf (gethash host *logical-pathname-translations*) nil)) + (setf (gethash host *logical-pathname-translations*) + (canonicalize-logical-pathname-translations translations host))) + +(defsetf logical-pathname-translations %set-logical-pathname-translations) + +(defun translate-logical-pathname (pathname &key) + (typecase pathname + (logical-pathname + (let* ((host (pathname-host pathname)) + (translations (logical-pathname-translations host))) + (dolist (translation translations + (error 'file-error + :pathname pathname + :format-control "No translation for ~S" + :format-arguments (list pathname))) + (let ((from-wildcard (car translation)) + (to-wildcard (cadr translation))) + (when (pathname-match-p pathname from-wildcard) + (return (translate-logical-pathname + (translate-pathname pathname from-wildcard to-wildcard)))))))) + (pathname pathname) + (t + (translate-logical-pathname (pathname pathname))))) + +(defun load-logical-pathname-translations (host) + (declare (type string host)) + (multiple-value-bind (ignore found) + (gethash (canonicalize-logical-host host) + *logical-pathname-translations*) + (declare (ignore ignore)) + (unless found + (error "The logical host ~S was not found." host)))) + +(defun logical-pathname (pathspec) + (typecase pathspec + (logical-pathname pathspec) + (string + (%make-logical-pathname pathspec)) + (stream + (let ((result (pathname pathspec))) + (if (typep result 'logical-pathname) + result + (error 'simple-type-error + :datum result + :expected-type 'logical-pathname)))) + (t + (error 'type-error + :datum pathspec + :expected-type '(or logical-pathname string stream))))) + +(defun parse-namestring (thing + &optional host (default-pathname *default-pathname-defaults*) + &key (start 0) end junk-allowed) + (declare (ignore junk-allowed)) ; FIXME + (cond ((eq host :unspecific) + (setf host nil)) + (host + (setf host (canonicalize-logical-host host)))) + (typecase thing + (stream + (values (pathname thing) start)) + (pathname + (values thing start)) + (string + (unless end + (setf end (length thing))) + (%parse-namestring (subseq thing start end) host default-pathname)) + (t + (error 'type-error + :format-control "~S cannot be converted to a pathname." + :format-arguments (list thing))))) Added: branches/save-image/src/org/armedbear/lisp/peek_char.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/peek_char.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,112 @@ +/* + * peek_char.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: peek_char.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### peek-char +public final class peek_char extends Primitive +{ + private peek_char() + { + super("peek-char", + "&optional peek-type input-stream eof-error-p eof-value recursive-p"); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + int length = args.length; + if (length > 5) + error(new WrongNumberOfArgumentsException(this)); + LispObject peekType = length > 0 ? args[0] : NIL; + Stream stream = length > 1 ? inSynonymOf(args[1]) : getStandardInput(); + boolean eofError = length > 2 ? (args[2] != NIL) : true; + LispObject eofValue = length > 3 ? args[3] : NIL; + // recursive-p is ignored + // boolean recursive = length > 4 ? (args[4] != NIL) : false; + if (peekType == NIL) { + // "If PEEK-TYPE is not supplied or NIL, PEEK-CHAR returns the next + // character to be read from INPUT-STREAM, without actually + // removing it from INPUT-STREAM." + final Stream in; + if (stream instanceof EchoStream) + // "When INPUT-STREAM is an echo stream, characters that are + // only peeked at are not echoed." Read from the echo stream's + // input stream to bypass the echo. + in = ((EchoStream)stream).getInputStream(); + else + in = stream; + final LispObject result = in.readChar(eofError, eofValue); + if (result instanceof LispCharacter) + in.unreadChar((LispCharacter)result); + return result; + } + if (peekType == T) { + // "If PEEK-TYPE is T, then PEEK-CHAR skips over whitespace[2] + // characters, but not comments, and then performs the peeking + // operation on the next character." + Readtable rt = currentReadtable(); + while (true) { + LispObject result = stream.readChar(eofError, eofValue); + if (result instanceof LispCharacter) { + char c = ((LispCharacter)result).value; + if (!rt.isWhitespace(c)) { + stream.unreadChar((LispCharacter)result); + return result; + } + } else + return result; + } + } + if (peekType instanceof LispCharacter) { + // "If PEEK-TYPE is a character, then PEEK-CHAR skips over input + // characters until a character that is CHAR= to that character is + // found; that character is left in INPUT-STREAM." + char c = ((LispCharacter)peekType).value; + while (true) { + LispObject result = stream.readChar(eofError, eofValue); + if (result instanceof LispCharacter) { + if (((LispCharacter)result).value == c) { + stream.unreadChar((LispCharacter)result); + return result; + } + } else + return result; + } + } + return error(new SimpleError(String.valueOf(peekType) + + " is an illegal peek-type.")); + } + + private static final Primitive PEEK_CHAR = new peek_char(); +} Added: branches/save-image/src/org/armedbear/lisp/pprint-dispatch.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/pprint-dispatch.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,335 @@ +;;; pprint-dispatch.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: pprint-dispatch.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from the November, 26 1991 version of Richard C. Waters' XP pretty +;;; printer. + +;------------------------------------------------------------------------ + +;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts. + +;Permission to use, copy, modify, and distribute this software and its +;documentation for any purpose and without fee is hereby granted, +;provided that this copyright and permission notice appear in all +;copies and supporting documentation, and that the name of M.I.T. not +;be used in advertising or publicity pertaining to distribution of the +;software without specific, written prior permission. M.I.T. makes no +;representations about the suitability of this software for any +;purpose. It is provided "as is" without express or implied warranty. + +; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +; SOFTWARE. + +;------------------------------------------------------------------------ + +(in-package #:xp) + +(defvar *ipd* nil ;see initialization at end of file. + "initial print dispatch table.") + +(defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil)) + (conses-with-cars (make-hash-table :test #'eq) :type hash-table) + (structures (make-hash-table :test #'eq) :type hash-table) + (others nil :type list)) + +;The list and the hash-tables contain entries of the +;following form. When stored in the hash tables, the test entry is +;the number of entries in the OTHERS list that have a higher priority. + +(defstruct (entry (:conc-name nil)) + (test nil) ;predicate function or count of higher priority others. + (fn nil) ;pprint function + (full-spec nil)) ;list of priority and type specifier + +(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) + (unless table + (setf table *ipd*)) + (sys::require-type table 'pprint-dispatch-table) + (let* ((new-conses-with-cars + (make-hash-table :test #'eq + :size (max (hash-table-count (conses-with-cars table)) 32))) + (new-structures + (make-hash-table :test #'eq + :size (max (hash-table-count (structures table)) 32)))) + (maphash #'(lambda (key value) + (setf (gethash key new-conses-with-cars) (copy-entry value))) + (conses-with-cars table)) + (maphash #'(lambda (key value) + (setf (gethash key new-structures) (copy-entry value))) + (structures table)) + (make-pprint-dispatch-table + :conses-with-cars new-conses-with-cars + :structures new-structures + :others (copy-list (others table))))) + +(defun set-pprint-dispatch (type-specifier function + &optional (priority 0) (table *print-pprint-dispatch*)) + (when (or (not (numberp priority)) (complexp priority)) + (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority)) + (set-pprint-dispatch+ type-specifier function priority table)) + +(defun set-pprint-dispatch+ (type-specifier function priority table) + (let* ((category (specifier-category type-specifier)) + (pred + (if (not (eq category 'other)) nil + (let ((pred (specifier-fn type-specifier))) + (if (and (consp (caddr pred)) + (symbolp (caaddr pred)) + (equal (cdaddr pred) '(x))) + (symbol-function (caaddr pred)) + ;; (compile nil pred) + pred + )))) + (entry (if function (make-entry :test pred + :fn function + :full-spec (list priority type-specifier))))) + (case category + (cons-with-car + (cond ((null entry) (remhash (cadadr type-specifier) (conses-with-cars table))) + (T (setf (test entry) + (count-if #'(lambda (e) + (priority-> (car (full-spec e)) priority)) + (others table))) + (setf (gethash (cadadr type-specifier) (conses-with-cars table)) entry)))) + (structure-type + (cond ((null entry) (remhash type-specifier (structures table))) + (T (setf (test entry) + (count-if #'(lambda (e) + (priority-> (car (full-spec e)) priority)) + (others table))) + (setf (gethash type-specifier (structures table)) entry)))) + (T ;other + (let ((old (car (member type-specifier (others table) :test #'equal + :key #'(lambda (e) (cadr (full-spec e))))))) + (when old + (setf (others table) (delete old (others table))) + (adjust-counts table (car (full-spec old)) -1))) + (when entry + (let ((others (cons nil (others table)))) + (do ((l others (cdr l))) + ((null (cdr l)) (rplacd l (list entry))) + (when (priority-> priority (car (full-spec (cadr l)))) + (rplacd l (cons entry (cdr l))) + (return nil))) + (setf (others table) (cdr others))) + (adjust-counts table priority 1))))) + nil) + +(defun priority-> (x y) + (if (consp x) + (if (consp y) (> (car x) (car y)) nil) + (if (consp y) T (> x y)))) + + +(defun adjust-counts (table priority delta) + (maphash #'(lambda (key value) + (declare (ignore key)) + (if (priority-> priority (car (full-spec value))) + (incf (test value) delta))) + (conses-with-cars table)) + (maphash #'(lambda (key value) + (declare (ignore key)) + (if (priority-> priority (car (full-spec value))) + (incf (test value) delta))) + (structures table))) + +(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) + (unless table + (setf table *ipd*)) + (let ((fn (get-printer object table))) + (values (or fn #'non-pretty-print) (not (null fn))))) + +(defun get-printer (object table) + (let* ((entry (if (consp object) + (gethash (car object) (conses-with-cars table)) + (gethash (type-of object) (structures table))))) + (if (not entry) + (setq entry (find object (others table) :test #'fits)) + (do ((i (test entry) (1- i)) + (l (others table) (cdr l))) + ((zerop i)) + (when (fits object (car l)) (setq entry (car l)) (return nil)))) + (when entry (fn entry)))) + +(defun fits (obj entry) (funcall (test entry) obj)) + +(defun specifier-category (spec) + (cond ((and (consp spec) + (eq (car spec) 'cons) + (consp (cdr spec)) + (null (cddr spec)) + (consp (cadr spec)) + (eq (caadr spec) 'member) + (consp (cdadr spec)) + (null (cddadr spec))) + 'cons-with-car) + ((and (symbolp spec) +;; (structure-type-p spec) + (get spec 'structure-printer) + ) + 'structure-type) + (T 'other))) + +(defvar *preds-for-specs* + '((T always-true) (cons consp) (simple-atom simple-atom-p) (other otherp) + (null null) (symbol symbolp) (atom atom) (cons consp) + (list listp) (number numberp) (integer integerp) + (rational rationalp) (float floatp) (complex complexp) + (character characterp) (string stringp) (bit-vector bit-vector-p) + (vector vectorp) (simple-vector simple-vector-p) + (simple-string simple-string-p) (simple-bit-vector simple-bit-vector-p) + (array arrayp) (package packagep) (function functionp) + (compiled-function compiled-function-p) (common commonp))) + +(defun always-true (x) (declare (ignore x)) T) + +(defun specifier-fn (spec) + `(lambda (x) ,(convert-body spec))) + +(defun convert-body (spec) + (cond ((atom spec) + (let ((pred (cadr (assoc spec *preds-for-specs*)))) + (if pred `(,pred x) `(typep x ',spec)))) + ((member (car spec) '(and or not)) + (cons (car spec) (mapcar #'convert-body (cdr spec)))) + ((eq (car spec) 'member) + `(member x ',(copy-list (cdr spec)))) + ((eq (car spec) 'cons) + `(and (consp x) + ,@(if (cdr spec) `((let ((x (car x))) + ,(convert-body (cadr spec))))) + ,@(if (cddr spec) `((let ((x (cdr x))) + ,(convert-body (caddr spec))))))) + ((eq (car spec) 'satisfies) + `(funcall (function ,(cadr spec)) x)) + ((eq (car spec) 'eql) + `(eql x ',(cadr spec))) + (t + `(typep x ',(copy-tree spec))))) + + + +(defun function-call-p (x) + (and (consp x) (symbolp (car x)) (fboundp (car x)))) + + + +(setq *ipd* (make-pprint-dispatch-table)) + +(set-pprint-dispatch+ '(satisfies function-call-p) 'fn-call '(-5) *ipd*) +(set-pprint-dispatch+ 'cons 'pprint-fill '(-10) *ipd*) + +(set-pprint-dispatch+ '(cons (member block)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member case)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member catch)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member ccase)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member compiler-let)) 'let-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member cond)) 'cond-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member ctypecase)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defconstant)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defmacro)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member define-modify-macro)) 'dmm-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defparameter)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defsetf)) 'defsetf-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member define-setf-method)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defstruct)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member deftype)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defun)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member defvar)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member do)) 'do-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member do*)) 'do-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member do-all-symbols)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member do-external-symbols)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member do-symbols)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member dolist)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member dotimes)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member ecase)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member etypecase)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member eval-when)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member flet)) 'flet-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member function)) 'function-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member labels)) 'flet-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member lambda)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member let)) 'let-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member let*)) 'let-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member locally)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member loop)) 'pretty-loop '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member macrolet)) 'flet-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member multiple-value-bind)) 'mvb-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member multiple-value-setq)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member prog)) 'prog-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member prog*)) 'prog-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member progv)) 'defun-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member psetf)) 'setq-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member psetq)) 'setq-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member quote)) 'quote-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member return-from)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member setf)) 'setq-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member setq)) 'setq-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member tagbody)) 'tagbody-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member throw)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member typecase)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member unless)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member unwind-protect)) 'up-print '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member when)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member with-input-from-string)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member with-open-file)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member with-open-stream)) 'block-like '(0) *ipd*) +(set-pprint-dispatch+ '(cons (member with-output-to-string)) 'block-like '(0) *ipd*) + +(defun pprint-dispatch-print (xp table) + (let ((stuff (copy-list (others table)))) + (maphash #'(lambda (key val) (declare (ignore key)) + (push val stuff)) + (conses-with-cars table)) + (maphash #'(lambda (key val) (declare (ignore key)) + (push val stuff)) + (structures table)) + (setq stuff (sort stuff #'priority-> :key #'(lambda (x) (car (full-spec x))))) + (pprint-logical-block (xp stuff :prefix "#<" :suffix ">") + (format xp (formatter "pprint dispatch table containing ~A entries: ") + (length stuff)) + (loop (pprint-exit-if-list-exhausted) + (let ((entry (pprint-pop))) + (format xp (formatter "~{~_P=~4D ~W~} F=~W ") + (full-spec entry) (fn entry))))))) + +(setf (get 'pprint-dispatch-table 'structure-printer) #'pprint-dispatch-print) + +(set-pprint-dispatch+ 'pprint-dispatch-table #'pprint-dispatch-print '(0) *ipd*) + +(setf *print-pprint-dispatch* (copy-pprint-dispatch nil)) Added: branches/save-image/src/org/armedbear/lisp/pprint.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/pprint.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1382 @@ +;;; pprint.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: pprint.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from the November, 26 1991 version of Richard C. Waters' XP pretty +;;; printer. + +;------------------------------------------------------------------------ + +;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts. + +;Permission to use, copy, modify, and distribute this software and its +;documentation for any purpose and without fee is hereby granted, +;provided that this copyright and permission notice appear in all +;copies and supporting documentation, and that the name of M.I.T. not +;be used in advertising or publicity pertaining to distribution of the +;software without specific, written prior permission. M.I.T. makes no +;representations about the suitability of this software for any +;purpose. It is provided "as is" without express or implied warranty. + +; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +; SOFTWARE. + +;------------------------------------------------------------------------ + +(in-package #:xp) + +;must do the following in common lisps not supporting *print-shared* + +(defvar *print-shared* nil) +(export '(*print-shared*)) + +(defvar *default-right-margin* 70. + "controls default line length; must be a non-negative integer") + +(defvar *current-level* 0 + "current depth in logical blocks.") +(defvar *abbreviation-happened* nil + "t if current thing being printed has been abbreviated.") +(defvar *result* nil "used to pass back a value") + +;default (bad) definitions for the non-portable functions + +#-(or :symbolics :lucid :franz-inc :cmu)(eval-when (eval load compile) +(defun structure-type-p (x) (and (symbolp x) (get x 'structure-printer))) +(defun output-width (&optional (s *standard-output*)) (declare (ignore s)) nil)) + +(defvar *locating-circularities* nil + "Integer if making a first pass over things to identify circularities. + Integer used as counter for #n= syntax.") + +; ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ---- + +(eval-when (eval load compile) ;not used at run time. + (defvar block-stack-entry-size 1) + (defvar prefix-stack-entry-size 5) + (defvar queue-entry-size 7) + (defvar buffer-entry-size 1) + (defvar prefix-entry-size 1) + (defvar suffix-entry-size 1)) + +(eval-when (eval load compile) ;used at run time + (defvar block-stack-min-size #.(* 35. block-stack-entry-size)) + (defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size)) + (defvar queue-min-size #.(* 75. queue-entry-size)) + (defvar buffer-min-size 256.) + (defvar prefix-min-size 256.) + (defvar suffix-min-size 256.) + ) + +(defstruct (xp-structure (:conc-name nil) #+nil (:print-function describe-xp)) + (base-stream nil) ;;The stream io eventually goes to. + line-length ;;The line length to use for formatting. + line-limit ;;If non-NIL the max number of lines to print. + line-no ;;number of next line to be printed. + depth-in-blocks + ;;Number of logical blocks at QRIGHT that are started but not ended. + (block-stack (make-array #.block-stack-min-size)) block-stack-ptr + ;;This stack is pushed and popped in accordance with the way blocks are + ;;nested at the moment they are entered into the queue. It contains the + ;;following block specific value. + ;;SECTION-START total position where the section (see AIM-1102) + ;;that is rightmost in the queue started. + (buffer (make-array #.buffer-min-size :element-type 'character)) + charpos buffer-ptr buffer-offset + ;;This is a vector of characters (eg a string) that builds up the + ;;line images that will be printed out. BUFFER-PTR is the + ;;buffer position where the next character should be inserted in + ;;the string. CHARPOS is the output character position of the + ;;first character in the buffer (non-zero only if a partial line + ;;has been output). BUFFER-OFFSET is used in computing total lengths. + ;;It is changed to reflect all shifting and insertion of prefixes so that + ;;total length computes things as they would be if they were + ;;all on one line. Positions are kept three different ways + ;; Buffer position (eg BUFFER-PTR) + ;; Line position (eg (+ BUFFER-PTR CHARPOS)). Indentations are stored in this form. + ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET)) + ;; Positions are stored in this form. + (queue (make-array #.queue-min-size)) + qleft + qright + ;;This holds a queue of action descriptors. QLEFT and QRIGHT + ;;point to the next entry to dequeue and the last entry enqueued + ;;respectively. The queue is empty when + ;;(> QLEFT QRIGHT). The queue entries have several parts: + ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK + ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH + ;; or :BLOCK/:CURRENT + ;;QPOS total position corresponding to this entry + ;;QDEPTH depth in blocks of this entry. + ;;QEND offset to entry marking end of section this entry starts. (NIL until known.) + ;; Only :start-block and non-literal :newline entries can start sections. + ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known). + ;;QARG for :IND indentation delta + ;; for :START-BLOCK suffix in the block if any. + ;; or if per-line-prefix then cons of suffix and + ;; per-line-prefix. + ;; for :END-BLOCK suffix for the block if any. + (prefix (make-array #.buffer-min-size :element-type 'character)) + ;;this stores the prefix that should be used at the start of the line + (prefix-stack (make-array #.prefix-stack-min-size)) + prefix-stack-ptr + ;;This stack is pushed and popped in accordance with the way blocks + ;;are nested at the moment things are taken off the queue and printed. + ;;It contains the following block specific values. + ;;PREFIX-PTR current length of PREFIX. + ;;SUFFIX-PTR current length of pending suffix + ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix. + ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block. + ;;SECTION-START-LINE line-no value at last non-literal break at this level. + (suffix (make-array #.buffer-min-size :element-type 'character)) + ;;this stores the suffixes that have to be printed to close of the current + ;;open blocks. For convenient in popping, the whole suffix + ;;is stored in reverse order. +) + + +(defun ext:charpos (stream) + (cond ((xp-structure-p stream) + (charpos stream)) + ((streamp stream) + (sys::stream-charpos stream)))) + +(defun (setf ext:charpos) (new-value stream) + (cond ((xp-structure-p stream) + (setf (charpos stream) new-value)) + ((streamp stream) + (sys::stream-%set-charpos stream new-value)))) + + +(defmacro LP<-BP (xp &optional (ptr nil)) + (if (null ptr) (setq ptr `(buffer-ptr ,xp))) + `(+ ,ptr (charpos ,xp))) +(defmacro TP<-BP (xp) + `(+ (buffer-ptr ,xp) (buffer-offset ,xp))) +(defmacro BP<-LP (xp ptr) + `(- ,ptr (charpos ,xp))) +(defmacro BP<-TP (xp ptr) + `(- ,ptr (buffer-offset ,xp))) +;This does not tell you the line position you were at when the TP +;was set, unless there have been no newlines or indentation output +;between ptr and the current output point. +(defmacro LP<-TP (xp ptr) + `(LP<-BP ,xp (BP<-TP ,xp ,ptr))) + +;We don't use adjustable vectors or any of that, because we seldom have +;to actually extend and non-adjustable vectors are a lot faster in +;many Common Lisps. + +(defmacro check-size (xp vect ptr) + (let* ((min-size + (symbol-value + (intern (concatenate 'string (string vect) "-MIN-SIZE") + (find-package "XP")))) + (entry-size + (symbol-value + (intern (concatenate 'string (string vect) "-ENTRY-SIZE") + (find-package "XP"))))) + `(when (and (> ,ptr ,(- min-size entry-size)) ;seldom happens + (> ,ptr (- (length (,vect ,xp)) ,entry-size))) + (let* ((old (,vect ,xp)) + (new (make-array (+ ,ptr ,(if (= entry-size 1) 50 + (* 10 entry-size))) + :element-type (array-element-type old)))) + (replace new old) + (setf (,vect ,xp) new))))) + +(defmacro section-start (xp) `(aref (block-stack ,xp) (block-stack-ptr ,xp))) + +(defun push-block-stack (xp) + (incf (block-stack-ptr xp) #.block-stack-entry-size) + (check-size xp block-stack (block-stack-ptr xp))) + +(defun pop-block-stack (xp) + (decf (block-stack-ptr xp) #.block-stack-entry-size)) + +(defmacro prefix-ptr (xp) + `(aref (prefix-stack ,xp) (prefix-stack-ptr ,xp))) +(defmacro suffix-ptr (xp) + `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 1))) +(defmacro non-blank-prefix-ptr (xp) + `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 2))) +(defmacro initial-prefix-ptr (xp) + `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 3))) +(defmacro section-start-line (xp) + `(aref (prefix-stack ,xp) (+ (prefix-stack-ptr ,xp) 4))) + +(defun push-prefix-stack (xp) + (let ((old-prefix 0) + (old-suffix 0) + (old-non-blank 0)) + (when (not (minusp (prefix-stack-ptr xp))) + (setq old-prefix (prefix-ptr xp) + old-suffix (suffix-ptr xp) + old-non-blank (non-blank-prefix-ptr xp))) + (incf (prefix-stack-ptr xp) #.prefix-stack-entry-size) + (check-size xp prefix-stack (prefix-stack-ptr xp)) + (setf (prefix-ptr xp) old-prefix) + (setf (suffix-ptr xp) old-suffix) + (setf (non-blank-prefix-ptr xp) old-non-blank))) + +(defun pop-prefix-stack (xp) + (decf (prefix-stack-ptr xp) #.prefix-stack-entry-size)) + +(defmacro Qtype (xp index) `(aref (queue ,xp) ,index)) +(defmacro Qkind (xp index) `(aref (queue ,xp) (1+ ,index))) +(defmacro Qpos (xp index) `(aref (queue ,xp) (+ ,index 2))) +(defmacro Qdepth (xp index) `(aref (queue ,xp) (+ ,index 3))) +(defmacro Qend (xp index) `(aref (queue ,xp) (+ ,index 4))) +(defmacro Qoffset (xp index) `(aref (queue ,xp) (+ ,index 5))) +(defmacro Qarg (xp index) `(aref (queue ,xp) (+ ,index 6))) + +;we shift the queue over rather than using a circular queue because +;that works out to be a lot faster in practice. Note, short printout +;does not ever cause a shift, and even in long printout, the queue is +;shifted left for free every time it happens to empty out. + +(defun enqueue (xp type kind &optional arg) + (incf (Qright xp) #.queue-entry-size) + (when (> (Qright xp) #.(- queue-min-size queue-entry-size)) + (replace (queue xp) (queue xp) :start2 (Qleft xp) :end2 (Qright xp)) + (setf (Qright xp) (- (Qright xp) (Qleft xp))) + (setf (Qleft xp) 0)) + (check-size xp queue (Qright xp)) + (setf (Qtype xp (Qright xp)) type) + (setf (Qkind xp (Qright xp)) kind) + (setf (Qpos xp (Qright xp)) (TP<-BP xp)) + (setf (Qdepth xp (Qright xp)) (depth-in-blocks xp)) + (setf (Qend xp (Qright xp)) nil) + (setf (Qoffset xp (Qright xp)) nil) + (setf (Qarg xp (Qright xp)) arg)) + +(defmacro Qnext (index) `(+ ,index #.queue-entry-size)) + +;This is called to initialize things when you start pretty printing. + +(defun initialize-xp (xp stream) + (setf (base-stream xp) stream) + (setf (line-length xp) (max 0 (cond (*print-right-margin*) + ((output-width stream)) + (t *default-right-margin*)))) + (setf (line-limit xp) *print-lines*) + (setf (line-no xp) 1) + (setf (depth-in-blocks xp) 0) + (setf (block-stack-ptr xp) 0) + (setf (charpos xp) (cond ((ext:charpos stream)) (t 0))) + (setf (section-start xp) 0) + (setf (buffer-ptr xp) 0) + (setf (buffer-offset xp) (charpos xp)) + (setf (Qleft xp) 0) + (setf (Qright xp) #.(- queue-entry-size)) + (setf (prefix-stack-ptr xp) #.(- prefix-stack-entry-size)) + xp) + +;This handles the basic outputting of characters. note + suffix means that +;the stream is known to be an XP stream, all inputs are mandatory, and no +;error checking has to be done. Suffix ++ additionally means that the +;output is guaranteed not to contain a newline char. + +(defun write-char+ (char xp) + (if (eql char #\newline) (pprint-newline+ :unconditional xp) + (write-char++ char xp))) + +(defun write-string+ (string xp start end) + (let ((sub-end nil) next-newline) + (loop (setq next-newline + (position #\newline string :test #'char= :start start :end end)) + (setq sub-end (if next-newline next-newline end)) + (write-string++ string xp start sub-end) + (when (null next-newline) (return nil)) + (pprint-newline+ :unconditional xp) + (setq start (1+ sub-end))))) + +;note this checks (> BUFFER-PTR LINE-LENGTH) instead of (> (LP<-BP) LINE-LENGTH) +;this is important so that when things are longer than a line they +;end up getting printed in chunks of size LINE-LENGTH. + +(defun write-char++ (char xp) + (when (> (buffer-ptr xp) (line-length xp)) + (force-some-output xp)) + (let ((new-buffer-end (1+ (buffer-ptr xp)))) + (check-size xp buffer new-buffer-end) + (setf (char (buffer xp) (buffer-ptr xp)) char) + (setf (buffer-ptr xp) new-buffer-end))) + +(defun force-some-output (xp) + (attempt-to-output xp nil nil) + (when (> (buffer-ptr xp) (line-length xp)) ;only if printing off end of line + (attempt-to-output xp T T))) + +(defun write-string++ (string xp start end) + (when (> (buffer-ptr xp) (line-length xp)) + (force-some-output xp)) + (write-string+++ string xp start end)) + +;never forces output; therefore safe to call from within output-line. + +(defun write-string+++ (string xp start end) + (let ((new-buffer-end (+ (buffer-ptr xp) (- end start)))) + (check-size xp buffer new-buffer-end) + (do ((buffer (buffer xp)) + (i (buffer-ptr xp) (1+ i)) + (j start (1+ j))) + ((= j end)) + (let ((char (char string j))) + (setf (char buffer i) char))) + (setf (buffer-ptr xp) new-buffer-end))) + +(defun pprint-tab+ (kind colnum colinc xp) + (let ((indented? nil) (relative? nil)) + (case kind + (:section (setq indented? t)) + (:line-relative (setq relative? t)) + (:section-relative (setq indented? t relative? t))) + (let* ((current + (if (not indented?) (LP<-BP xp) + (- (TP<-BP xp) (section-start xp)))) + (new + (if (zerop colinc) + (if relative? (+ current colnum) (max colnum current)) + (cond (relative? + (* colinc (floor (+ current colnum colinc -1) colinc))) + ((> colnum current) colnum) + (T (+ colnum + (* colinc + (floor (+ current (- colnum) colinc) colinc))))))) + (length (- new current))) + (when (plusp length) + (let ((end (+ (buffer-ptr xp) length))) + (check-size xp buffer end) + (fill (buffer xp) #\space :start (buffer-ptr xp) :end end) + (setf (buffer-ptr xp) end)))))) + +;note following is smallest number >= x that is a multiple of colinc +; (* colinc (floor (+ x (1- colinc)) colinc)) + +(defun pprint-newline+ (kind xp) + (enqueue xp :newline kind) + (do ((ptr (Qleft xp) (Qnext ptr))) ;find sections we are ending + ((not (< ptr (Qright xp)))) ;all but last + (when (and (null (Qend xp ptr)) + (not (> (depth-in-blocks xp) (Qdepth xp ptr))) + (member (Qtype xp ptr) '(:newline :start-block))) + (setf (Qend xp ptr) (- (Qright xp) ptr)))) + (setf (section-start xp) (TP<-BP xp)) + (when (member kind '(:fresh :unconditional :mandatory)) + (attempt-to-output xp T nil))) + +(defun start-block (xp prefix on-each-line? suffix) + (unless (stringp prefix) + (error 'type-error + :datum prefix + :expected-type 'string)) + (unless (stringp suffix) + (error 'type-error + :datum suffix + :expected-type 'string)) + (when prefix + (write-string++ prefix xp 0 (length prefix))) + (push-block-stack xp) + (enqueue xp :start-block nil + (if on-each-line? (cons suffix prefix) suffix)) + (incf (depth-in-blocks xp)) ;must be after enqueue + (setf (section-start xp) (TP<-BP xp))) + +(defun end-block (xp suffix) + (unless (eq *abbreviation-happened* '*print-lines*) + (when suffix + (write-string+ suffix xp 0 (length suffix))) + (decf (depth-in-blocks xp)) + (enqueue xp :end-block nil suffix) + (do ((ptr (Qleft xp) (Qnext ptr))) ;looking for start of block we are ending + ((not (< ptr (Qright xp)))) ;all but last + (when (and (= (depth-in-blocks xp) (Qdepth xp ptr)) + (eq (Qtype xp ptr) :start-block) + (null (Qoffset xp ptr))) + (setf (Qoffset xp ptr) (- (Qright xp) ptr)) + (return nil))) ;can only be 1 + (pop-block-stack xp))) + +(defun pprint-indent+ (kind n xp) + (enqueue xp :ind kind n)) + +; The next function scans the queue looking for things it can do. +;it keeps outputting things until the queue is empty, or it finds +;a place where it cannot make a decision yet. + +(defmacro maybe-too-large (xp Qentry) + `(let ((limit (line-length ,xp))) + (when (eql (line-limit ,xp) (line-no ,xp)) ;prevents suffix overflow + (decf limit 2) ;3 for " .." minus 1 for space (heuristic) + (when (not (minusp (prefix-stack-ptr ,xp))) + (decf limit (suffix-ptr ,xp)))) + (cond ((Qend ,xp ,Qentry) + (> (LP<-TP ,xp (Qpos ,xp (+ ,Qentry (Qend ,xp ,Qentry)))) limit)) + ((or force-newlines? (> (LP<-BP ,xp) limit)) T) + (T (return nil))))) ;wait until later to decide. + +(defmacro misering? (xp) + `(and *print-miser-width* + (<= (- (line-length ,xp) (initial-prefix-ptr ,xp)) *print-miser-width*))) + +;If flush-out? is T and force-newlines? is NIL then the buffer, +;prefix-stack, and queue will be in an inconsistent state after the call. +;You better not call it this way except as the last act of outputting. + +(defun attempt-to-output (xp force-newlines? flush-out?) + (do () ((> (Qleft xp) (Qright xp)) + (setf (Qleft xp) 0) + (setf (Qright xp) #.(- queue-entry-size))) ;saves shifting + (case (Qtype xp (Qleft xp)) + (:ind + (unless (misering? xp) + (set-indentation-prefix xp + (case (Qkind xp (Qleft xp)) + (:block (+ (initial-prefix-ptr xp) (Qarg xp (Qleft xp)))) + (T ; :current + (+ (LP<-TP xp (Qpos xp (Qleft xp))) + (Qarg xp (Qleft xp))))))) + (setf (Qleft xp) (Qnext (Qleft xp)))) + (:start-block + (cond ((maybe-too-large xp (Qleft xp)) + (push-prefix-stack xp) + (setf (initial-prefix-ptr xp) (prefix-ptr xp)) + (set-indentation-prefix xp (LP<-TP xp (Qpos xp (Qleft xp)))) + (let ((arg (Qarg xp (Qleft xp)))) + (when (consp arg) (set-prefix xp (cdr arg))) + (setf (initial-prefix-ptr xp) (prefix-ptr xp)) + (cond ((not (listp arg)) (set-suffix xp arg)) + ((car arg) (set-suffix xp (car arg))))) + (setf (section-start-line xp) (line-no xp))) + (T (incf (Qleft xp) (Qoffset xp (Qleft xp))))) + (setf (Qleft xp) (Qnext (Qleft xp)))) + (:end-block (pop-prefix-stack xp) (setf (Qleft xp) (Qnext (Qleft xp)))) + (T ; :newline + (when (case (Qkind xp (Qleft xp)) + (:fresh (not (zerop (LP<-BP xp)))) + (:miser (misering? xp)) + (:fill (or (misering? xp) + (> (line-no xp) (section-start-line xp)) + (maybe-too-large xp (Qleft xp)))) + (T T)) ;(:linear :unconditional :mandatory) + (output-line xp (Qleft xp)) + (setup-for-next-line xp (Qleft xp))) + (setf (Qleft xp) (Qnext (Qleft xp)))))) + (when flush-out? (flush xp))) + +;this can only be called last! + +(defun flush (xp) + (unless *locating-circularities* + (write-string (buffer xp) (base-stream xp) :end (buffer-ptr xp))) + (incf (buffer-offset xp) (buffer-ptr xp)) + (incf (charpos xp) (buffer-ptr xp)) + (setf (buffer-ptr xp) 0)) + +;This prints out a line of stuff. + +(defun output-line (xp Qentry) + (let* ((out-point (BP<-TP xp (Qpos xp Qentry))) + (last-non-blank (position #\space (buffer xp) :test-not #'char= + :from-end T :end out-point)) + (end (cond ((member (Qkind xp Qentry) '(:fresh :unconditional)) out-point) + (last-non-blank (1+ last-non-blank)) + (T 0))) + (line-limit-exit (and (line-limit xp) + (not *print-readably*) + (not (> (line-limit xp) (line-no xp)))))) + (when line-limit-exit + (setf (buffer-ptr xp) end) ;truncate pending output. + (write-string+++ " .." xp 0 3) + (reverse-string-in-place (suffix xp) 0 (suffix-ptr xp)) + (write-string+++ (suffix xp) xp 0 (suffix-ptr xp)) + (setf (Qleft xp) (Qnext (Qright xp))) + (setf *abbreviation-happened* '*print-lines*) + (throw 'line-limit-abbreviation-exit T)) + (incf (line-no xp)) + (unless *locating-circularities* + (let ((stream (base-stream xp))) + (sys::%write-string (buffer xp) stream 0 end) + (sys::%terpri stream))))) + +(defun setup-for-next-line (xp Qentry) + (let* ((out-point (BP<-TP xp (Qpos xp Qentry))) + (prefix-end + (cond ((member (Qkind xp Qentry) '(:unconditional :fresh)) + (non-blank-prefix-ptr xp)) + (T (prefix-ptr xp)))) + (change (- prefix-end out-point))) + (setf (charpos xp) 0) + (when (plusp change) ;almost never happens + (check-size xp buffer (+ (buffer-ptr xp) change))) + (replace (buffer xp) (buffer xp) :start1 prefix-end + :start2 out-point :end2 (buffer-ptr xp)) + (replace (buffer xp) (prefix xp) :end2 prefix-end) + (incf (buffer-ptr xp) change) + (decf (buffer-offset xp) change) + (when (not (member (Qkind xp Qentry) '(:unconditional :fresh))) + (setf (section-start-line xp) (line-no xp))))) + +(defun set-indentation-prefix (xp new-position) + (let ((new-ind (max (non-blank-prefix-ptr xp) new-position))) + (setf (prefix-ptr xp) (initial-prefix-ptr xp)) + (check-size xp prefix new-ind) + (when (> new-ind (prefix-ptr xp)) + (fill (prefix xp) #\space :start (prefix-ptr xp) :end new-ind)) + (setf (prefix-ptr xp) new-ind))) + +(defun set-prefix (xp prefix-string) + (replace (prefix xp) prefix-string + :start1 (- (prefix-ptr xp) (length prefix-string))) + (setf (non-blank-prefix-ptr xp) (prefix-ptr xp))) + +(defun set-suffix (xp suffix-string) + (let* ((end (length suffix-string)) + (new-end (+ (suffix-ptr xp) end))) + (check-size xp suffix new-end) + (do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end)) + (setf (char (suffix xp) i) (char suffix-string j))) + (setf (suffix-ptr xp) new-end))) + +(defun reverse-string-in-place (string start end) + (do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string) + (let ((c (char string i))) + (setf (char string i) (char string j)) + (setf (char string j) c)))) + +; ---- BASIC INTERFACE FUNCTIONS ---- + +;The internal functions in this file, and the (formatter "...") expansions +;use the '+' forms of these functions directly (which is faster) because, +;they do not need error checking of fancy stream coercion. The '++' forms +;additionally assume the thing being output does not contain a newline. + +(defun write (object &key + ((:stream stream) *standard-output*) + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) + *print-right-margin*) + ((:miser-width *print-miser-width*) + *print-miser-width*) + ((:lines *print-lines*) *print-lines*) + ((:pprint-dispatch *print-pprint-dispatch*) + *print-pprint-dispatch*)) + (sys:output-object object (sys:out-synonym-of stream)) + object) + +(defun maybe-initiate-xp-printing (fn stream &rest args) + (if (xp-structure-p stream) + (apply fn stream args) + (let ((*abbreviation-happened* nil) + (sys::*circularity-hash-table* + (if (and *print-circle* (null sys::*circularity-hash-table*)) + (make-hash-table :test 'eq) + sys::*circularity-hash-table*)) + (*result* nil)) + (xp-print fn (sys:out-synonym-of stream) args) + *result*))) + +(defun xp-print (fn stream args) + (setq *result* (do-xp-printing fn stream args)) + (when *locating-circularities* + (setq *locating-circularities* nil) + (setq *abbreviation-happened* nil) +;; (setq *parents* nil) + (setq *result* (do-xp-printing fn stream args)))) + +(defun do-xp-printing (fn stream args) + (let ((xp (initialize-xp (make-xp-structure) stream)) + (*current-level* 0) + (result nil)) + (catch 'line-limit-abbreviation-exit + (start-block xp "" nil "") + (setq result (apply fn xp args)) + (end-block xp nil)) + (when (and *locating-circularities* + (zerop *locating-circularities*) ;No circularities. + (= (line-no xp) 1) ;Didn't suppress line. + (zerop (buffer-offset xp))) ;Didn't suppress partial line. + (setq *locating-circularities* nil)) ;print what you have got. + (when (catch 'line-limit-abbreviation-exit + (attempt-to-output xp nil t) nil) + (attempt-to-output xp t t)) + result)) + +(defun write+ (object xp) +;; (let ((*parents* *parents*)) +;; (unless (and *circularity-hash-table* +;; (eq (circularity-process xp object nil) :subsequent)) +;; (when (and *circularity-hash-table* (consp object)) +;; ;;avoid possible double check in handle-logical-block. +;; (setq object (cons (car object) (cdr object)))) + (let ((printer (if *print-pretty* (get-printer object *print-pprint-dispatch*) nil)) + type) + (cond (printer (funcall printer xp object)) + ((maybe-print-fast object xp)) + ((and *print-pretty* + (symbolp (setq type (type-of object))) + (setq printer (get type 'structure-printer)) + (not (eq printer :none))) + (funcall printer xp object)) + ((and *print-pretty* *print-array* (arrayp object) + (not (stringp object)) (not (bit-vector-p object)) + (not (structure-type-p (type-of object)))) + (pretty-array xp object)) + (t + (let ((stuff (with-output-to-string (s) (non-pretty-print object s)))) + (write-string+ stuff xp 0 (length stuff))))))) + +(defun non-pretty-print (object s) +;; (write object +;; :level (if *print-level* +;; (- *print-level* *current-level*)) +;; :pretty nil +;; :stream s)) + (sys::output-ugly-object object s)) + +;This prints a few very common, simple atoms very fast. +;Pragmatically, this turns out to be an enormous savings over going to the +;standard printer all the time. There would be diminishing returns from making +;this work with more things, but might be worth it. +(defun maybe-print-fast (object xp) + (cond ((stringp object) + (let ((s (sys::%write-to-string object))) + (write-string++ s xp 0 (length s)) + t)) + ((ext:fixnump object) + (print-fixnum xp object) + t) + ((and (symbolp object) + (or (symbol-package object) + (null *print-circle*))) + (let ((s (sys::%write-to-string object))) + (write-string++ s xp 0 (length s)) + t) + ))) + +(defun print-fixnum (xp fixnum) + (let ((s (sys::%write-to-string fixnum))) + (write-string++ s xp 0 (length s)))) + +(defun print (object &optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (terpri stream) + (let ((*print-escape* t)) + (sys:output-object object stream)) + (write-char #\space stream) + object) + +(defun prin1 (object &optional (stream *standard-output*)) + (let ((*print-escape* t)) + (sys:output-object object (sys:out-synonym-of stream))) + object) + +(defun princ (object &optional (stream *standard-output*)) + (let ((*print-escape* nil) + (*print-readably* nil)) + (sys:output-object object (sys:out-synonym-of stream))) + object) + +(defun pprint (object &optional (stream *standard-output*)) + (setq stream (sys:out-synonym-of stream)) + (terpri stream) + (let ((*print-escape* T) (*print-pretty* T)) + (sys:output-object object stream)) + (values)) + +(defun write-to-string (object &key + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) *print-right-margin*) + ((:miser-width *print-miser-width*) *print-miser-width*) + ((:lines *print-lines*) *print-lines*) + ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)) + (let ((stream (make-string-output-stream))) + (sys:output-object object stream) + (get-output-stream-string stream))) + +(defun prin1-to-string (object) + (with-output-to-string (stream) + (let ((*print-escape* t)) + (sys:output-object object stream)))) + +(defun princ-to-string (object) + (with-output-to-string (stream) + (let ((*print-escape* nil) + (*print-readably* nil)) + (sys:output-object object stream)))) + +(defun write-char (char &optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (if (xp-structure-p stream) + (write-char+ char stream) + (sys:%stream-write-char char stream)) + char) + +(defun write-string (string &optional (stream *standard-output*) + &key (start 0) (end (length string))) + (setf stream (sys:out-synonym-of stream)) + (if (xp-structure-p stream) + (write-string+ string stream start end) + (progn + (unless start + (setf start 0)) + (if end + (setf end (min end (length string))) + (setf end (length string))) + (sys::%write-string string stream start end))) + string) + +(defun write-line (string &optional (stream *standard-output*) + &key (start 0) (end (length string))) + (setf stream (sys:out-synonym-of stream)) + (cond ((xp-structure-p stream) + (write-string+ string stream start end) + (pprint-newline+ :unconditional stream)) + (t (sys::%write-string string stream start end) + (sys::%terpri stream))) + string) + +(defun terpri (&optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (if (xp-structure-p stream) + (pprint-newline+ :unconditional stream) + (sys:%stream-terpri stream)) + nil) + +;This has to violate the XP data abstraction and fool with internal +;stuff, in order to find out the right info to return as the result. + +(defun fresh-line (&optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (cond ((xp-structure-p stream) + (attempt-to-output stream t t) ;ok because we want newline + (when (not (zerop (LP<-BP stream))) + (pprint-newline+ :fresh stream) + t)) + (t + (sys::%fresh-line stream)))) + +;Each of these causes the stream to be pessimistic and insert +;newlines wherever it might have to, when forcing the partial output +;out. This is so that things will be in a consistent state if +;output continues to the stream later. + +(defun finish-output (&optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (when (xp-structure-p stream) + (attempt-to-output stream T T) + (setf stream (base-stream stream))) + (sys::%finish-output stream) + nil) + +(defun force-output (&optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (when (xp-structure-p stream) + (attempt-to-output stream T T) + (setf stream (base-stream stream))) + (sys::%force-output stream) + nil) + +(defun clear-output (&optional (stream *standard-output*)) + (setf stream (sys:out-synonym-of stream)) + (when (xp-structure-p stream) + (let ((*locating-circularities* 0)) ;hack to prevent visible output + (attempt-to-output stream T T) + (setf stream (base-stream stream)))) + (sys::%clear-output stream) + nil) + +;The internal functions in this file, and the (formatter "...") expansions +;use the '+' forms of these functions directly (which is faster) because, +;they do not need error checking or fancy stream coercion. The '++' forms +;additionally assume the thing being output does not contain a newline. + +(defmacro pprint-logical-block ((stream-symbol object + &key + (prefix "" prefix-p) + (per-line-prefix "" per-line-prefix-p) + (suffix "")) + &body body) + (cond ((eq stream-symbol nil) + (setf stream-symbol '*standard-output*)) + ((eq stream-symbol t) + (setf stream-symbol '*terminal-io*))) + (unless (symbolp stream-symbol) + (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol." + stream-symbol) + (setf stream-symbol '*standard-output*)) + (when (and prefix-p per-line-prefix-p) + (error "Cannot specify values for both PREFIX and PER-LINE-PREFIX.")) + `(maybe-initiate-xp-printing + #'(lambda (,stream-symbol) + (let ((+l ,object) + (+p ,(cond (prefix-p prefix) + (per-line-prefix-p per-line-prefix) + (t ""))) + (+s ,suffix)) + (pprint-logical-block+ + (,stream-symbol +l +p +s ,per-line-prefix-p t nil) + ,@ body nil))) + (sys:out-synonym-of ,stream-symbol))) + +;Assumes var and args must be variables. Other arguments must be literals or variables. + +(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?) + &body body) +;; (when (and circle-check? atsign?) +;; (setf circle-check? 'not-first-p)) + (declare (ignore atsign?)) + `(let ((*current-level* (1+ *current-level*)) + (sys:*current-print-length* -1) +;; ,@(if (and circle-check? atsign?) +;; `((not-first-p (plusp sys:*current-print-length*)))) + ) + (unless (check-block-abbreviation ,var ,args ,circle-check?) + (block logical-block + (start-block ,var ,prefix ,per-line? ,suffix) + (unwind-protect + (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var)) + (pprint-exit-if-list-exhausted () + `(if (null ,',args) (return-from logical-block nil)))) + ,@ body) + (end-block ,var ,suffix)))))) + +;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is +;; true, a line break is inserted in the output when the appropriate condition +;; below is satisfied; otherwise, PPRINT-NEWLINE has no effect." +(defun pprint-newline (kind &optional (stream *standard-output*)) + (sys:require-type kind '(MEMBER :LINEAR :MISER :FILL :MANDATORY)) + (setq stream (sys:out-synonym-of stream)) + (when (not (member kind '(:linear :miser :fill :mandatory))) + (error 'simple-type-error + :format-control "Invalid KIND argument ~A to PPRINT-NEWLINE." + :format-arguments (list kind))) + (when (and (xp-structure-p stream) *print-pretty*) + (pprint-newline+ kind stream)) + nil) + +;; "If stream is a pretty printing stream and the value of *PRINT-PRETTY* is +;; true, PPRINT-INDENT sets the indentation in the innermost dynamically +;; enclosing logical block; otherwise, PPRINT-INDENT has no effect." +(defun pprint-indent (relative-to n &optional (stream *standard-output*)) + (setq stream (sys:out-synonym-of stream)) + (when (not (member relative-to '(:block :current))) + (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to)) + (when (and (xp-structure-p stream) *print-pretty*) + (pprint-indent+ relative-to (truncate n) stream)) + nil) + +(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*)) + (setq stream (sys:out-synonym-of stream)) + (when (not (member kind '(:line :section :line-relative :section-relative))) + (error "Invalid KIND argument ~A to PPRINT-TAB" kind)) + (when (and (xp-structure-p stream) *print-pretty*) + (pprint-tab+ kind colnum colinc stream)) + nil) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro pprint-pop+ (args xp) + `(if (pprint-pop-check+ ,args ,xp) + (return-from logical-block nil) + (pop ,args))) + + (defun pprint-pop-check+ (args xp) + (incf sys:*current-print-length*) + (cond ((not (listp args)) ;must be first so supersedes length abbrev + (write-string++ ". " xp 0 2) + (sys:output-object args xp) + t) + ((and *print-length* ;must supersede circle check + (not *print-readably*) + (not (< sys:*current-print-length* *print-length*))) + (write-string++ "..." xp 0 3) +;; (setq *abbreviation-happened* T) + t) +;; ((and *circularity-hash-table* (not (zerop sys:*current-print-length*))) +;; (case (circularity-process xp args T) +;; (:first ;; note must inhibit rechecking of circularity for args. +;; (write+ (cons (car args) (cdr args)) xp) T) +;; (:subsequent t) +;; (t nil))) + + ((or (not *print-circle*) + (sys::uniquely-identified-by-print-p args)) + nil) + + ((and (plusp sys:*current-print-length*) + (sys::check-for-circularity args)) + (write-string++ ". " xp 0 2) + (sys:output-object args xp) + t) + + )) + + (defun check-block-abbreviation (xp args circle-check?) + (declare (ignore circle-check?)) + (cond ((not (listp args)) + (sys:output-object args xp) T) + ((and *print-level* + (not *print-readably*) + (> *current-level* *print-level*)) + (write-char++ #\# xp) + (setf *abbreviation-happened* t) + t) +;; ((and *circularity-hash-table* +;; circle-check? +;; (eq (circularity-process xp args nil) :subsequent)) T) + + (t + nil))) +) ;; EVAL-WHEN + +; ---- PRETTY PRINTING FORMATS ---- + +(defun pretty-array (xp array) + (cond ((vectorp array) + (pretty-vector xp array)) + ((zerop (array-rank array)) + (when *print-readably* + (unless (eq (array-element-type array) t) + (error 'print-not-readable :object array))) + (write-string++ "#0A" xp 0 3) + (sys:output-object (aref array) xp)) + (t + (pretty-non-vector xp array)))) + +(defun pretty-vector (xp v) + (pprint-logical-block (xp nil :prefix "#(" :suffix ")") + (let ((end (length v)) + (i 0)) + (when (plusp end) + (loop + (pprint-pop) + (sys:output-object (aref v i) xp) + (when (= (incf i) end) + (return nil)) + (write-char++ #\space xp) + (pprint-newline+ :fill xp)))))) + +(declaim (special *prefix*)) + +(defun pretty-non-vector (xp array) + (when (and *print-readably* + (not (array-readably-printable-p array))) + (error 'print-not-readable :object array)) + (let* ((bottom (1- (array-rank array))) + (indices (make-list (1+ bottom) :initial-element 0)) + (dims (array-dimensions array)) + (*prefix* (cl:format nil "#~DA(" (1+ bottom)))) + (labels ((pretty-slice (slice) + (pprint-logical-block (xp nil :prefix *prefix* :suffix ")") + (let ((end (nth slice dims)) + (spot (nthcdr slice indices)) + (i 0) + (*prefix* "(")) + (when (plusp end) + (loop (pprint-pop) + (setf (car spot) i) + (if (= slice bottom) + (sys:output-object (apply #'aref array indices) xp) + (pretty-slice (1+ slice))) + (if (= (incf i) end) (return nil)) + (write-char++ #\space xp) + (pprint-newline+ (if (= slice bottom) :fill :linear) xp))))))) + (pretty-slice 0)))) + +(defun array-readably-printable-p (array) + (and (eq (array-element-type array) t) + (let ((zero (position 0 (array-dimensions array))) + (number (position 0 (array-dimensions array) + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number))))) + +;Must use pprint-logical-block (no +) in the following three, because they are +;exported functions. + +(defun pprint-linear (s list &optional (colon? T) atsign?) + (declare (ignore atsign?)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop + (sys:output-object (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-newline+ :linear s)))) + +(defun pprint-fill (stream object &optional (colon-p t) at-sign-p) + (declare (ignore at-sign-p)) + (pprint-logical-block (stream object :prefix (if colon-p "(" "") + :suffix (if colon-p ")" "")) + (pprint-exit-if-list-exhausted) + (loop + (sys:output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char++ #\space stream) + (pprint-newline+ :fill stream)))) + +(defun pprint-tabular (stream list &optional (colon-p T) at-sign-p (tabsize nil)) + (declare (ignore at-sign-p)) + (when (null tabsize) (setq tabsize 16)) + (pprint-logical-block (stream list :prefix (if colon-p "(" "") + :suffix (if colon-p ")" "")) + (pprint-exit-if-list-exhausted) + (loop + (sys:output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char++ #\space stream) + (pprint-tab+ :section-relative 0 tabsize stream) + (pprint-newline+ :fill stream)))) + +(defun fn-call (xp list) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)) + +;Although idiosyncratic, I have found this very useful to avoid large +;indentations when printing out code. + +(defun alternative-fn-call (xp list) + (if (> (length (symbol-name (car list))) 12) + (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))) + +(defun bind-list (xp list &rest args) + (declare (ignore args)) + (if (do ((i 50 (1- i)) + (ls list (cdr ls))) ((null ls) t) + (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i)) + (return nil))) + (pprint-fill xp list) + (funcall (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") xp list))) + +(defun block-like (xp list &rest args) + (declare (ignore args)) + (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list)) + +(defun defun-like (xp list &rest args) + (declare (ignore args)) + (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/xp:pprint-fill/~^~@{ ~_~W~^~}~:>") + xp list)) + +(defun print-fancy-fn-call (xp list template) + (let ((i 0) (in-first-section t)) + (pprint-logical-block+ (xp list "(" ")" nil t nil) + (sys:output-object (pprint-pop) xp) + (pprint-indent+ :current 1 xp) + (loop + (pprint-exit-if-list-exhausted) + (write-char++ #\space xp) + (when (eq i (car template)) + (pprint-indent+ :block (cadr template) xp) + (setq template (cddr template)) + (setq in-first-section nil)) + (pprint-newline (cond ((and (zerop i) in-first-section) :miser) + (in-first-section :fill) + (T :linear)) + xp) + (sys:output-object (pprint-pop) xp) + (incf i))))) + +;This is an attempt to specify a correct format for every form in the CL book +;that does not just get printed out like an ordinary function call +;(i.e., most special forms and many macros). This of course does not +;cover anything new you define. + +(defun let-print (xp obj) + (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>") + xp obj)) + +(defun cond-print (xp obj) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") xp obj)) + +(defun dmm-print (xp list) + (print-fancy-fn-call xp list '(3 1))) + +(defun defsetf-print (xp list) + (print-fancy-fn-call xp list '(3 1))) + +(defun do-print (xp obj) + (funcall + (formatter "~:<~W~^ ~:I~@_~/xp:bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") + xp obj)) + +(defun flet-print (xp obj) + (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/xp:block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>") + xp obj)) + +(defun function-print (xp list) + (if (and (consp (cdr list)) (null (cddr list))) + (funcall (formatter "#'~W") xp (cadr list)) + (fn-call xp list))) + +(defun mvb-print (xp list) + (print-fancy-fn-call xp list '(1 3 2 1))) + +;; Used by PROG-PRINT and TAGBODY-PRINT. +(defun maybelab (xp item &rest args) + (declare (ignore args) (special need-newline indentation)) + (when need-newline (pprint-newline+ :mandatory xp)) + (cond ((and item (symbolp item)) + (write+ item xp) + (setq need-newline nil)) + (t (pprint-tab+ :section indentation 0 xp) + (write+ item xp) + (setq need-newline T)))) + +(defun prog-print (xp list) + (let ((need-newline T) (indentation (1+ (length (symbol-name (car list)))))) + (declare (special need-newline indentation)) + (funcall (formatter "~:<~W~^ ~:/xp:pprint-fill/~^ ~@{~/xp:maybelab/~^ ~}~:>") + xp list))) + +(defun tagbody-print (xp list) + (let ((need-newline (and (consp (cdr list)) + (symbolp (cadr list)) (cadr list))) + (indentation (1+ (length (symbol-name (car list)))))) + (declare (special need-newline indentation)) + (funcall (formatter "~:<~W~^ ~@{~/xp:maybelab/~^ ~}~:>") xp list))) + +(defun setq-print (xp obj) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj)) + +(defun quote-print (xp list) + (if (and (consp (cdr list)) (null (cddr list))) + (funcall (formatter "'~W") xp (cadr list)) + (pprint-fill xp list))) + +(defun up-print (xp list) + (print-fancy-fn-call xp list '(0 3 1 1))) + +;here is some simple stuff for printing LOOP + +;The challange here is that we have to effectively parse the clauses of the +;loop in order to know how to print things. Also you want to do this in a +;purely incremental way so that all of the abbreviation things work, and +;you wont blow up on circular lists or the like. (More aesthic output could +;be produced by really parsing the clauses into nested lists before printing them.) + +;The following program assumes the following simplified grammar of the loop +;clauses that explains how to print them. Note that it does not bare much +;resemblence to the right parsing grammar, however, it produces half decent +;output. The way to make the output better is to make the grammar more +;detailed. +; +;loop == (LOOP {clause}*) ;one clause on each line. +;clause == block | linear | cond | finally +;block == block-head {expr}* ;as many exprs as possible on each line. +;linear == linear-head {expr}* ;one expr on each line. +;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. +;cond == cond-head [expr] +; clause +; {AND clause}* ;one AND on each line. +; [ELSE +; clause +; {AND clause}*] ;one AND on each line. +; [END] +;block-head == FOR | AS | WITH | AND +; | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN +; | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT +; | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING +;linear-head == DO | DOING | INITIALLY +;var-head == FOR | AS | WITH +;cond-head == IF | WHEN | UNLESS +;expr == + +;Note all the string comparisons below are required to support some +;existing implementations of LOOP. + +(defun token-type (token &aux string) + (cond ((not (symbolp token)) :expr) + ((string= (setq string (string token)) "FINALLY") :finally) + ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head) + ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head) + ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE" + "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER" + "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" + "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING" + "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" + "MINIMIZE" "MINIMIZING") + :test #'string=) + :block-head) + (T :expr))) + +(defun pretty-loop (xp loop) + (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop + (fn-call xp loop) + (pprint-logical-block (xp loop :prefix "(" :suffix ")") + (let (token type) + (labels ((next-token () + (pprint-exit-if-list-exhausted) + (setq token (pprint-pop)) + (setq type (token-type token))) + (print-clause (xp) + (case type + (:linear-head (print-exprs xp nil :mandatory)) + (:cond-head (print-cond xp)) + (:finally (print-exprs xp T :mandatory)) + (otherwise (print-exprs xp nil :fill)))) + (print-exprs (xp skip-first-non-expr newline-type) + (let ((first token)) + (next-token) ;so always happens no matter what + (pprint-logical-block (xp nil) + (write first :stream xp) + (when (and skip-first-non-expr (not (eq type :expr))) + (write-char #\space xp) + (write token :stream xp) + (next-token)) + (when (eq type :expr) + (write-char #\space xp) + (pprint-indent :current 0 xp) + (loop (write token :stream xp) + (next-token) + (when (not (eq type :expr)) (return nil)) + (write-char #\space xp) + (pprint-newline newline-type xp)))))) + (print-cond (xp) + (let ((first token)) + (next-token) ;so always happens no matter what + (pprint-logical-block (xp nil) + (write first :stream xp) + (when (eq type :expr) + (write-char #\space xp) + (write token :stream xp) + (next-token)) + (write-char #\space xp) + (pprint-indent :block 2 xp) + (pprint-newline :linear xp) + (print-clause xp) + (print-and-list xp) + (when (and (symbolp token) + (string= (string token) "ELSE")) + (print-else-or-end xp) + (write-char #\space xp) + (pprint-newline :linear xp) + (print-clause xp) + (print-and-list xp)) + (when (and (symbolp token) + (string= (string token) "END")) + (print-else-or-end xp))))) + (print-and-list (xp) + (loop (when (not (and (symbolp token) + (string= (string token) "AND"))) + (return nil)) + (write-char #\space xp) + (pprint-newline :mandatory xp) + (write token :stream xp) + (next-token) + (write-char #\space xp) + (print-clause xp))) + (print-else-or-end (xp) + (write-char #\space xp) + (pprint-indent :block 0 xp) + (pprint-newline :linear xp) + (write token :stream xp) + (next-token) + (pprint-indent :block 2 xp))) + (pprint-exit-if-list-exhausted) + (write (pprint-pop) :stream xp) + (next-token) + (write-char #\space xp) + (pprint-indent :current 0 xp) + (loop (print-clause xp) + (write-char #\space xp) + (pprint-newline :linear xp))))))) + +;; (defun basic-write (object stream) +;; (cond ((xp-structure-p stream) +;; (write+ object stream)) +;; (*print-pretty* +;; (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s)) +;; stream object)) +;; (t +;; (assert nil) +;; (sys:output-object object stream)))) + +(defun output-pretty-object (object stream) +;; (basic-write object stream)) + (cond ((xp-structure-p stream) + (write+ object stream)) + (*print-pretty* + (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s)) + stream object)) + (t + (assert nil) + (sys:output-object object stream)))) + +(provide 'pprint) + +;------------------------------------------------------------------------ + +;Copyright Massachusetts Institute of Technology, Cambridge, Massachusetts. + +;Permission to use, copy, modify, and distribute this software and its +;documentation for any purpose and without fee is hereby granted, +;provided that this copyright and permission notice appear in all +;copies and supporting documentation, and that the name of M.I.T. not +;be used in advertising or publicity pertaining to distribution of the +;software without specific, written prior permission. M.I.T. makes no +;representations about the suitability of this software for any +;purpose. It is provided "as is" without express or implied warranty. + +; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +; SOFTWARE. + +;------------------------------------------------------------------------ Added: branches/save-image/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/precompiler.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,1189 @@ +;;; precompiler.lisp +;;; +;;; Copyright (C) 2003-2008 Peter Graves +;;; $Id: precompiler.lisp 11695 2009-03-03 22:10:25Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export '(*inline-declarations* + process-optimization-declarations + process-special-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) + (unless (and (consp form) (eq (%car form) 'DECLARE)) + (return)) + (dolist (decl (%cdr form)) + (case (car decl) + (OPTIMIZE + (dolist (spec (%cdr decl)) + (let ((val 3) + (quality spec)) + (when (consp spec) + (setf quality (%car spec) + val (cadr spec))) + (when (and (fixnump val) + (<= 0 val 3)) + (case quality + (speed + (setf *speed* val)) + (safety + (setf *safety* val)) + (debug + (setf *debug* val)) + (space + (setf *space* val)) + (compilation-speed) ;; Ignored. + (t + (compiler-warn "Ignoring unknown optimization quality ~S in ~S." quality decl))))))) + ((INLINE NOTINLINE) + (dolist (symbol (%cdr decl)) + (push (cons symbol (%car decl)) *inline-declarations*))) + (:explain + (dolist (spec (%cdr decl)) + (let ((val t) + (quality spec)) + (when (consp spec) + (setf quality (%car spec)) + (when (= (length spec) 2) + (setf val (%cadr spec)))) + (if val + (pushnew quality *explain*) + (setf *explain* (remove quality *explain*))))))))) + t) + +;; Returns list of declared specials. +(declaim (ftype (function (list) list) process-special-declarations)) +(defun process-special-declarations (forms) + (let ((specials nil)) + (dolist (form forms) + (unless (and (consp form) (eq (%car form) 'DECLARE)) + (return)) + (let ((decls (%cdr form))) + (dolist (decl decls) + (when (eq (car decl) 'special) + (setq specials (append (cdr decl) specials)))))) + specials)) + +(declaim (ftype (function (t) t) inline-p)) +(defun inline-p (name) + (declare (optimize speed)) + (let ((entry (assoc name *inline-declarations*))) + (if entry + (eq (cdr entry) 'INLINE) + (and (symbolp name) (eq (get name '%inline) 'INLINE))))) + +(declaim (ftype (function (t) t) notinline-p)) +(defun notinline-p (name) + (declare (optimize speed)) + (let ((entry (assoc name *inline-declarations*))) + (if entry + (eq (cdr entry) 'NOTINLINE) + (and (symbolp name) (eq (get name '%inline) 'NOTINLINE))))) + +(defun expand-inline (form expansion) +;; (format t "expand-inline form = ~S~%" form) +;; (format t "expand-inline expansion = ~S~%" expansion) + (let* ((op (car form)) + (proclaimed-ftype (proclaimed-ftype op)) + (args (cdr form)) + (vars (cadr expansion)) + (varlist ()) + new-form) +;; (format t "op = ~S proclaimed-ftype = ~S~%" op (proclaimed-ftype op)) + (do ((vars vars (cdr vars)) + (args args (cdr args))) + ((null vars)) + (push (list (car vars) (car args)) varlist)) + (setf new-form (list* 'LET (nreverse varlist) + (copy-tree (cddr expansion)))) + (when proclaimed-ftype + (let ((result-type (ftype-result-type proclaimed-ftype))) + (when (and result-type + (neq result-type t) + (neq result-type '*)) + (setf new-form (list 'TRULY-THE result-type new-form))))) +;; (format t "expand-inline new form = ~S~%" new-form) + new-form)) + +(define-compiler-macro assoc (&whole form &rest args) + (cond ((and (= (length args) 4) + (eq (third args) :test) + (or (equal (fourth args) '(quote eq)) + (equal (fourth args) '(function eq)))) + `(assq ,(first args) ,(second args))) + ((= (length args) 2) + `(assql ,(first args) ,(second args))) + (t form))) + +(define-compiler-macro member (&whole form &rest args) + (let ((arg1 (first args)) + (arg2 (second args))) + (case (length args) + (2 + `(memql ,arg1 ,arg2)) + (4 + (let ((arg3 (third args)) + (arg4 (fourth args))) + (cond ((and (eq arg3 :test) + (or (equal arg4 '(quote eq)) + (equal arg4 '(function eq)))) + `(memq ,arg1 ,arg2)) + ((and (eq arg3 :test) + (or (equal arg4 '(quote eql)) + (equal arg4 '(function eql)) + (equal arg4 '(quote char=)) + (equal arg4 '(function char=)))) + `(memql ,arg1 ,arg2)) + (t + form)))) + (t + form)))) + +(define-compiler-macro search (&whole form &rest args) + (if (= (length args) 2) + `(simple-search , at args) + form)) + +(define-compiler-macro identity (&whole form &rest args) + (if (= (length args) 1) + `(progn ,(car args)) + form)) + +(defun quoted-form-p (form) + (and (consp form) (eq (%car form) 'QUOTE) (= (length form) 2))) + +(define-compiler-macro eql (&whole form &rest args) + (let ((first (car args)) + (second (cadr args))) + (if (or (and (quoted-form-p first) (symbolp (cadr first))) + (and (quoted-form-p second) (symbolp (cadr second)))) + `(eq ,first ,second) + form))) + +(define-compiler-macro not (&whole form arg) + (if (atom arg) + form + (let ((op (case (car arg) + (>= '<) + (< '>=) + (<= '>) + (> '<=) + (t nil)))) + (if (and op (= (length arg) 3)) + (cons op (cdr arg)) + form)))) + +(defun predicate-for-type (type) + (cdr (assq type '((ARRAY . arrayp) + (ATOM . atom) + (BIT-VECTOR . bit-vector-p) + (CHARACTER . characterp) + (COMPLEX . complexp) + (CONS . consp) + (FIXNUM . fixnump) + (FLOAT . floatp) + (FUNCTION . functionp) + (HASH-TABLE . hash-table-p) + (INTEGER . integerp) + (LIST . listp) + (NULL . null) + (NUMBER . numberp) + (NUMBER . numberp) + (PACKAGE . packagep) + (RATIONAL . rationalp) + (REAL . realp) + (SIMPLE-BIT-VECTOR . simple-bit-vector-p) + (SIMPLE-STRING . simple-string-p) + (SIMPLE-VECTOR . simple-vector-p) + (STREAM . streamp) + (STRING . stringp) + (SYMBOL . symbolp))))) + +(define-compiler-macro typep (&whole form &rest args) + (if (= (length args) 2) ; no environment arg + (let* ((object (%car args)) + (type-specifier (%cadr args)) + (type (and (consp type-specifier) + (eq (%car type-specifier) 'QUOTE) + (%cadr type-specifier))) + (predicate (and type (predicate-for-type type)))) + (if predicate + `(,predicate ,object) + `(%typep , at args))) + form)) + +(define-compiler-macro subtypep (&whole form &rest args) + (if (= (length args) 2) + `(%subtypep , at args) + form)) + +(define-compiler-macro funcall (&whole form &rest args) + (let ((callee (car args))) + (if (and (>= *speed* *debug*) + (consp callee) + (eq (%car callee) 'function) + (symbolp (cadr callee)) + (not (special-operator-p (cadr callee))) + (not (macro-function (cadr callee) sys:*compile-file-environment*)) + (memq (symbol-package (cadr callee)) + (list (find-package "CL") (find-package "SYS")))) + `(,(cadr callee) ,@(cdr args)) + form))) + +(define-compiler-macro byte (size position) + `(cons ,size ,position)) + +(define-compiler-macro byte-size (bytespec) + `(car ,bytespec)) + +(define-compiler-macro byte-position (bytespec) + `(cdr ,bytespec)) + +(define-source-transform concatenate (&whole form result-type &rest sequences) + (if (equal result-type '(quote STRING)) + `(sys::concatenate-to-string (list , at sequences)) + form)) + +(define-source-transform ldb (&whole form bytespec integer) + (if (and (consp bytespec) + (eq (%car bytespec) 'byte) + (= (length bytespec) 3)) + (let ((size (%cadr bytespec)) + (position (%caddr bytespec))) + `(%ldb ,size ,position ,integer)) + form)) + +(define-source-transform find (&whole form item sequence &key from-end test test-not start end key) + (cond ((and (>= (length form) 3) (null start) (null end)) + (cond ((and (stringp sequence) + (null from-end) + (member test '(#'eql #'char=) :test #'equal) + (null test-not) + (null key)) + `(string-find ,item ,sequence)) + (t + (let ((item-var (gensym)) + (seq-var (gensym))) + `(let ((,item-var ,item) + (,seq-var ,sequence)) + (if (listp ,seq-var) + (list-find* ,item-var ,seq-var ,from-end ,test ,test-not 0 (length ,seq-var) ,key) + (vector-find* ,item-var ,seq-var ,from-end ,test ,test-not 0 (length ,seq-var) ,key))))))) + (t + form))) + +(define-source-transform adjoin (&whole form &rest args) + (if (= (length args) 2) + `(adjoin-eql ,(first args) ,(second args)) + form)) + +(define-compiler-macro catch (&whole form tag &rest args) + (declare (ignore tag)) + (if (and (null (cdr args)) + (constantp (car args))) + (car args) + form)) + +(define-compiler-macro string= (&whole form &rest args) + (if (= (length args) 2) + `(sys::%%string= , at args) + form)) + +(define-compiler-macro <= (&whole form &rest args) + (cond ((and (= (length args) 3) + (numberp (first args)) + (numberp (third args)) + (= (first args) (third args))) + `(= ,(second args) ,(first args))) + (t + form))) + +(in-package "EXTENSIONS") + +(export '(precompile-form precompile)) + +(unless (find-package "PRECOMPILER") + (make-package "PRECOMPILER" + :nicknames '("PRE") + :use '("COMMON-LISP" "EXTENSIONS" "SYSTEM"))) + +(in-package "PRECOMPILER") + +(defvar *in-jvm-compile* nil) + +(defvar *local-variables* nil) + +(declaim (ftype (function (t) t) find-varspec)) +(defun find-varspec (sym) + (dolist (varspec *local-variables*) + (when (eq sym (car varspec)) + (return varspec)))) + +(declaim (ftype (function (t) t) precompile1)) +(defun precompile1 (form) + (cond ((symbolp form) + (let ((varspec (find-varspec form))) + (cond ((and varspec (eq (second varspec) :symbol-macro)) + (precompile1 (copy-tree (third varspec)))) + ((null varspec) + (let ((expansion (expand-macro form))) + (if (eq expansion form) + form + (precompile1 expansion)))) + (t + form)))) + ((atom form) + form) + (t + (let ((op (%car form)) + handler) + (when (symbolp op) + (cond ((setf handler (get op 'precompile-handler)) + (return-from precompile1 (funcall handler form))) + ((macro-function op *compile-file-environment*) + (return-from precompile1 (precompile1 (expand-macro form)))) + ((special-operator-p op) + (error "PRECOMPILE1: unsupported special operator ~S." op)))) + (precompile-function-call form))))) + +(defun precompile-identity (form) + (declare (optimize speed)) + form) + +(declaim (ftype (function (t) cons) precompile-cons)) +(defun precompile-cons (form) + (cons (car form) (mapcar #'precompile1 (cdr form)))) + +(declaim (ftype (function (t t) t) precompile-function-call)) +(defun precompile-function-call (form) + (let ((op (car form))) + (when (and (consp op) (eq (%car op) 'LAMBDA)) + (return-from precompile-function-call + (cons (precompile-lambda op) + (mapcar #'precompile1 (cdr form))))) + (when (or (not *in-jvm-compile*) (notinline-p op)) + (return-from precompile-function-call (precompile-cons form))) + (when (source-transform op) + (let ((new-form (expand-source-transform form))) + (when (neq new-form form) + (return-from precompile-function-call (precompile1 new-form))))) + (when *enable-inline-expansion* + (let ((expansion (inline-expansion op))) + (when expansion + (let ((explain *explain*)) + (when (and explain (memq :calls explain)) + (format t "; inlining call to ~S~%" op))) + (return-from precompile-function-call (precompile1 (expand-inline form expansion)))))) + (cons op (mapcar #'precompile1 (cdr form))))) + +(defun precompile-locally (form) + (let ((*inline-declarations* *inline-declarations*)) + (process-optimization-declarations (cdr form)) + (cons 'LOCALLY (mapcar #'precompile1 (cdr form))))) + +(defun precompile-block (form) + (let ((args (cdr form))) + (if (null (cdr args)) + nil + (list* 'BLOCK (car args) (mapcar #'precompile1 (cdr args)))))) + +(defun precompile-dolist (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (cons 'DOLIST (cons (mapcar #'precompile1 (cadr form)) + (mapcar #'precompile1 (cddr form)))))) + +(defun precompile-dotimes (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (cons 'DOTIMES (cons (mapcar #'precompile1 (cadr form)) + (mapcar #'precompile1 (cddr form)))))) + +(defun precompile-do/do*-vars (varlist) + (let ((result nil)) + (dolist (varspec varlist) + (if (atom varspec) + (push varspec result) + (case (length varspec) + (1 + (push (%car varspec) result)) + (2 + (let* ((var (%car varspec)) + (init-form (%cadr varspec))) + (unless (symbolp var) + (error 'type-error)) + (push (list var (precompile1 init-form)) + result))) + (3 + (let* ((var (%car varspec)) + (init-form (%cadr varspec)) + (step-form (%caddr varspec))) + (unless (symbolp var) + (error 'type-error)) + (push (list var (precompile1 init-form) (precompile1 step-form)) + result)))))) + (nreverse result))) + +(defun precompile-do/do*-end-form (end-form) + (let ((end-test-form (car end-form)) + (result-forms (cdr end-form))) + (list* end-test-form (mapcar #'precompile1 result-forms)))) + +(defun precompile-do/do* (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (list* (car form) + (precompile-do/do*-vars (cadr form)) + (precompile-do/do*-end-form (caddr form)) + (mapcar #'precompile1 (cdddr form))))) + +(defun precompile-do-symbols (form) + (list* (car form) (cadr form) (mapcar #'precompile1 (cddr form)))) + +(defun precompile-load-time-value (form) + form) + +(defun precompile-progn (form) + (let ((body (cdr form))) + (if (eql (length body) 1) + (let ((res (precompile1 (%car body)))) + ;; If the result turns out to be a bare symbol, leave it wrapped + ;; with PROGN so it won't be mistaken for a tag in an enclosing + ;; TAGBODY. + (if (symbolp res) + (list 'progn res) + res)) + (cons 'PROGN (mapcar #'precompile1 body))))) + +(defun precompile-progv (form) + (if (< (length form) 3) + (compiler-error "Not enough arguments for ~S." 'progv) + (list* 'PROGV (mapcar #'precompile1 (%cdr form))))) + +(defun precompile-setf (form) + (let ((place (second form))) + (cond ((and (consp place) + (eq (%car place) 'VALUES)) + (setf form + (list* 'SETF + (list* 'VALUES + (mapcar #'precompile1 (%cdr place))) + (cddr form))) + (precompile1 (expand-macro form))) + ((symbolp place) + (let ((varspec (find-varspec place))) + (if (and varspec (eq (second varspec) :symbol-macro)) + (precompile1 (list* 'SETF (copy-tree (third varspec)) (cddr form))) + (precompile1 (expand-macro form))))) + (t + (precompile1 (expand-macro form)))))) + +(defun precompile-setq (form) + (let* ((args (cdr form)) + (len (length args))) + (when (oddp len) + (error 'simple-program-error + :format-control "Odd number of arguments to SETQ.")) + (if (= len 2) + (let* ((sym (%car args)) + (val (%cadr args)) + (varspec (find-varspec sym))) + (if (and varspec (eq (second varspec) :symbol-macro)) + (precompile1 (list 'SETF (copy-tree (third varspec)) val)) + (list 'SETQ sym (precompile1 val)))) + (let ((result ())) + (loop + (when (null args) + (return)) + (push (precompile-setq (list 'SETQ (car args) (cadr args))) result) + (setq args (cddr args))) + (setq result (nreverse result)) + (push 'PROGN result) + result)))) + +(defun precompile-psetf (form) + (setf form + (list* 'PSETF + (mapcar #'precompile1 (cdr form)))) + (precompile1 (expand-macro form))) + +(defun precompile-psetq (form) + ;; Make sure all the vars are symbols. + (do* ((rest (cdr form) (cddr rest)) + (var (car rest))) + ((null rest)) + (unless (symbolp var) + (error 'simple-error + :format-control "~S is not a symbol." + :format-arguments (list var)))) + ;; Delegate to PRECOMPILE-PSETF so symbol macros are handled correctly. + (precompile-psetf form)) + +(defun rewrite-aux-vars-process-decls (forms arg-vars aux-vars) + (declare (ignore aux-vars)) + (let ((lambda-decls nil) + (let-decls nil)) + (dolist (form forms) + (unless (and (consp form) (eq (car form) 'DECLARE)) ; shouldn't happen + (return)) + (dolist (decl (cdr form)) + (case (car decl) + ((OPTIMIZE DECLARATION DYNAMIC-EXTENT FTYPE INLINE NOTINLINE) + (push (list 'DECLARE decl) lambda-decls)) + (SPECIAL + (dolist (name (cdr decl)) + (if (memq name arg-vars) + (push (list 'DECLARE (list 'SPECIAL name)) lambda-decls) + (push (list 'DECLARE (list 'SPECIAL name)) let-decls)))) + (TYPE + (dolist (name (cddr decl)) + (if (memq name arg-vars) + (push (list 'DECLARE (list 'TYPE (cadr decl) name)) lambda-decls) + (push (list 'DECLARE (list 'TYPE (cadr decl) name)) let-decls)))) + (t + (dolist (name (cdr decl)) + (if (memq name arg-vars) + (push (list 'DECLARE (list (car decl) name)) lambda-decls) + (push (list 'DECLARE (list (car decl) name)) let-decls))))))) + (setq lambda-decls (nreverse lambda-decls)) + (setq let-decls (nreverse let-decls)) + (values lambda-decls let-decls))) + +(defun rewrite-aux-vars (form) + (multiple-value-bind (body decls doc) + (parse-body (cddr form)) + (declare (ignore doc)) ; FIXME + (let* ((lambda-list (cadr form)) + (lets (cdr (memq '&AUX lambda-list))) + aux-vars) + (dolist (form lets) + (cond ((consp form) + (push (%car form) aux-vars)) + (t + (push form aux-vars)))) + (setq aux-vars (nreverse aux-vars)) + (setq lambda-list (subseq lambda-list 0 (position '&AUX lambda-list))) + (multiple-value-bind (lambda-decls let-decls) + (rewrite-aux-vars-process-decls decls (lambda-list-names lambda-list) aux-vars) + `(lambda ,lambda-list , at lambda-decls (let* ,lets , at let-decls , at body)))))) + +(defun maybe-rewrite-lambda (form) + (let* ((lambda-list (cadr form))) + (when (memq '&AUX lambda-list) + (setq form (rewrite-aux-vars form)) + (setq lambda-list (cadr form))) + (multiple-value-bind (body decls doc) + (parse-body (cddr form)) + (let* ((declared-specials (process-special-declarations decls)) + (specials nil)) + ;; Scan for specials. + (let ((keyp nil)) + (dolist (var lambda-list) + (cond ((eq var '&KEY) + (setq keyp t)) + ((atom var) + (when (or (special-variable-p var) (memq var declared-specials)) + (push var specials))) + ((not keyp) ;; e.g. "&optional (*x* 42)" + (setq var (%car var)) + (when (or (special-variable-p var) (memq var declared-specials)) + (push var specials))) + ;; Keyword parameters. + ((atom (%car var)) ;; e.g. "&key (a 42)" + ;; Not special. + ) + (t + ;; e.g. "&key ((:x *x*) 42)" + (setq var (second (%car var))) ;; *x* + (when (or (special-variable-p var) (memq var declared-specials)) + (push var specials)))))) + ;;//###FIXME: Ideally, we don't rewrite for specials at all + (when specials + ;; For each special... + (dolist (special specials) + (let ((sym special)) + (let ((res nil) + (keyp nil)) + ;; Walk through the lambda list and replace each occurrence. + (dolist (var lambda-list) + (cond ((eq var '&KEY) + (setq keyp t) + (push var res)) + ((atom var) + (when (eq var special) + (setq var sym)) + (push var res)) + ((not keyp) ;; e.g. "&optional (*x* 42)" + (when (eq (%car var) special) + (setf (car var) sym)) + (push var res)) + ((atom (%car var)) ;; e.g. "&key (a 42)" + (push var res)) + (t + ;; e.g. "&key ((:x *x*) 42)" + (when (eq (second (%car var)) special) + (setf (second (%car var)) sym)) + (push var res)))) + (setq lambda-list (nreverse res))) + (setq body (list (append (list 'LET* (list (list special sym))) body)))))) + `(lambda ,lambda-list , at decls ,@(when doc `(,doc)) , at body))))) + +(defun precompile-lambda (form) + (setq form (maybe-rewrite-lambda form)) + (let ((body (cddr form)) + (*inline-declarations* *inline-declarations*)) + (process-optimization-declarations body) + (list* 'LAMBDA (cadr form) (mapcar #'precompile1 body)))) + +(defun precompile-named-lambda (form) + (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form)))) + (setf lambda-form (maybe-rewrite-lambda lambda-form)) + (let ((body (cddr lambda-form)) + (*inline-declarations* *inline-declarations*)) + (process-optimization-declarations body) + (list* 'NAMED-LAMBDA (cadr form) (cadr lambda-form) + (mapcar #'precompile1 body))))) + +(defun precompile-defun (form) + (if *in-jvm-compile* + (precompile1 (expand-macro form)) + form)) + +(defvar *local-functions-and-macros* ()) + +(defun precompile-macrolet (form) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*))) + (dolist (definition (cadr form)) + (environment-add-macro-definition + *compile-file-environment* + (car definition) + (make-macro (car definition) + (make-closure + (make-expander-for-macrolet definition) + NIL)))) + (multiple-value-bind (body decls) + (parse-body (cddr form) nil) + `(locally , at decls ,@(mapcar #'precompile1 body))))) + +;; "If the restartable-form is a list whose car is any of the symbols SIGNAL, +;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a +;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the +;; indicated restarts with the condition to be signaled." So we need to +;; precompile the restartable form before macroexpanding RESTART-CASE. +(defun precompile-restart-case (form) + (let ((new-form (list* 'RESTART-CASE (precompile1 (cadr form)) (cddr form)))) + (precompile1 (macroexpand new-form sys:*compile-file-environment*)))) + +(defun precompile-symbol-macrolet (form) + (let ((*local-variables* *local-variables*) + (*compile-file-environment* + (make-environment *compile-file-environment*)) + (defs (cadr form))) + (dolist (def defs) + (let ((sym (car def)) + (expansion (cadr def))) + (when (special-variable-p sym) + (error 'program-error + :format-control "Attempt to bind the special variable ~S with SYMBOL-MACROLET." + :format-arguments (list sym))) + (push (list sym :symbol-macro expansion) *local-variables*) + (environment-add-symbol-binding *compile-file-environment* + sym + (sys::make-symbol-macro expansion)) + )) + (multiple-value-bind (body decls) + (parse-body (cddr form) nil) + (when decls + (let ((specials ())) + (dolist (decl decls) + (when (eq (car decl) 'DECLARE) + (dolist (declspec (cdr decl)) + (when (eq (car declspec) 'SPECIAL) + (setf specials (append specials (cdr declspec))))))) + (when specials + (let ((syms (mapcar #'car (cadr form)))) + (dolist (special specials) + (when (memq special syms) + (error 'program-error + :format-control "~S is a symbol-macro and may not be declared special." + :format-arguments (list special)))))))) + `(locally , at decls ,@(mapcar #'precompile1 body))))) + +(defun precompile-the (form) + (list 'THE + (second form) + (precompile1 (third form)))) + +(defun precompile-truly-the (form) + (list 'TRULY-THE + (second form) + (precompile1 (third form)))) + +(defun precompile-let/let*-vars (vars) + (let ((result nil)) + (dolist (var vars) + (cond ((consp var) +;; (when (> (length var) 2) +;; (error 'program-error +;; :format-control "The LET/LET* binding specification ~S is invalid." +;; :format-arguments (list var))) + (let ((v (%car var)) + (expr (cadr var))) + (unless (symbolp v) + (error 'simple-type-error + :format-control "The variable ~S is not a symbol." + :format-arguments (list v))) + (push (list v (precompile1 expr)) result) + (push (list v :variable) *local-variables*))) + (t + (push var result) + (push (list var :variable) *local-variables*)))) + (nreverse result))) + +(defun precompile-let (form) + (let ((*local-variables* *local-variables*)) + (list* 'LET + (precompile-let/let*-vars (cadr form)) + (mapcar #'precompile1 (cddr form))))) + +;; (LET* ((X 1)) (LET* ((Y 2)) (LET* ((Z 3)) (+ X Y Z)))) => +;; (LET* ((X 1) (Y 2) (Z 3)) (+ X Y Z)) +(defun maybe-fold-let* (form) + (if (and (= (length form) 3) + (consp (%caddr form)) + (eq (%car (%caddr form)) 'LET*)) + (let ((third (maybe-fold-let* (%caddr form)))) + (list* 'LET* (append (%cadr form) (cadr third)) (cddr third))) + form)) + +(defun precompile-let* (form) + (setf form (maybe-fold-let* form)) + (let ((*local-variables* *local-variables*)) + (list* 'LET* + (precompile-let/let*-vars (cadr form)) + (mapcar #'precompile1 (cddr form))))) + +(defun precompile-case (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (let* ((keyform (cadr form)) + (clauses (cddr form)) + (result (list (precompile1 keyform)))) + (dolist (clause clauses) + (push (precompile-case-clause clause) result)) + (cons (car form) (nreverse result))))) + +(defun precompile-case-clause (clause) + (let ((keys (car clause)) + (forms (cdr clause))) + (cons keys (mapcar #'precompile1 forms)))) + +(defun precompile-cond (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (let ((clauses (cdr form)) + (result nil)) + (dolist (clause clauses) + (push (precompile-cond-clause clause) result)) + (cons 'COND (nreverse result))))) + +(defun precompile-cond-clause (clause) + (let ((test (car clause)) + (forms (cdr clause))) + (cons (precompile1 test) (mapcar #'precompile1 forms)))) + +(defun precompile-local-function-def (def) + (let ((name (car def)) + (arglist (cadr def)) + (body (cddr def))) + ;; Macro names are shadowed by local functions. + (environment-add-function-definition *compile-file-environment* name body) + (list* name arglist (mapcar #'precompile1 body)))) + +(defun precompile-local-functions (defs) + (let ((result nil)) + (dolist (def defs (nreverse result)) + (push (precompile-local-function-def def) result)))) + +(defun find-use (name expression) + (cond ((atom expression) + nil) + ((eq (%car expression) name) + t) + ((consp name) + t) ;; FIXME Recognize use of SETF functions! + (t + (or (find-use name (%car expression)) + (find-use name (%cdr expression)))))) + +(defun precompile-flet/labels (form) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*)) + (operator (car form)) + (locals (cadr form)) + (body (cddr form))) + (dolist (local locals) + (let* ((name (car local)) + (used-p (find-use name body))) + (unless used-p + (when (eq operator 'LABELS) + (dolist (local locals) + (when (neq name (car local)) + (when (find-use name (cddr local)) + (setf used-p t) + (return)) + ;; Scope of defined function names includes &AUX parameters (LABELS.7B). + (let ((aux-vars (cdr (memq '&aux (cadr local))))) + (when (and aux-vars (find-use name aux-vars) + (setf used-p t) + (return)))))))) + (unless used-p + (format t "; Note: deleting unused local function ~A ~S~%" operator name) + (let* ((new-locals (remove local locals :test 'eq)) + (new-form + (if new-locals + (list* operator new-locals body) + (list* 'PROGN body)))) + (return-from precompile-flet/labels (precompile1 new-form)))))) + (list* (car form) + (precompile-local-functions locals) + (mapcar #'precompile1 body)))) + +(defun precompile-function (form) + (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA)) + (list 'FUNCTION (precompile-lambda (%cadr form))) + form)) + +(defun precompile-if (form) + (let ((args (cdr form))) + (case (length args) + (2 + (let ((test (precompile1 (%car args)))) + (cond ((null test) + nil) + (;;(constantp test) + (eq test t) + (precompile1 (%cadr args))) + (t + (list 'IF + test + (precompile1 (%cadr args))))))) + (3 + (let ((test (precompile1 (%car args)))) + (cond ((null test) + (precompile1 (%caddr args))) + (;;(constantp test) + (eq test t) + (precompile1 (%cadr args))) + (t + (list 'IF + test + (precompile1 (%cadr args)) + (precompile1 (%caddr args))))))) + (t + (error "wrong number of arguments for IF"))))) + +(defun precompile-when (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (precompile-cons form))) + +(defun precompile-unless (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (precompile-cons form))) + +;; MULTIPLE-VALUE-BIND is handled explicitly by the JVM compiler. +(defun precompile-multiple-value-bind (form) + (let ((vars (cadr form)) + (values-form (caddr form)) + (body (cdddr form))) + (list* 'MULTIPLE-VALUE-BIND + vars + (precompile1 values-form) + (mapcar #'precompile1 body)))) + +;; MULTIPLE-VALUE-LIST is handled explicitly by the JVM compiler. +(defun precompile-multiple-value-list (form) + (list 'MULTIPLE-VALUE-LIST (precompile1 (cadr form)))) + +(defun precompile-nth-value (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + form)) + +(defun precompile-return (form) + (if *in-jvm-compile* + (precompile1 (macroexpand form)) + (list 'RETURN (precompile1 (cadr form))))) + +(defun precompile-return-from (form) + (list 'RETURN-FROM (cadr form) (precompile1 (caddr form)))) + +(defun precompile-tagbody (form) + (do ((body (cdr form) (cdr body)) + (result ())) + ((null body) (cons 'TAGBODY (nreverse result))) + (if (atom (car body)) + (push (car body) result) + (push (let* ((first-form (car body)) + (expanded (precompile1 first-form))) + (if (and (symbolp expanded) + (neq expanded first-form)) + ;; Workaround: + ;; Since our expansion/compilation order + ;; is out of sync with the definition of + ;; TAGBODY (which requires the compiler + ;; to look for tags before expanding), + ;; we need to disguise anything which might + ;; look like a tag. We do this by wrapping + ;; it in a PROGN form. + (list 'PROGN expanded) + expanded)) result)))) + +(defun precompile-eval-when (form) + (list* 'EVAL-WHEN (cadr form) (mapcar #'precompile1 (cddr form)))) + +(defun precompile-unwind-protect (form) + (list* 'UNWIND-PROTECT + (precompile1 (cadr form)) + (mapcar #'precompile1 (cddr form)))) + +;; EXPAND-MACRO is like MACROEXPAND, but EXPAND-MACRO quits if *IN-JVM-COMPILE* +;; is false and a macro is encountered that is also implemented as a special +;; operator, so interpreted code can use the special operator implementation. +(defun expand-macro (form) + (loop + (unless *in-jvm-compile* + (when (and (consp form) + (symbolp (%car form)) + (special-operator-p (%car form))) + (return-from expand-macro form))) + (multiple-value-bind (result expanded) + (macroexpand-1 form *compile-file-environment*) + (unless expanded + (return-from expand-macro result)) + (setf form result)))) + +(declaim (ftype (function (t t) t) precompile-form)) +(defun precompile-form (form in-jvm-compile) + (let ((*in-jvm-compile* in-jvm-compile) + (*inline-declarations* *inline-declarations*) + (*local-functions-and-macros* ())) + (precompile1 form))) + +(defun install-handler (symbol &optional handler) + (declare (type symbol symbol)) + (let ((handler (or handler + (find-symbol (sys::%format nil "PRECOMPILE-~A" (symbol-name symbol)) + 'precompiler)))) + (unless (and handler (fboundp handler)) + (error "No handler for ~S." symbol)) + (setf (get symbol 'precompile-handler) handler))) + +(defun install-handlers () + (mapcar #'install-handler '(BLOCK + CASE + COND + DOLIST + DOTIMES + EVAL-WHEN + FUNCTION + IF + LAMBDA + MACROLET + MULTIPLE-VALUE-BIND + MULTIPLE-VALUE-LIST + NAMED-LAMBDA + NTH-VALUE + PROGN + PROGV + PSETF + PSETQ + RESTART-CASE + RETURN + RETURN-FROM + SETF + SETQ + SYMBOL-MACROLET + TAGBODY + UNWIND-PROTECT + UNLESS + WHEN)) + + (dolist (pair '((ECASE precompile-case) + + (AND precompile-cons) + (OR precompile-cons) + + (CATCH precompile-cons) + (MULTIPLE-VALUE-CALL precompile-cons) + (MULTIPLE-VALUE-PROG1 precompile-cons) + + (DO precompile-do/do*) + (DO* precompile-do/do*) + + (LET precompile-let) + (LET* precompile-let*) + + (LOCALLY precompile-locally) + + (FLET precompile-flet/labels) + (LABELS precompile-flet/labels) + + (LOAD-TIME-VALUE precompile-load-time-value) + + (DECLARE precompile-identity) +;; (DEFMETHOD precompile-identity) + (DEFUN precompile-defun) + (GO precompile-identity) + (QUOTE precompile-identity) + (THE precompile-the) + (THROW precompile-cons) + (TRULY-THE precompile-truly-the))) + (install-handler (first pair) (second pair)))) + +(install-handlers) + +(in-package #:system) + +(defun precompile (name &optional definition) + (unless definition + (setq definition (or (and (symbolp name) (macro-function name)) + (fdefinition name)))) + (let (expr result) + (cond ((functionp definition) + (multiple-value-bind (form closure-p) + (function-lambda-expression definition) + (unless form +;; (format t "; No lambda expression available for ~S.~%" name) + (return-from precompile (values nil t t))) + (when closure-p + (format t "; Unable to compile function ~S defined in non-null lexical environment.~%" name) + (finish-output) + (return-from precompile (values nil t t))) + (setq expr form))) + ((and (consp definition) (eq (%car definition) 'lambda)) + (setq expr definition)) + (t +;; (error 'type-error))) + (format t "Unable to precompile ~S.~%" name) + (return-from precompile (values nil t t)))) + (setf result (coerce-to-function (precompile-form expr nil))) + (when (and name (functionp result)) + (%set-lambda-name result name) + (set-call-count result (call-count definition)) + (let ((*warn-on-redefinition* nil)) + (if (and (symbolp name) (macro-function name)) + (let ((mac (make-macro name result))) + (%set-arglist mac (arglist (symbol-function name))) + (setf (fdefinition name) mac)) + (progn + (setf (fdefinition name) result) + (%set-arglist result (arglist definition)))))) + (values (or name result) nil nil))) + +(defun precompile-package (pkg &key verbose) + (dolist (sym (package-symbols pkg)) + (when (fboundp sym) + (unless (special-operator-p sym) + (let ((f (fdefinition sym))) + (unless (compiled-function-p f) + (when verbose + (format t "Precompiling ~S~%" sym) + (finish-output)) + (precompile sym)))))) + t) + +(defun %compile (name definition) + (if (and name (fboundp name) (%typep (symbol-function name) 'generic-function)) + (values name nil nil) + (precompile name definition))) + +;; ;; Redefine EVAL to precompile its argument. +;; (defun eval (form) +;; (%eval (precompile-form form nil))) + +;; ;; Redefine DEFMACRO to precompile the expansion function on the fly. +;; (defmacro defmacro (name lambda-list &rest body) +;; (let* ((form (gensym "WHOLE-")) +;; (env (gensym "ENVIRONMENT-"))) +;; (multiple-value-bind (body decls) +;; (parse-defmacro lambda-list form body name 'defmacro :environment env) +;; (let ((expander `(lambda (,form ,env) , at decls (block ,name ,body)))) +;; `(progn +;; (let ((macro (make-macro ',name +;; (or (precompile nil ,expander) ,expander)))) +;; ,@(if (special-operator-p name) +;; `((put ',name 'macroexpand-macro macro)) +;; `((fset ',name macro))) +;; (%set-arglist macro ',lambda-list) +;; ',name)))))) + +;; Make an exception just this one time... +(when (get 'defmacro 'macroexpand-macro) + (fset 'defmacro (get 'defmacro 'macroexpand-macro)) + (remprop 'defmacro 'macroexpand-macro)) + +(defvar *defined-functions*) + +(defvar *undefined-functions*) + +(defun note-name-defined (name) + (when (boundp '*defined-functions*) + (push name *defined-functions*)) + (when (and (boundp '*undefined-functions*) (not (null *undefined-functions*))) + (setf *undefined-functions* (remove name *undefined-functions*)))) + +;; Redefine DEFUN to precompile the definition on the fly. +(defmacro defun (name lambda-list &body body &environment env) + (note-name-defined name) + (multiple-value-bind (body decls doc) + (parse-body body) + (let* ((block-name (fdefinition-block-name name)) + (lambda-expression `(named-lambda ,name ,lambda-list , at decls ,@(when doc `(,doc)) + (block ,block-name , at body)))) + (cond (*compile-file-truename* + `(fset ',name ,lambda-expression)) + (t + (when (and env (empty-environment-p env)) + (setf env nil)) + (when (null env) + (setf lambda-expression (precompile-form lambda-expression nil))) + `(progn + (%defun ',name ,lambda-expression) + ,@(when doc + `((%set-documentation ',name 'function ,doc))))))))) Added: branches/save-image/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/print-object.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,133 @@ +;;; print-object.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: print-object.lisp 11590 2009-01-25 23:34:24Z astalla $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(require 'clos) +(require 'java) + +(when (autoloadp 'print-object) + (fmakunbound 'print-object)) + +(defgeneric print-object (object stream)) + +(defmethod print-object ((object t) stream) + (print-unreadable-object (object stream :type t :identity t))) + +(defmethod print-object ((object structure-object) stream) + (write-string (%write-to-string object) stream)) + +(defmethod print-object ((object standard-object) stream) + (print-unreadable-object (object stream :identity t) + (format stream "~S" (class-name (class-of object)))) + object) + +(defmethod print-object ((class java:java-class) stream) + (write-string (%write-to-string class) stream)) + +(defmethod print-object ((class class) stream) + (print-unreadable-object (class stream :identity t) + (format stream "~S ~S" + (class-name (class-of class)) + (class-name class))) + class) + +(defmethod print-object ((gf standard-generic-function) stream) + (print-unreadable-object (gf stream :identity t) + (format stream "~S ~S" + (class-name (class-of gf)) + (%generic-function-name gf))) + gf) + +(defmethod print-object ((method standard-method) stream) + (print-unreadable-object (method stream :identity t) + (format stream "~S ~S~{ ~S~} ~S" + (class-name (class-of method)) + (%generic-function-name + (%method-generic-function method)) + (method-qualifiers method) + (mapcar #'(lambda (c) + (if (typep c 'mop::eql-specializer) + `(eql ,(mop::eql-specializer-object c)) + (class-name c))) + (%method-specializers method)))) + method) + +(defmethod print-object ((restart restart) stream) + (if *print-escape* + (print-unreadable-object (restart stream :type t :identity t) + (prin1 (restart-name restart) stream)) + (restart-report restart stream))) + +(defmethod print-object ((c condition) stream) + (if *print-escape* + (call-next-method) + (if (slot-boundp c 'format-control) + (apply #'format stream + (simple-condition-format-control c) + (simple-condition-format-arguments c)) + (call-next-method)))) + +(defmethod print-object ((c type-error) stream) + (if *print-escape* + (call-next-method) + (if (slot-boundp c 'format-control) + (apply 'format stream + (simple-condition-format-control c) + (simple-condition-format-arguments c)) + (format stream "The value ~S is not of type ~S." + (type-error-datum c) + (type-error-expected-type c))))) + +(defmethod print-object ((x undefined-function) stream) + (if *print-escape* + (call-next-method) + (format stream "The function ~S is undefined." (cell-error-name x)))) + +(defmethod print-object ((x unbound-variable) stream) + (if *print-escape* + (print-unreadable-object (x stream :identity t) + (format stream "~S ~S" + (type-of x) + (cell-error-name x))) + (format stream "The variable ~S is unbound." (cell-error-name x)))) + +(defmethod print-object ((e java:java-exception) stream) + (if *print-escape* + (print-unreadable-object (e stream :type t :identity t) + (format stream "~A" + (java:jcall (java:jmethod "java.lang.Object" "toString") + (java:java-exception-cause e)))) + (format stream "Java exception '~A'." + (java:jcall (java:jmethod "java.lang.Object" "toString") + (java:java-exception-cause e))))) + +(provide 'print-object) Added: branches/save-image/src/org/armedbear/lisp/print-unreadable-object.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/print-unreadable-object.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,57 @@ +;;; print-unreadable-object.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: print-unreadable-object.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defun %print-unreadable-object (object stream type identity body) + (setf stream (out-synonym-of stream)) + (when *print-readably* + (error 'print-not-readable :object object)) + (format stream "#<") + (when type + (format stream "~S" (type-of object)) + (format stream " ")) + (when body + (funcall body)) + (when identity + (when (or body (not type)) + (format stream " ")) + (format stream "{~X}" (identity-hash-code object))) + (format stream ">") + nil) + +(defmacro print-unreadable-object ((object stream &key type identity) &body body) + `(%print-unreadable-object ,object ,stream ,type ,identity + ,(if body + `(lambda () , at body) + nil))) Added: branches/save-image/src/org/armedbear/lisp/print.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/print.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,308 @@ +;;; print.lisp +;;; +;;; Copyright (C) 2004-2006 Peter Graves +;;; $Id: print.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +;;; Can this object contain other objects? +(defun compound-object-p (x) + (or (consp x) + (typep x 'structure-object) + (typep x 'standard-object) + (typep x '(array t *)))) + +;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and +;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from +;;; the block named NIL. +(defmacro punt-print-if-too-long (index stream) + `(when (and (not *print-readably*) + *print-length* + (>= ,index *print-length*)) + (write-string "..." ,stream) + (return))) + +(defun output-integer (integer stream) +;; (%output-object integer stream)) + (if (xp::xp-structure-p stream) + (let ((s (sys::%write-to-string integer))) + (xp::write-string++ s stream 0 (length s))) + (%output-object integer stream))) + +(defun output-list (list stream) + (cond ((and (null *print-readably*) + *print-level* + (>= *current-print-level* *print-level*)) + (write-char #\# stream)) + (t + (let ((*current-print-level* (1+ *current-print-level*))) + (write-char #\( stream) + (let ((*current-print-length* 0) + (list list)) + (loop + (punt-print-if-too-long *current-print-length* stream) + (output-object (pop list) stream) + (unless list + (return)) + (when (or (atom list) + (check-for-circularity list)) + (write-string " . " stream) + (output-object list stream) + (return)) + (write-char #\space stream) + (incf *current-print-length*))) + (write-char #\) stream)))) + list) + +;;; Output the abbreviated #< form of an array. +(defun output-terse-array (array stream) + (let ((*print-level* nil) + (*print-length* nil)) + (print-unreadable-object (array stream :type t :identity t)))) + +(defun array-readably-printable-p (array) + (and (eq (array-element-type array) t) + (let ((zero (position 0 (array-dimensions array))) + (number (position 0 (array-dimensions array) + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number))))) + +(defun output-vector (vector stream) + (declare (vector vector)) + (cond ((stringp vector) + (assert nil) + (sys::%output-object vector stream)) + ((not (or *print-array* *print-readably*)) + (output-terse-array vector stream)) + ((bit-vector-p vector) + (assert nil) + (sys::%output-object vector stream)) + (t + (when (and *print-readably* + (not (array-readably-printable-p vector))) + (error 'print-not-readable :object vector)) + (cond ((and (null *print-readably*) + *print-level* + (>= *current-print-level* *print-level*)) + (write-char #\# stream)) + (t + (let ((*current-print-level* (1+ *current-print-level*))) + (write-string "#(" stream) + (dotimes (i (length vector)) + (unless (zerop i) + (write-char #\space stream)) + (punt-print-if-too-long i stream) + (output-object (aref vector i) stream)) + (write-string ")" stream)))))) + vector) + +(defun output-ugly-object (object stream) + (cond ((consp object) + (output-list object stream)) + ((and (vectorp object) + (not (stringp object)) + (not (bit-vector-p object))) + (output-vector object stream)) + ((structure-object-p object) + (print-object object stream)) + ((standard-object-p object) + (print-object object stream)) + ((xp::xp-structure-p stream) + (let ((s (sys::%write-to-string object))) + (xp::write-string++ s stream 0 (length s)))) + (t + (%output-object object stream)))) + +;;;; circularity detection stuff + +;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that +;;; (eventually) ends up with entries for every object printed. When +;;; we are initially looking for circularities, we enter a T when we +;;; find an object for the first time, and a 0 when we encounter an +;;; object a second time around. When we are actually printing, the 0 +;;; entries get changed to the actual marker value when they are first +;;; printed. +(defvar *circularity-hash-table* nil) + +;;; When NIL, we are just looking for circularities. After we have +;;; found them all, this gets bound to 0. Then whenever we need a new +;;; marker, it is incremented. +(defvar *circularity-counter* nil) + +;;; Check to see whether OBJECT is a circular reference, and return +;;; something non-NIL if it is. If ASSIGN is T, then the number to use +;;; in the #n= and #n# noise is assigned at this time. +;;; If ASSIGN is true, reference bookkeeping will only be done for +;;; existing entries, no new references will be recorded! +;;; +;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with +;;; ASSIGN true, or the circularity detection noise will get confused +;;; about when to use #n= and when to use #n#. If this returns non-NIL +;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it. +;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value, +;;; you need to initiate the circularity detection noise, e.g. bind +;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values +;;; (see #'OUTPUT-OBJECT for an example). +(defun check-for-circularity (object &optional assign) + (cond ((null *print-circle*) + ;; Don't bother, nobody cares. + nil) + ((null *circularity-hash-table*) + (values nil :initiate)) + ((null *circularity-counter*) + (ecase (gethash object *circularity-hash-table*) + ((nil) + ;; first encounter + (setf (gethash object *circularity-hash-table*) t) + ;; We need to keep looking. + nil) + ((t) + ;; second encounter + (setf (gethash object *circularity-hash-table*) 0) + ;; It's a circular reference. + t) + (0 + ;; It's a circular reference. + t))) + (t + (let ((value (gethash object *circularity-hash-table*))) + (case value + ((nil t) + ;; If NIL, we found an object that wasn't there the + ;; first time around. If T, this object appears exactly + ;; once. Either way, just print the thing without any + ;; special processing. Note: you might argue that + ;; finding a new object means that something is broken, + ;; but this can happen. If someone uses the ~@<...~:> + ;; format directive, it conses a new list each time + ;; though format (i.e. the &REST list), so we will have + ;; different cdrs. + nil) + (0 + (if assign + (let ((value (incf *circularity-counter*))) + ;; first occurrence of this object: Set the counter. + (setf (gethash object *circularity-hash-table*) value) + value) + t)) + (t + ;; second or later occurrence + (- value))))))) + +;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then +;;; you should go ahead and print the object. If it returns NIL, then +;;; you should blow it off. +(defun handle-circularity (marker stream) + (case marker + (:initiate + ;; Someone forgot to initiate circularity detection. + (let ((*print-circle* nil)) + (error "trying to use CHECK-FOR-CIRCULARITY when ~ + circularity checking isn't initiated"))) + ((t) + ;; It's a second (or later) reference to the object while we are + ;; just looking. So don't bother groveling it again. + nil) + (t +;; (write-char #\# stream) +;; (let ((*print-base* 10) +;; (*print-radix* nil)) + (cond ((minusp marker) +;; (output-integer (- marker) stream) +;; (write-char #\# stream) + (print-reference marker stream) + nil) + (t +;; (output-integer marker stream) +;; (write-char #\= stream) + (print-label marker stream) + t))))) + +(defun print-label (marker stream) + (write-char #\# stream) + (let ((*print-base* 10) + (*print-radix* nil)) + (output-integer marker stream)) + (write-char #\= stream)) + +(defun print-reference (marker stream) + (write-char #\# stream) + (let ((*print-base* 10) + (*print-radix* nil)) + (output-integer (- marker) stream)) + (write-char #\# stream)) + +;;;; OUTPUT-OBJECT -- the main entry point + +;; Objects whose print representation identifies them EQLly don't need to be +;; checked for circularity. +(defun uniquely-identified-by-print-p (x) + (or (numberp x) + (characterp x) + (and (symbolp x) + (symbol-package x)))) + +(defun %print-object (object stream) + (if *print-pretty* + (xp:output-pretty-object object stream) + (output-ugly-object object stream))) + +(defun %check-object (object stream) + (multiple-value-bind (marker initiate) + (check-for-circularity object t) + (if (eq initiate :initiate) + ;; Initialize circularity detection. + (let ((*circularity-hash-table* (make-hash-table :test 'eq))) + (%check-object object (make-broadcast-stream)) + (let ((*circularity-counter* 0)) + (%check-object object stream))) + ;; Otherwise... + (if marker + (when (handle-circularity marker stream) + (%print-object object stream)) + (%print-object object stream))))) + +;;; Output OBJECT to STREAM observing all printer control variables. +(defun output-object (object stream) + (cond ((or (not *print-circle*) + (uniquely-identified-by-print-p object)) + (%print-object object stream)) + ;; If we have already started circularity detection, this object might + ;; be a shared reference. If we have not, then if it is a compound + ;; object, it might contain a circular reference to itself or multiple + ;; shared references. + ((or *circularity-hash-table* + (compound-object-p object)) + (%check-object object stream)) + (t + (%print-object object stream))) + object) Added: branches/save-image/src/org/armedbear/lisp/probe_file.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/probe_file.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,95 @@ +/* + * probe_file.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: probe_file.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; + +public final class probe_file extends Lisp +{ + // ### probe-file + // probe-file pathspec => truename + private static final Primitive PROBE_FILE = + new Primitive("probe-file", "pathspec") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Pathname.truename(arg, false); + } + }; + + // ### truename + // truename filespec => truename + private static final Primitive TRUENAME = + new Primitive("truename", "filespec") + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return Pathname.truename(arg, true); + } + }; + + // ### probe-directory + // probe-directory pathspec => truename + private static final Primitive PROBE_DIRECTORY = + new Primitive("probe-directory", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) + error(new FileError("Bad place for a wild pathname.", pathname)); + File file = Utilities.getFile(pathname); + return file.isDirectory() ? Utilities.getDirectoryPathname(file) : NIL; + } + }; + + // ### file-directory-p + // file-directory-p pathspec => generalized-boolean + private static final Primitive FILE_DIRECTORY_P = + new Primitive("file-directory-p", PACKAGE_EXT, true) + { + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + Pathname pathname = coerceToPathname(arg); + if (pathname.isWild()) + error(new FileError("Bad place for a wild pathname.", pathname)); + File file = Utilities.getFile(pathname); + return file.isDirectory() ? T : NIL; + } + }; +} Added: branches/save-image/src/org/armedbear/lisp/proclaim.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/proclaim.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,149 @@ +;;; proclaim.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: proclaim.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type)) + +(defmacro declaim (&rest decls) +`(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(mapcar (lambda (decl) `(proclaim ',decl)) + decls))) + +(defun declaration-error (name) + (error 'simple-error + :format-control "The symbol ~S cannot be both the name of a type and the name of a declaration." + :format-arguments (list name))) + +(defvar *declaration-types* (make-hash-table :test 'eq)) + +;; "A symbol cannot be both the name of a type and the name of a declaration. +;; Defining a symbol as the name of a class, structure, condition, or type, +;; when the symbol has been declared as a declaration name, or vice versa, +;; signals an error." +(defun check-declaration-type (name) + (when (gethash1 name (the hash-table *declaration-types*)) + (declaration-error name))) + +(defun proclaim (declaration-specifier) + (unless (symbolp (car declaration-specifier)) + (%type-error (car declaration-specifier) 'symbol)) + ;; (cdr declaration-specifier) must be a proper list. + (unless (listp (cddr declaration-specifier)) + (%type-error (cddr declaration-specifier) 'list)) + (case (car declaration-specifier) + (SPECIAL + (dolist (name (cdr declaration-specifier)) + (%defvar name))) + (OPTIMIZE + (dolist (spec (cdr declaration-specifier)) + (let ((val 3) + (quality spec)) + (when (consp spec) + (setf quality (%car spec) + val (cadr spec))) + (when (and (fixnump val) + (<= 0 val 3)) + (case quality + (SPEED + (setf *speed* val)) + (SPACE + (setf *space* val)) + (SAFETY + (setf *safety* val)) + (DEBUG + (setf *debug* val))))))) + (FTYPE + (unless (cdr declaration-specifier) + (error "No type specified in FTYPE declaration: ~S" declaration-specifier)) + (apply 'proclaim-ftype (cdr declaration-specifier))) + (TYPE + (unless (cdr declaration-specifier) + (error "No type specified in TYPE declaration: ~S" declaration-specifier)) + (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))))) + (DECLARATION + (dolist (name (cdr declaration-specifier)) + (when (or (get name 'deftype-definition) + (find-class name nil)) + (declaration-error name)) + (setf (gethash name (the hash-table *declaration-types*)) name))) + (:explain + (dolist (spec (cdr declaration-specifier)) + (let ((val t) + (quality spec)) + (when (consp spec) + (setf quality (%car spec)) + (when (= (length spec) 2) + (setf val (%cadr spec)))) + (if val + (pushnew quality *explain*) + (setf *explain* (remove quality *explain*)))))))) + +(defun proclaim-type (type &rest names) + (dolist (name names) + (setf (get name 'proclaimed-type) type))) + +(defun proclaimed-type (name) + (get name 'proclaimed-type)) + +(declaim (type hash-table *proclaimed-ftypes*)) +(defconst *proclaimed-ftypes* (make-hash-table :test 'equal)) + +(declaim (inline proclaim-ftype-1)) +(defun proclaim-ftype-1 (ftype name) + (declare (optimize speed)) + (if (symbolp name) + (setf (get name 'proclaimed-ftype) ftype) + (setf (gethash name *proclaimed-ftypes*) ftype))) +(declaim (notinline proclaim-ftype-1)) + +(defun proclaim-ftype (ftype &rest names) + (declare (optimize speed)) + (declare (inline proclaim-ftype-1)) + (dolist (name names) + (proclaim-ftype-1 ftype name))) + +(defun proclaimed-ftype (name) + (if (symbolp name) + (get name 'proclaimed-ftype) + (gethash1 name *proclaimed-ftypes*))) + +(defun ftype-result-type (ftype) + (if (atom ftype) + '* + (let ((result-type (third ftype))) + (if result-type + result-type + '*)))) Added: branches/save-image/src/org/armedbear/lisp/profiler.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/profiler.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,137 @@ +;;; profiler.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: profiler.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:profiler) + +(export '(*hidden-functions*)) + +(require '#:clos) +(require '#:format) + +(defvar *type* nil) + +(defvar *granularity* 1 "Sampling interval (in milliseconds).") + +(defvar *hidden-functions* + '(funcall apply eval + sys::%eval sys::interactive-eval + tpl::repl tpl::top-level-loop)) + +(defstruct (profile-info + (:constructor make-profile-info (object count))) + object + count) + +;; Returns list of all symbols with non-zero call counts. +(defun list-called-objects () + (let ((result '())) + (dolist (pkg (list-all-packages)) + (dolist (sym (sys:package-symbols pkg)) + (unless (memq sym *hidden-functions*) + (when (fboundp sym) + (let* ((definition (fdefinition sym)) + (count (sys:call-count definition))) + (unless (zerop count) + (cond ((typep definition 'generic-function) + (push (make-profile-info definition count) result) + (dolist (method (mop::generic-function-methods definition)) + (setf count (sys:call-count (sys:%method-function method))) + (unless (zerop count) + (push (make-profile-info method count) result)))) + (t + (push (make-profile-info sym count) result))))))))) + (remove-duplicates result :key 'profile-info-object :test 'eq))) + +(defun object-name (object) + (cond ((symbolp object) + object) + ((typep object 'generic-function) + (sys:%generic-function-name object)) + ((typep object 'method) + (list 'METHOD + (sys:%generic-function-name (sys:%method-generic-function object)) + (sys:%method-specializers object))))) + +(defun object-compiled-function-p (object) + (cond ((symbolp object) + (compiled-function-p (fdefinition object))) + ((typep object 'method) + (compiled-function-p (sys:%method-function object))) + (t + (compiled-function-p object)))) + +(defun show-call-count (info max-count) + (let* ((object (profile-info-object info)) + (count (profile-info-count info))) + (if max-count + (format t "~5,1F ~8D ~S~A~%" + (/ (* count 100.0) max-count) + count + (object-name object) + (if (object-compiled-function-p object) + "" + " [interpreted function]")) + (format t "~8D ~S~A~%" + count + (object-name object) + (if (object-compiled-function-p object) + "" + " [interpreted function]"))))) + +(defun show-call-counts () + (let ((list (list-called-objects))) + (setf list (sort list #'< :key 'profile-info-count)) + (let ((max-count nil)) + (when (eq *type* :time) + (let ((last-info (car (last list)))) + (setf max-count (if last-info + (profile-info-count last-info) + nil)) + (when (eql max-count 0) + (setf max-count nil)))) + (dolist (info list) + (show-call-count info max-count)))) + (values)) + +(defun start-profiler (&key type) + "Starts the profiler. + :TYPE may be either :TIME (statistical sampling) or :COUNT-ONLY (exact call + counts)." + (unless type + (setf type :time)) + (unless (memq type '(:time :count-only)) + (error ":TYPE must be :TIME or :COUNT-ONLY")) + (setf *type* type) + (%start-profiler type *granularity*)) + +(defmacro with-profiling ((&key type) &body body) + `(unwind-protect (progn (start-profiler :type ,type) , at body) + (stop-profiler))) Added: branches/save-image/src/org/armedbear/lisp/prog.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/prog.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,52 @@ +;;; prog.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: prog.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From GCL. + +(in-package "COMMON-LISP") + +(defmacro prog (vl &rest body &aux (decl nil)) + (do () + ((or (endp body) + (not (consp (car body))) + (not (eq (caar body) 'declare))) + `(block nil (let ,vl , at decl (tagbody , at body)))) + (push (car body) decl) + (pop body))) + +(defmacro prog* (vl &rest body &aux (decl nil)) + (do () + ((or (endp body) + (not (consp (car body))) + (not (eq (caar body) 'declare))) + `(block nil (let* ,vl , at decl (tagbody , at body)))) + (push (car body) decl) + (pop body))) Added: branches/save-image/src/org/armedbear/lisp/psetf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/psetf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,62 @@ +;;; psetf.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: psetf.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From CMUCL. + +(in-package #:system) + +(require '#:collect) + +(defmacro psetf (&rest args &environment env) + "This is to SETF as PSETQ is to SETQ. Args are alternating place + expressions and values to go into those places. All of the subforms and + values are determined, left to right, and only then are the locations + updated. Returns NIL." + (collect ((let*-bindings) (mv-bindings) (setters)) + (do ((a args (cddr a))) + ((endp a)) + (when (endp (cdr a)) + (error 'simple-program-error + :format-control "Odd number of arguments to PSETF.")) + (multiple-value-bind + (dummies vals newval setter getter) + (get-setf-expansion (macroexpand-1 (car a) env) env) + (declare (ignore getter)) + (let*-bindings (mapcar #'list dummies vals)) + (mv-bindings (list newval (cadr a))) + (setters setter))) + (labels ((thunk (let*-bindings mv-bindings) + (if let*-bindings + `(let* ,(car let*-bindings) + (multiple-value-bind ,@(car mv-bindings) + ,(thunk (cdr let*-bindings) (cdr mv-bindings)))) + `(progn ,@(setters) nil)))) + (thunk (let*-bindings) (mv-bindings))))) Added: branches/save-image/src/org/armedbear/lisp/query.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/query.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,71 @@ +;;; query.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: query.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package "SYSTEM") + +(defun query-readline () + (force-output *query-io*) + (string-trim '(#\space #\tab) (read-line *query-io*))) + +(defun y-or-n-p (&optional format-string &rest arguments) + (when format-string + (fresh-line *query-io*) + (apply #'format *query-io* format-string arguments)) + (loop + (let* ((line (query-readline)) + (ans (if (string= line "") + #\? ;Force CASE below to issue instruction. + (schar line 0)))) + (unless (whitespacep ans) + (case ans + ((#\y #\Y) (return t)) + ((#\n #\N) (return nil)) + (t + (write-line "Type \"y\" for yes or \"n\" for no. " *query-io*) + (when format-string + (apply #'format *query-io* format-string arguments)) + (force-output *query-io*))))))) + +(defun yes-or-no-p (&optional format-string &rest arguments) + (clear-input *query-io*) + (when format-string + (fresh-line *query-io*) + (apply #'format *query-io* format-string arguments)) + (do ((ans (query-readline) (query-readline))) + (()) + (cond ((string-equal ans "YES") (return t)) + ((string-equal ans "NO") (return nil)) + (t + (write-line "Type \"yes\" for yes or \"no\" for no. " *query-io*) + (when format-string + (apply #'format *query-io* format-string arguments)))))) Added: branches/save-image/src/org/armedbear/lisp/read-conditional.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/read-conditional.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,49 @@ +;;; read-conditional.lisp +;;; +;;; Copyright (C) 2005-2007 Peter Graves +;;; $Id: read-conditional.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun read-feature (stream) + (let* ((*package* +keyword-package+) + (*read-suppress* nil)) + (if (featurep (read stream t nil t)) + #\+ #\-))) + +(defun read-conditional (stream subchar int) + (declare (ignore int)) + (if (eql subchar (read-feature stream)) + (read stream t nil t) + (let ((*read-suppress* t)) + (read stream t nil t) + (values)))) + +(set-dispatch-macro-character #\# #\+ #'read-conditional +standard-readtable+) +(set-dispatch-macro-character #\# #\- #'read-conditional +standard-readtable+) Added: branches/save-image/src/org/armedbear/lisp/read-from-string.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/read-from-string.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,36 @@ +;;; read-from-string.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: read-from-string.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun read-from-string (string &optional (eof-error-p t) eof-value + &key (start 0) end preserve-whitespace) + (sys::%read-from-string string eof-error-p eof-value start end preserve-whitespace)) Added: branches/save-image/src/org/armedbear/lisp/read-sequence.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/read-sequence.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +;;; read-sequence.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: read-sequence.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun read-sequence (sequence stream &key (start 0) end) + (declare (type stream stream)) + (require-type start '(integer 0)) + (if end + (require-type end '(integer 0)) + (setf end (length sequence))) + (let* ((element-type (stream-element-type stream))) + (cond ((eq element-type 'character) + (do ((pos start (1+ pos))) + ((>= pos end) pos) + (let ((element (read-char stream nil :eof))) + (when (eq element :eof) + (return pos)) + (setf (elt sequence pos) element)))) + ((equal element-type '(unsigned-byte 8)) + (if (and (vectorp sequence) + (equal (array-element-type sequence) '(unsigned-byte 8))) + (read-vector-unsigned-byte-8 sequence stream start end) + (do ((pos start (1+ pos))) + ((>= pos end) pos) + (let ((element (read-8-bits stream nil :eof))) + (when (eq element :eof) + (return pos)) + (setf (elt sequence pos) element))))) + (t + (do ((pos start (1+ pos))) + ((>= pos end) pos) + (let ((element (read-byte stream nil :eof))) + (when (eq element :eof) + (return pos)) + (setf (elt sequence pos) element))))))) Added: branches/save-image/src/org/armedbear/lisp/reduce.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/reduce.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,83 @@ +;;; reduce.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: reduce.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from OpenMCL. + +(in-package #:system) + +(defmacro list-reduce (function sequence start end initial-value ivp key) + (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) + `(let ((sequence (nthcdr ,start ,sequence))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value ,what) + (funcall ,function value ,what))) + ((= count ,end) value))))) + + +(defmacro list-reduce-from-end (function sequence start end + initial-value ivp key) + (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) + `(let ((sequence (nthcdr (- (length ,sequence) ,end) (reverse ,sequence)))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value ,what) + (funcall ,function ,what value))) + ((= count ,end) value))))) + + +(defun reduce (function sequence &key from-end (start 0) + end (initial-value nil ivp) key) + (unless end (setq end (length sequence))) + (if (= end start) + (if ivp initial-value (funcall function)) + (if (listp sequence) + (if from-end + (list-reduce-from-end function sequence start end initial-value ivp key) + (list-reduce function sequence start end initial-value ivp key)) + (let* ((disp (if from-end -1 1)) + (index (if from-end (1- end) start)) + (terminus (if from-end (1- start) end)) + (value (if ivp initial-value + (let ((elt (aref sequence index))) + (setf index (+ index disp)) + (if key (funcall key elt) elt)))) + (element nil)) + (do* () + ((= index terminus) value) + (setf element (aref sequence index) + index (+ index disp) + element (if key (funcall key element) element) + value (funcall function + (if from-end element value) + (if from-end value element)))))))) Added: branches/save-image/src/org/armedbear/lisp/rem.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/rem.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * rem.java + * + * Copyright (C) 2004 Peter Graves + * $Id: rem.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### rem number divisor => remainder +public final class rem extends Primitive +{ + private rem() + { + super("rem", "number divisor"); + } + + @Override + public LispObject execute(LispObject number, LispObject divisor) + throws ConditionThrowable + { + number.truncate(divisor); + final LispThread thread = LispThread.currentThread(); + LispObject remainder = thread._values[1]; + thread.clearValues(); + return remainder; + } + + private static final Primitive REM = new rem(); +} Added: branches/save-image/src/org/armedbear/lisp/remf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/remf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +;;; remf.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: remf.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(defmacro remf (place indicator &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered to + remove the property specified by the indicator. Returns T if such a + property was present, NIL if not." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) + ;; See ANSI 5.1.3 for why we do out-of-order evaluation + (push (list ind-temp indicator) let-list) + (push (list (car newval) getter) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((eq (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) + (push (list (car d) (car v)) let-list)))) Added: branches/save-image/src/org/armedbear/lisp/remove-duplicates.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/remove-duplicates.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,112 @@ +;;; remove-duplicates.lisp +;;; +;;; Copyright (C) 2003-2004 Peter Graves +;;; $Id: remove-duplicates.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; Adapted from CMUCL. + +(defun list-remove-duplicates (list test test-not start end key from-end) + (let* ((result (list ())) + (splice result) + (current list)) + (do ((index 0 (1+ index))) + ((= index start)) + (setq splice (cdr (rplacd splice (list (car current))))) + (setq current (cdr current))) + (do ((index start (1+ index))) + ((or (and end (= index end)) + (atom current))) + (if (or (and from-end + (not (member (apply-key key (car current)) + (nthcdr (1+ start) result) + :test test + :test-not test-not + :key key))) + (and (not from-end) + (not (do ((it (apply-key key (car current))) + (l (cdr current) (cdr l)) + (i (1+ index) (1+ i))) + ((or (atom l) (and end (= i end))) + ()) + (if (if test-not + (not (funcall test-not it (apply-key key (car l)))) + (funcall test it (apply-key key (car l)))) + (return t)))))) + (setq splice (cdr (rplacd splice (list (car current)))))) + (setq current (cdr current))) + (do () + ((atom current)) + (setq splice (cdr (rplacd splice (list (car current))))) + (setq current (cdr current))) + (cdr result))) + +(defun vector-remove-duplicates (vector test test-not start end key from-end + &optional (length (length vector))) + (when (null end) (setf end (length vector))) + (let ((result (make-sequence-like vector length)) + (index 0) + (jndex start)) + (do () + ((= index start)) + (setf (aref result index) (aref vector index)) + (setq index (1+ index))) + (do ((elt)) + ((= index end)) + (setq elt (aref vector index)) + (unless (or (and from-end + (position (apply-key key elt) result :start start + :end jndex :test test :test-not test-not :key key)) + (and (not from-end) + (position (apply-key key elt) vector :start (1+ index) + :end end :test test :test-not test-not :key key))) + (setf (aref result jndex) elt) + (setq jndex (1+ jndex))) + (setq index (1+ index))) + (do () + ((= index length)) + (setf (aref result jndex) (aref vector index)) + (setq index (1+ index)) + (setq jndex (1+ jndex))) + (shrink-vector result jndex))) + +(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end + end key) + (if (listp sequence) + (when sequence + (if (and (eq test #'eql) + (null test-not) + (eql start 0) + (null from-end) + (null end) + (null key)) + (simple-list-remove-duplicates sequence) + (list-remove-duplicates sequence test test-not start end key from-end))) + (vector-remove-duplicates sequence test test-not start end key from-end))) Added: branches/save-image/src/org/armedbear/lisp/remove.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/remove.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,193 @@ +;;; remove.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: remove.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(resolve 'delete) ; MUMBLE-DELETE-FROM-END + +;;; From CMUCL. + +(defmacro real-count (count) + `(cond ((null ,count) most-positive-fixnum) + ((fixnump ,count) (if (minusp ,count) 0 ,count)) + ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum)) + (t ,count))) + +(defmacro mumble-remove-macro (bump left begin finish right pred) + `(do ((index ,begin (,bump index)) + (result + (do ((index ,left (,bump index)) + (result (make-sequence-like sequence length))) + ((= index ,begin) result) + (aset result index (aref sequence index)))) + (new-index ,begin) + (number-zapped 0) + (this-element)) + ((or (= index ,finish) (= number-zapped count)) + (do ((index index (,bump index)) + (new-index new-index (,bump new-index))) + ((= index ,right) (shrink-vector result new-index)) + (aset result new-index (aref sequence index)))) + (setq this-element (aref sequence index)) + (cond (,pred (setq number-zapped (1+ number-zapped))) + (t (aset result new-index this-element) + (setq new-index (,bump new-index)))))) + +(defmacro mumble-remove (pred) + `(mumble-remove-macro 1+ 0 start end length ,pred)) + +(defmacro mumble-remove-from-end (pred) + `(let ((sequence (copy-seq sequence))) + (mumble-delete-from-end ,pred))) + +(defmacro normal-mumble-remove () + `(mumble-remove + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro normal-mumble-remove-from-end () + `(mumble-remove-from-end + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro if-mumble-remove () + `(mumble-remove (funcall predicate (apply-key key this-element)))) + +(defmacro if-mumble-remove-from-end () + `(mumble-remove-from-end (funcall predicate (apply-key key this-element)))) + +(defmacro if-not-mumble-remove () + `(mumble-remove (not (funcall predicate (apply-key key this-element))))) + +(defmacro if-not-mumble-remove-from-end () + `(mumble-remove-from-end + (not (funcall predicate (apply-key key this-element))))) + +(defmacro list-remove-macro (pred reverse-p) + `(let* ((sequence ,(if reverse-p + '(reverse sequence) + 'sequence)) + (%start ,(if reverse-p '(- length end) 'start)) + (%end ,(if reverse-p '(- length start) 'end)) + (splice (list nil)) + (results (do ((index 0 (1+ index)) + (before-start splice)) + ((= index %start) before-start) + (setq splice + (cdr (rplacd splice (list (pop sequence)))))))) + (do ((index %start (1+ index)) + (this-element) + (number-zapped 0)) + ((or (= index %end) (= number-zapped count)) + (do ((index index (1+ index))) + ((null sequence) + ,(if reverse-p + '(nreverse (cdr results)) + '(cdr results))) + (setq splice (cdr (rplacd splice (list (pop sequence))))))) + (setq this-element (pop sequence)) + (if ,pred + (setq number-zapped (1+ number-zapped)) + (setq splice (cdr (rplacd splice (list this-element)))))))) + + +(defmacro list-remove (pred) + `(list-remove-macro ,pred nil)) + +(defmacro list-remove-from-end (pred) + `(list-remove-macro ,pred t)) + +(defmacro normal-list-remove () + `(list-remove + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro normal-list-remove-from-end () + `(list-remove-from-end + (if test-not + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) + +(defmacro if-list-remove () + `(list-remove + (funcall predicate (apply-key key this-element)))) + +(defmacro if-list-remove-from-end () + `(list-remove-from-end + (funcall predicate (apply-key key this-element)))) + +(defmacro if-not-list-remove () + `(list-remove + (not (funcall predicate (apply-key key this-element))))) + +(defmacro if-not-list-remove-from-end () + `(list-remove-from-end + (not (funcall predicate (apply-key key this-element))))) + +(defun remove (item sequence &key from-end (test #'eql) test-not (start 0) + end count key) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (if (listp sequence) + (if from-end + (normal-list-remove-from-end) + (normal-list-remove)) + (if from-end + (normal-mumble-remove-from-end) + (normal-mumble-remove))))) + +(defun remove-if (predicate sequence &key from-end (start 0) end count key) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (if (listp sequence) + (if from-end + (if-list-remove-from-end) + (if-list-remove)) + (if from-end + (if-mumble-remove-from-end) + (if-mumble-remove))))) + +(defun remove-if-not (predicate sequence &key from-end (start 0) end count key) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (if (listp sequence) + (if from-end + (if-not-list-remove-from-end) + (if-not-list-remove)) + (if from-end + (if-not-mumble-remove-from-end) + (if-not-mumble-remove))))) Added: branches/save-image/src/org/armedbear/lisp/replace.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/replace.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,169 @@ +;;; replace.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: replace.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package #:system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro seq-dispatch (sequence list-form array-form) + `(if (listp ,sequence) + ,list-form + ,array-form))) + +(eval-when (:compile-toplevel :execute) + + ;;; If we are copying around in the same vector, be careful not to copy the + ;;; same elements over repeatedly. We do this by copying backwards. + (defmacro mumble-replace-from-mumble () + `(if (and (eq target-sequence source-sequence) (> target-start source-start)) + (let ((nelts (min (- target-end target-start) (- source-end source-start)))) + (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1) + (1- target-index)) + (source-index (+ (the fixnum source-start) (the fixnum nelts) -1) + (1- source-index))) + ((= target-index (the fixnum (1- target-start))) target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end))) + target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) + (aref source-sequence source-index))))) + + (defmacro list-replace-from-list () + `(if (and (eq target-sequence source-sequence) (> target-start source-start)) + (let ((new-elts (subseq source-sequence source-start + (+ (the fixnum source-start) + (the fixnum + (min (- (the fixnum target-end) + (the fixnum target-start)) + (- (the fixnum source-end) + (the fixnum source-start)))))))) + (do ((n new-elts (cdr n)) + (o (nthcdr target-start target-sequence) (cdr o))) + ((null n) target-sequence) + (rplaca o (car n)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref)) + (source-sequence-ref (nthcdr source-start source-sequence) + (cdr source-sequence-ref))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null target-sequence-ref) (null source-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (car source-sequence-ref))))) + + (defmacro list-replace-from-mumble () + `(do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null target-sequence-ref)) + target-sequence) + (declare (fixnum source-index target-index)) + (rplaca target-sequence-ref (aref source-sequence source-index)))) + + (defmacro mumble-replace-from-list () + `(do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (source-sequence (nthcdr source-start source-sequence) + (cdr source-sequence))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null source-sequence)) + target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) (car source-sequence)))) + + ) ; eval-when + +;;; The support routines for REPLACE are used by compiler transforms, so we +;;; worry about dealing with end being supplied as or defaulting to nil +;;; at this level. + +(defun list-replace-from-list* (target-sequence source-sequence target-start + target-end source-start source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (list-replace-from-list)) + +(defun list-replace-from-vector* (target-sequence source-sequence target-start + target-end source-start source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (list-replace-from-mumble)) + +(defun vector-replace-from-list* (target-sequence source-sequence target-start + target-end source-start source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (mumble-replace-from-list)) + +(defun vector-replace-from-vector* (target-sequence source-sequence + target-start target-end source-start + source-end) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (mumble-replace-from-mumble)) + +(defun %replace (target-sequence source-sequence target-start target-end source-start source-end) + (declare (type (integer 0 #.most-positive-fixnum) target-start target-end source-start source-end)) + (seq-dispatch target-sequence + (seq-dispatch source-sequence + (list-replace-from-list) + (list-replace-from-mumble)) + (seq-dispatch source-sequence + (mumble-replace-from-list) + (mumble-replace-from-mumble)))) + +;;; REPLACE cannot default end arguments to the length of sequence since it +;;; is not an error to supply nil for their values. We must test for ends +;;; being nil in the body of the function. +(defun replace (target-sequence source-sequence &key + ((:start1 target-start) 0) + ((:end1 target-end)) + ((:start2 source-start) 0) + ((:end2 source-end))) + "The target sequence is destructively modified by copying successive +elements into it from the source sequence." + (let ((target-end (or target-end (length target-sequence))) + (source-end (or source-end (length source-sequence)))) + (%replace target-sequence source-sequence target-start target-end source-start source-end))) Added: branches/save-image/src/org/armedbear/lisp/require.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/require.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,49 @@ +;;; require.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: require.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; PROVIDE, REQUIRE (from SBCL) +(defun provide (module-name) + (pushnew (string module-name) *modules* :test #'string=) + t) + +(defun require (module-name &optional pathnames) + (unless (member (string module-name) *modules* :test #'string=) + (let ((saved-modules (copy-list *modules*))) + (cond (pathnames + (unless (listp pathnames) (setf pathnames (list pathnames))) + (dolist (x pathnames) + (load x))) + (t + (let ((*readtable* (copy-readtable nil))) + (load-system-file (string-downcase (string module-name)))))) + (set-difference *modules* saved-modules)))) Added: branches/save-image/src/org/armedbear/lisp/restart.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/restart.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,322 @@ +;;; restart.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: restart.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL/SBCL. + +(in-package #:system) + +(defun read-evaluated-form () + (fresh-line *query-io*) + (%format *query-io* "Enter a form to be evaluated:~%") + (list (eval (read *query-io*)))) + +(defvar *restart-clusters* ()) + +(defvar *condition-restarts* ()) + +(defstruct restart + name + function + report-function + interactive-function + (test-function #'(lambda (c) t))) + +(defmacro restart-bind (bindings &body forms) + `(let ((*restart-clusters* + (cons (list + ,@(mapcar #'(lambda (binding) + `(make-restart + :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) + , at forms)) + +(defun compute-restarts (&optional condition) + (let ((associated ()) + (other ())) + (dolist (alist *condition-restarts*) + (if (eq (car alist) condition) + (setq associated (cdr alist)) + (setq other (append (cdr alist) other)))) + (let ((res ())) + (dolist (restart-cluster *restart-clusters*) + (dolist (restart restart-cluster) + (when (and (or (not condition) + (member restart associated) + (not (member restart other))) + (funcall (restart-test-function restart) condition)) + (push restart res)))) + (nreverse res)))) + +(defun restart-report (restart stream) + (funcall (or (restart-report-function restart) + (let ((name (restart-name restart))) + (lambda (stream) + (if name (%format stream "~S" name) + (%format stream "~S" restart))))) + stream)) + +(defun print-restart (restart stream) + (if *print-escape* + (print-unreadable-object (restart stream :type t :identity t) + (prin1 (restart-name restart) stream)) + (restart-report restart stream))) + +(defun find-restart (name &optional condition) + (let ((restarts (compute-restarts condition))) + (dolist (restart restarts) + (when (or (eq restart name) (eq (restart-name restart) name)) + (return-from find-restart restart))))) + +(defun find-restart-or-control-error (identifier &optional condition) + (or (find-restart identifier condition) + (error 'control-error + :format-control "Restart ~S is not active." + :format-arguments (list identifier)))) + +(defun invoke-restart (restart &rest values) + (let ((real-restart (find-restart-or-control-error restart))) + (apply (restart-function real-restart) values))) + +(defun interactive-restart-arguments (real-restart) + (let ((interactive-function (restart-interactive-function real-restart))) + (if interactive-function + (funcall interactive-function) + '()))) + +(defun invoke-restart-interactively (restart) + (let* ((real-restart (find-restart-or-control-error restart)) + (args (interactive-restart-arguments real-restart))) + (apply (restart-function real-restart) args))) + + +(defun parse-keyword-pairs (list keys) + (do ((l list (cddr l)) + (k '() (list* (cadr l) (car l) k))) + ((or (null l) (not (member (car l) keys))) + (values (nreverse k) l)))) + +(defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms) + (let ((temp (member '&rest names))) + (unless (= (length temp) 2) + (error "&REST keyword is ~:[missing~;misplaced~]." temp)) + (let ((key-vars (ldiff names temp)) + (key-var (or keywords-var (gensym))) + (rest-var (cadr temp))) + (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package "KEYWORD"))) + key-vars))) + `(multiple-value-bind (,key-var ,rest-var) + (parse-keyword-pairs ,expression ',keywords) + (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword))) + key-vars keywords) + , at forms)))))) + +(defun transform-keywords (&key report interactive test) + (let ((result ())) + (when report + (setf result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setf result (list* `#',interactive + :interactive-function + result))) + (when test + (setf result (list* `#',test :test-function result))) + (nreverse result))) + + +;; "If the restartable-form is a list whose car is any of the symbols SIGNAL, +;; ERROR, CERROR, or WARN (or is a macro form which macroexpands into such a +;; list), then WITH-CONDITION-RESTARTS is used implicitly to associate the +;; indicated restarts with the condition to be signaled." +(defun munge-restart-case-expression (expression) + (let ((exp (macroexpand expression))) + (if (consp exp) + (let* ((name (car exp)) + (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) + (if (member name '(SIGNAL ERROR CERROR WARN)) + (let ((n-cond (gensym))) + `(let ((,n-cond (coerce-to-condition ,(first args) + (list ,@(rest args)) + ',(case name + (WARN 'simple-warning) + (SIGNAL 'simple-condition) + (t 'simple-error)) + ',name))) + (with-condition-restarts + ,n-cond + (car *restart-clusters*) + ,(if (eq name 'cerror) + `(cerror ,(second exp) ,n-cond) + `(,name ,n-cond))))) + expression)) + expression))) + +(defmacro restart-case (expression &body clauses) + (let ((block-tag (gensym)) + (temp-var (gensym)) + (data + (mapcar #'(lambda (clause) + (with-keyword-pairs ((report interactive test + &rest forms) + (cddr clause)) + (list (car clause) + (gensym) + (transform-keywords :report report + :interactive interactive + :test test) + (cadr clause) + forms))) + clauses))) + `(block ,block-tag + (let ((,temp-var nil)) + (tagbody + (restart-bind + ,(mapcar #'(lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setq ,temp-var temp) + (go ,tag)) + , at keys))) + data) + (return-from ,block-tag ,(munge-restart-case-expression expression))) + ,@(mapcan #'(lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply #'(lambda ,bvl , at body) + ,temp-var))))) + data)))))) + +(defmacro with-simple-restart ((restart-name format-string + &rest format-arguments) + &body forms) + `(restart-case (progn , at forms) + (,restart-name () + :report (lambda (stream) + (simple-format stream ,format-string , at format-arguments)) + (values nil t)))) + +(defmacro with-condition-restarts (condition-form restarts-form &body body) + (let ((n-cond (gensym))) + `(let ((*condition-restarts* + (cons (let ((,n-cond ,condition-form)) + (cons ,n-cond + (append ,restarts-form + (cdr (assoc ,n-cond *condition-restarts*))))) + *condition-restarts*))) + , at body))) + +(defun abort (&optional condition) + (invoke-restart (find-restart-or-control-error 'abort condition)) + (error 'control-error + :format-control "ABORT restart failed to transfer control dynamically.")) + +(defun muffle-warning (&optional condition) + (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) + +(defun continue (&optional condition) + (let ((restart (find-restart 'continue condition))) + (when restart + (invoke-restart restart)))) + +(defun store-value (value &optional condition) + (let ((restart (find-restart 'store-value condition))) + (when restart + (invoke-restart restart value)))) + +(defun use-value (value &optional condition) + (let ((restart (find-restart 'use-value condition))) + (when restart + (invoke-restart restart value)))) + +(defun warn (datum &rest arguments) + (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn))) + (require-type condition 'warning) + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (let ((badness (etypecase condition + (style-warning 'style-warning) + (warning 'warning)))) + (fresh-line *error-output*) + (simple-format *error-output* "~S: ~A~%" badness condition))) + nil) + +(defun style-warn (format-control &rest format-arguments) + (warn 'style-warning + :format-control format-control + :format-arguments format-arguments)) + +(defun cerror (continue-string datum &rest arguments) + (with-simple-restart (continue "~A" (apply #'simple-format nil continue-string arguments)) + (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) + (with-condition-restarts condition (list (find-restart 'continue)) + (signal condition) + (invoke-debugger condition)))) + nil) + +(defun query-function () + (format *query-io* "~&Enter a form to be evaluated: ") + (force-output *query-io*) + (multiple-value-list (eval (read *query-io*)))) + +(defun undefined-function-called (name arguments) + (finish-output) + (loop + (restart-case + (error 'undefined-function :name name) + (continue () + :report "Try again.") + (use-value (value) + :report "Specify a function to call instead." + :interactive query-function + (return-from undefined-function-called + (apply value arguments))) + (return-value (&rest values) + :report (lambda (stream) + (format stream "Return one or more values from the call to ~S." name)) + :interactive query-function + (return-from undefined-function-called + (values-list values)))) + (when (fboundp name) + (return (apply name arguments))))) Added: branches/save-image/src/org/armedbear/lisp/revappend.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/revappend.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,37 @@ +;;; revappend.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: revappend.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun revappend (x y) + (do ((top x (cdr top)) + (result y (cons (car top) result))) + ((endp top) result))) Added: branches/save-image/src/org/armedbear/lisp/room.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/room.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,88 @@ +/* + * room.java + * + * Copyright (C) 2003-2005 Peter Graves + * $Id: room.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### room +public final class room extends Primitive +{ + private room() + { + super("room", "&optional x"); + } + + @Override + public LispObject execute(LispObject[] args) throws ConditionThrowable + { + if (args.length > 1) + return error(new WrongNumberOfArgumentsException(this)); + Runtime runtime = Runtime.getRuntime(); + long total = 0; + long free = 0; + long maxFree = 0; + while (true) { + try { + runtime.gc(); + Thread.sleep(100); + runtime.runFinalization(); + Thread.sleep(100); + runtime.gc(); + Thread.sleep(100); + } + catch (InterruptedException e) {} + total = runtime.totalMemory(); + free = runtime.freeMemory(); + if (free > maxFree) + maxFree = free; + else + break; + } + long used = total - free; + Stream out = getStandardOutput(); + StringBuffer sb = new StringBuffer("Total memory "); + sb.append(total); + sb.append(" bytes"); + sb.append(System.getProperty("line.separator")); + sb.append(used); + sb.append(" bytes used"); + sb.append(System.getProperty("line.separator")); + sb.append(free); + sb.append(" bytes free"); + sb.append(System.getProperty("line.separator")); + out._writeString(sb.toString()); + out._finishOutput(); + return number(used); + } + + private static final Primitive ROOM = new room(); +} Added: branches/save-image/src/org/armedbear/lisp/rotatef.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/rotatef.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +;;; rotatef.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: rotatef.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(eval-when (:compile-toplevel) + (require '#:collect)) + +(defmacro rotatef (&rest args &environment env) + (when args + (collect ((let*-bindings) (mv-bindings) (setters) (getters)) + (dolist (arg args) + (multiple-value-bind (temps subforms store-vars setter getter) + (get-setf-expansion arg env) + (loop + for temp in temps + for subform in subforms + do (let*-bindings `(,temp ,subform))) + (mv-bindings store-vars) + (setters setter) + (getters getter))) + (setters nil) + (getters (car (getters))) + (labels ((thunk (mv-bindings getters) + (if mv-bindings + `((multiple-value-bind ,(car mv-bindings) ,(car getters) + ,@(thunk (cdr mv-bindings) (cdr getters)))) + (setters)))) + `(let* ,(let*-bindings) + ,@(thunk (mv-bindings) (cdr (getters)))))))) Added: branches/save-image/src/org/armedbear/lisp/rt.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/rt.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,547 @@ +;;; rt.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: rt.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from rt.lsp and ansi-aux.lsp in the GCL ANSI test suite. + +#+abcl (require '#:jvm) + +(defpackage :regression-test (:use :cl) (:nicknames #-lispworks :rt)) + +(in-package :regression-test) + +(export '(deftest my-aref)) + +(defvar *prefix* + #-(or windows mswindows) "/home/peter/gcl/ansi-tests/" + #+(or windows mswindows) "C:\\cygwin\\home\\peter\\gcl\\ansi-tests\\") + +(defvar *compile-tests* t) + +(defvar *passed* 0) +(defvar *failed* 0) + +(defun my-aref (a &rest args) + (apply #'aref a args)) + +(defun my-row-major-aref (a index) + (row-major-aref a index)) + +(defun equalp-with-case (x y) + (cond + ((eq x y) t) + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + ((typep x 'pathname) + (equal x y)) + (t (eql x y)))) + +(defmacro deftest (name &rest body) + (fresh-line) + (format t "Test ~S~%" `,name) + (finish-output) + (let* ((p body) + (properties + (loop while (keywordp (first p)) + unless (cadr p) + do (error "Poorly formed deftest: ~S~%" + (list* 'deftest name body)) + append (list (pop p) (pop p)))) + (form (pop p)) + (values p)) + (declare (ignore properties)) + (let* ((aborted nil) + (r (handler-case (multiple-value-list + (cond (*compile-tests* + (funcall (compile nil `(lambda () ,form)))) + (t + (eval `,form)))) + (error (c) (setf aborted t) (list c)))) + (passed (and (not aborted) (equalp-with-case r `,values)))) + (unless passed + (let ((*print-pretty* t)) + (format t "Form: ~S~%" `,form) + (format t "Expected value: ~S~%" + (if (= (length `,values) 1) + (car `,values) + `,values)) + (let ((r (if (= (length r) 1) (car r) r))) + (format t "Actual value: ~S" r) + (when (typep r 'condition) + (format t " [\"~A\"]" r)) + (terpri)) + (finish-output))) + (if passed (incf *passed*) (incf *failed*))))) + +(in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (intern "==>" "CL-USER")) + +(defvar *compiled-and-loaded-files* nil) + +(defun compile-and-load (filename &key force) + (let* ((pathname (concatenate 'string regression-test::*prefix* filename)) + (former-data (assoc pathname *compiled-and-loaded-files* + :test #'equalp)) + (compile-pathname (compile-file-pathname pathname)) + (source-write-time (file-write-date pathname)) + (target-write-time (and (probe-file compile-pathname) + (file-write-date compile-pathname)))) + (unless (and (not force) + former-data + (>= (cadr former-data) source-write-time)) + (when (or (not target-write-time) + (<= target-write-time source-write-time)) + (compile-file pathname)) + (if former-data + (setf (cadr former-data) source-write-time) + (push (list pathname source-write-time) *compiled-and-loaded-files*)) + (load compile-pathname)))) + +(defpackage :cl-test + (:use :cl :regression-test) + (:nicknames) + (:shadow #:handler-case #:handler-bind) + (:import-from "COMMON-LISP-USER" #:compile-and-load "==>") + (:export #:random-from-seq #:random-case #:coin #:random-permute)) + +(defun do-tests (&rest args) + (let ((*compile-print* nil) + (regression-test::*passed* 0) + (regression-test::*failed* 0) + (*default-pathname-defaults* (pathname regression-test::*prefix*)) + (suffix ".lsp") + (tests (or args '("abs" + "acons" + "adjoin" + "and" + "append" + "apply" + "aref" + "array" + "array-as-class" + "array-dimension" + "array-dimensions" + "array-displacement" + "array-in-bounds-p" + "array-misc" + "array-rank" + "array-row-major-index" + "array-t" + "array-total-size" + "arrayp" + "ash" + "assoc" + "assoc-if" + "assoc-if-not" + "atom" + "bit" + "bit-and" + "bit-andc1" + "bit-andc2" + "bit-eqv" + "bit-ior" + "bit-nand" + "bit-nor" + "bit-not" + "bit-orc1" + "bit-orc2" + "bit-vector" + "bit-vector-p" + "bit-xor" + "block" + "boole" + "boundp" + "butlast" + "byte" + "call-arguments-limit" + "case" + "catch" + "ccase" + "ceiling" + "cell-error-name" + "char-compare" + "char-schar" + "character" + "cl-symbols" + "coerce" + "complement" + "complex" + "complexp" + "concatenate" + "cond" + "condition" + "conjugate" + "cons" + "cons-test-01" + "cons-test-03" + "cons-test-05" + "consp" + "constantly" + "constantp" + "copy-alist" + "copy-list" + "copy-seq" + "copy-symbol" + "copy-tree" + "count" + "count-if" + "count-if-not" + "ctypecase" + "cxr" + "defconstant" + "define-modify-macro" + "defmacro" + "defparameter" + "defun" + "defvar" + "destructuring-bind" + "divide" + "dpb" + "ecase" + "elt" + "endp" + "epsilons" + "eql" + "equal" + "equalp" + "error" + "etypecase" + "eval" + "evenp" + "every" + "expt" + "fboundp" + "fceiling" + "fdefinition" + "ffloor" + "fill" + "fill-pointer" + "fill-strings" + "find" + "find-if" + "find-if-not" + "flet" + "float" + "floatp" + "floor" + "fmakunbound" + "fround" + "ftruncate" + "funcall" + "function" + "function-lambda-expression" + "functionp" + "gcd" + "gensym" + "get-properties" + "getf" + "handler-bind" + "handler-case" + "hash-table" + "identity" + "if" + "ignore-errors" + "imagpart" + "integer-length" + "integerp" + "intersection" + "invoke-debugger" + "isqrt" + "iteration" + "keywordp" + "labels" + "lambda" + "lambda-list-keywords" + "lambda-parameters-limit" + "last" + "lcm" + "ldb" + "ldiff" + "length" + "let" + "list" + "list-length" + "listp" + "load-structures" + "logand" + "logandc1" + "logandc2" + "logbitp" + "logeqv" + "logior" + "lognor" + "lognot" + "logorc1" + "logorc2" + "logxor" + "loop" + "loop1" + "loop2" + "loop3" + "loop4" + "loop5" + "loop6" + "loop7" + "loop8" + "loop9" + "loop10" + "loop11" + "loop12" + "loop13" + "loop14" + "loop15" + "loop16" + "loop17" + "make-array" + "make-list" + "make-sequence" + "make-string" + "make-symbol" + "map" + "map-into" + "mapc" + "mapcan" + "mapcar" + "mapcon" + "mapl" + "maplist" + "max" + "member" + "member-if" + "member-if-not" + "merge" + "min" + "minus" + "minusp" + "mismatch" + "multiple-value-bind" + "multiple-value-call" + "multiple-value-list" + "multiple-value-prog1" + "multiple-value-setq" + "nbutlast" + "nconc" + "nil" + "nintersection" + "not-and-null" + "notany" + "notevery" + "nreconc" + "nreverse" + "nset-difference" + "nset-exclusive-or" + "nstring-capitalize" + "nstring-downcase" + "nstring-upcase" + "nsublis" + "nsubst" + "nsubst-if" + "nsubst-if-not" + "nsubstitute" + "nsubstitute-if" + "nsubstitute-if-not" + "nth" + "nth-value" + "nthcdr" + "number-comparison" + "numerator-denominator" + "nunion" + "oddp" + "oneminus" + "oneplus" + "or" + "load-packages" + "pairlis" + "parse-integer" + "phase" + "places" + "plus" + "plusp" + "pop" + "position" + "position-if" + "position-if-not" + "prog" + "prog1" + "prog2" + "progn" + "progv" + "psetf" + "psetq" + "push" + "pushnew" + "random" + "rassoc" + "rassoc-if" + "rassoc-if-not" + "rational" + "rationalize" + "rationalp" + "realp" + "realpart" + "reduce" + "remf" + "remove" + "remove-duplicates" + "replace" + "rest" + "return" + "revappend" + "reverse" + "rotatef" + "round" + "row-major-aref" + "rplaca" + "rplacd" + "sbit" + "search-bitvector" + "search-list" + "search-string" + "search-vector" + "set-difference" + "set-exclusive-or" + "shiftf" + "signum" + "simple-array" + "simple-array-t" + "simple-bit-vector" + "simple-bit-vector-p" + "simple-vector-p" + "some" + "sort" + "special-operator-p" + "string" + "string-capitalize" + "string-comparisons" + "string-downcase" + "string-left-trim" + "string-right-trim" + "string-trim" + "string-upcase" + "sublis" + "subseq" + "subsetp" + "subst" + "subst-if" + "subst-if-not" + "substitute" + "substitute-if" + "substitute-if-not" + "subtypep" + "subtypep-cons" + "subtypep-eql" + "subtypep-float" + "subtypep-integer" + "subtypep-member" + "subtypep-rational" + "subtypep-real" + "svref" + "symbol-name" + "t" + "tagbody" + "tailp" + "times" + "tree-equal" + "truncate" + "typecase" + "union" + "unless" + "unwind-protect" + "values" + "values-list" + "vector" + "vector-pop" + "vector-push" + "vector-push-extend" + "vectorp" + "when" + "zerop")))) + (dolist (test tests) + (load (concatenate 'string regression-test::*prefix* test suffix))) + (format t "~A tests: ~A passed, ~A failed~%" + (+ regression-test::*passed* regression-test::*failed*) + regression-test::*passed* + regression-test::*failed*) + (format t "*compile-tests* was ~A~%" regression-test::*compile-tests*)) + (values)) + +(defun do-all-tests (&optional (compile-tests t)) + (let ((regression-test::*compile-tests* compile-tests)) + (time (do-tests)))) + +(compile-and-load "ansi-aux-macros.lsp") +(load (concatenate 'string regression-test::*prefix* "universe.lsp")) +(compile-and-load "random-aux.lsp") +(compile-and-load "ansi-aux.lsp") + +(compile-and-load "char-aux.lsp") +(load (concatenate 'string regression-test::*prefix* "cl-symbols-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "cl-symbol-names.lsp")) +(load (concatenate 'string regression-test::*prefix* "array-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "subseq-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "cons-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "numbers-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "string-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "remove-aux.lsp")) +(load (concatenate 'string regression-test::*prefix* "remove-duplicates-aux.lsp")) + +#+armedbear +(when (and (fboundp 'jvm::jvm-compile) (not (autoloadp 'jvm::jvm-compile))) + (mapcar #'jvm::jvm-compile '(regression-test::equalp-with-case + cl-test::make-scaffold-copy + cl-test::check-scaffold-copy + cl-test::is-intersection))) Added: branches/save-image/src/org/armedbear/lisp/run-benchmarks.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/run-benchmarks.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,217 @@ +;; Driver for Eric Marsden's CL-BENCH Lisp performance benchmarks. + +(in-package :cl-user) + +#+armedbear +(require 'pprint) + +#+allegro +(progn + (setq excl:*record-source-file-info* nil) + (setq excl:*load-source-file-info* nil) + (setq excl:*record-xref-info* nil) + (setq excl:*load-xref-info* nil)) + +(setf *default-pathname-defaults* #p"/home/peter/cl-bench/") + +(load #p"defpackage.lisp") +(compile-file #p"files/arrays.olisp") +(compile-file #p"files/bignum.olisp") +(compile-file #p"files/boehm-gc.olisp") +(compile-file #p"files/clos.olisp") +(compile-file #p"files/crc40.olisp") +(compile-file #p"files/deflate.olisp") +(compile-file #p"files/gabriel.olisp") +(compile-file #p"files/hash.olisp") +(compile-file #p"files/math.olisp") +(compile-file #p"files/ratios.olisp") +(compile-file #p"files/richards.olisp") +(compile-file #p"files/misc.olisp") + +(load (compile-file-pathname #p"files/arrays.olisp")) +(load (compile-file-pathname #p"files/bignum.olisp")) +(load (compile-file-pathname #p"files/boehm-gc.olisp")) +(load (compile-file-pathname #p"files/clos.olisp")) +(load (compile-file-pathname #p"files/crc40.olisp")) +(load (compile-file-pathname #p"files/deflate.olisp")) +(load (compile-file-pathname #p"files/gabriel.olisp")) +(load (compile-file-pathname #p"files/hash.olisp")) +(load (compile-file-pathname #p"files/math.olisp")) +(load (compile-file-pathname #p"files/ratios.olisp")) +(load (compile-file-pathname #p"files/richards.olisp")) +(load (compile-file-pathname #p"files/misc.olisp")) +(compile-file #p"support.lisp") +(load (compile-file-pathname #p"support.lisp")) + +(in-package :cl-bench) + +(export '(run-benchmark run-benchmarks)) + +(setf *benchmark-output* t) + +#+(or armedbear clisp) +(defun bench-gc () + (ext:gc)) + +#+sbcl +(defun bench-gc () + (sb-ext:gc #+gencgc :full #+gencgc t)) + +#+allegro +(defun bench-gc () + (excl:gc)) + +(defun report-filename () + (let ((impl "")) + #+allegro (setf impl "-allegro") + #+armedbear (setf impl "-armedbear") + #+clisp (setf impl "-clisp") + #+sbcl (setf impl "-sbcl") + (multiple-value-bind (sec min hour day month year) + (get-decoded-time) + (format nil "~abenchmark-~d~2,'0d~2,'0dT~2,'0d~2,'0d~a" + #+win32 "" #-win32 "/var/tmp/" + year month day hour min impl)))) + +(defun run-benchmark (function &optional args (times 1)) + (let ((name (symbol-name function))) + (format t "Running benchmark ~A" (symbol-name function)) + (when (> times 1) + (format t " (~D runs)" times)) + (terpri) + (force-output) + (let (before-real after-real before-user after-user) + (setf before-real (get-internal-real-time)) + (setf before-user (get-internal-run-time)) + (dotimes (i times) + (apply function args)) + (setf after-user (get-internal-run-time)) + (setf after-real (get-internal-real-time)) + (let ((real (/ (- after-real before-real) internal-time-units-per-second)) + (user (/ (- after-user before-user) internal-time-units-per-second))) + (format *benchmark-output* + ";; ~25a ~8,2f ~8,2f~%" + name real user) + (format *trace-output* + ";; ~25a ~8,2f ~8,2f~%" + name real user)) + (force-output *benchmark-output*))) + (bench-gc) + (values)) + +(defun run-benchmarks () + (with-open-file (f (report-filename) + :direction :output + :if-exists :supersede) + (let ((*benchmark-output* f)) + (format *benchmark-output* "~A ~A " + (lisp-implementation-type) (lisp-implementation-version)) + (multiple-value-bind (second minute hour date month year) + (get-decoded-time) + (format *benchmark-output* "~d-~2,'0d-~2,'0d ~2,'0d:~2,'0d~%" + year month date hour minute)) + (format *benchmark-output* "~a~%" (short-site-name)) + (force-output *benchmark-output*) + (bench-gc) + ;; The benchmarks. + #+nil + (run-benchmark 'cl-bench.misc:run-compiler nil 3) + #+nil + (run-benchmark 'cl-bench.misc:run-fasload nil 20) + #-allegro + (run-benchmark 'cl-bench.misc:run-permutations nil 2) + #+nil + (progn + (cl-bench.misc::setup-walk-list/seq) + (run-benchmark 'cl-bench.misc:walk-list/seq) + (setf cl-bench.misc::*big-seq-list* nil) + (bench-gc)) + #+nil + (progn + (cl-bench.misc::setup-walk-list/mess) + (run-benchmark 'cl-bench.misc:walk-list/mess) + (setf cl-bench.misc::*big-mess-list* nil) + (bench-gc)) + (run-benchmark 'cl-bench.gabriel:boyer nil 30) + (run-benchmark 'cl-bench.gabriel:browse nil 10) + (run-benchmark 'cl-bench.gabriel:dderiv-run nil 50) + (run-benchmark 'cl-bench.gabriel:deriv-run nil 60) + (run-benchmark 'cl-bench.gabriel:run-destructive nil 100) + (run-benchmark 'cl-bench.gabriel:run-div2-test1 nil 200) + (run-benchmark 'cl-bench.gabriel:run-div2-test2 nil 200) + (run-benchmark 'cl-bench.gabriel:run-fft nil 30) + (run-benchmark 'cl-bench.gabriel:run-frpoly/fixnum nil 100) + (run-benchmark 'cl-bench.gabriel:run-frpoly/bignum nil 30) + (run-benchmark 'cl-bench.gabriel:run-frpoly/float nil 100) + (run-benchmark 'cl-bench.gabriel:run-puzzle nil 1500) + (run-benchmark 'cl-bench.gabriel:run-tak) + (run-benchmark 'cl-bench.gabriel:run-ctak) + (run-benchmark 'cl-bench.gabriel:run-trtak) + (run-benchmark 'cl-bench.gabriel:run-takl) + #+nil + (run-benchmark 'cl-bench.gabriel:run-stak) + (run-benchmark 'cl-bench.gabriel:fprint/ugly nil 200) + (run-benchmark 'cl-bench.gabriel:fprint/pretty) + (run-benchmark 'cl-bench.gabriel:run-traverse) + (run-benchmark 'cl-bench.gabriel:run-triangle) + (run-benchmark 'cl-bench.richards:richards) + (run-benchmark 'cl-bench.math:run-factorial nil 1000) + (run-benchmark 'cl-bench.math:run-fib nil 50) + (run-benchmark 'cl-bench.math:run-fib-ratio) + #+nil + (run-benchmark 'cl-bench.math:run-ackermann) + (run-benchmark 'cl-bench.math:run-mandelbrot/complex) + (run-benchmark 'cl-bench.math:run-mandelbrot/dfloat) + (run-benchmark 'cl-bench.math:run-mrg32k3a) + (run-benchmark 'cl-bench.crc:run-crc40) + (run-benchmark 'cl-bench.bignum:run-elem-100-1000) + (run-benchmark 'cl-bench.bignum:run-elem-1000-100) + (run-benchmark 'cl-bench.bignum:run-elem-10000-1) + (run-benchmark 'cl-bench.bignum:run-pari-100-10) + (run-benchmark 'cl-bench.bignum:run-pari-200-5) + (run-benchmark 'cl-bench.bignum:run-pi-decimal/small) + #-allegro + (run-benchmark 'cl-bench.bignum:run-pi-decimal/big) + (run-benchmark 'cl-bench.bignum:run-pi-atan) + (run-benchmark 'cl-bench.ratios:run-pi-ratios) + #-clisp + (run-benchmark 'cl-bench.hash:run-slurp-lines nil 30) + #-allegro + (run-benchmark 'cl-bench.hash:hash-strings nil 2) + (run-benchmark 'cl-bench.hash:hash-integers nil 10) + #-allegro + (run-benchmark 'cl-bench.boehm-gc:gc-benchmark) + (run-benchmark 'cl-bench.deflate:run-deflate-file nil 100) + #-allegro + (run-benchmark 'cl-bench.arrays:bench-1d-arrays) + #-allegro + (run-benchmark 'cl-bench.arrays:bench-2d-arrays '(1000 1)) + #-allegro + (run-benchmark 'cl-bench.arrays:bench-3d-arrays '(100 1)) + (run-benchmark 'cl-bench.arrays:bench-bitvectors nil 3) + #-allegro + (run-benchmark 'cl-bench.arrays:bench-strings) + #-allegro + (run-benchmark 'cl-bench.arrays:bench-strings/adjustable '(1000000 1)) + #-(or allegro clisp) + (run-benchmark 'cl-bench.arrays:bench-string-concat '(1000000 1)) + #-allegro + (run-benchmark 'cl-bench.arrays:bench-search-sequence '(1000000 1)) + (return-from run-benchmarks) + (run-benchmark 'cl-bench.clos:run-defclass) + (run-benchmark 'cl-bench.clos:run-defmethod) + (run-benchmark 'cl-bench.clos:make-instances) + (run-benchmark 'cl-bench.clos:make-instances/simple) + (run-benchmark 'cl-bench.clos:methodcalls/simple) + (run-benchmark 'cl-bench.clos:methodcalls/simple+after) + #-clisp + (run-benchmark 'cl-bench.clos:methodcalls/complex) + #+nil + (run-benchmark 'cl-bench.clos:run-eql-fib) + (run-benchmark 'cl-bench.clos::eql-fib '(16))))) + +(in-package "CL-USER") + +(import '(cl-bench:run-benchmark cl-bench:run-benchmarks)) + +(export '(run-benchmark run-benchmarks)) Added: branches/save-image/src/org/armedbear/lisp/run-shell-command.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/run-shell-command.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,35 @@ +;;; run-shell-command.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: run-shell-command.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun run-shell-command (command &key directory (output *standard-output*)) + (%run-shell-command command directory output)) Added: branches/save-image/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/runtime-class.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,663 @@ +;;; runtime-class.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: runtime-class.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package :java) + +(require :format) + +;; jparse generated definitions, somewhat simplified + +(defclass java-class nil ((java-instance :initarg :java-instance :reader java-instance))) +(defclass jboolean (java-class) nil) +(defmethod initialize-instance :after ((b jboolean) &key &allow-other-keys) + (setf (slot-value b 'java-instance) (make-immediate-object (java-instance b) :boolean))) +(defclass jarray (java-class) nil) +(defclass |java.lang.Object| (java-class) nil) +(defclass output-stream (java-class) nil) +(defclass file-output-stream (output-stream java-class) nil) +(defclass class-visitor (java-class) nil) +(defclass class-writer (class-visitor java-class) nil) +(defclass code-visitor (java-class) nil) +(defclass code-writer (code-visitor java-class) nil) +(defclass attribute (java-class) nil) +(defclass constants (java-class) nil) +(defclass label (java-class) nil) +(defmethod make-file-output-stream-1 ((v1 string)) + (make-instance 'file-output-stream :java-instance + (jnew (jconstructor "java.io.FileOutputStream" "java.lang.String") v1))) +(defmethod write-1 ((instance file-output-stream) (v1 jarray)) + (jcall (jmethod "java.io.FileOutputStream" "write" "[B") (java-instance instance) (java-instance v1))) +(defmethod close-0 ((instance file-output-stream)) + (jcall (jmethod "java.io.FileOutputStream" "close") (java-instance instance))) +(defmethod make-class-writer-1 ((v1 jboolean)) + (make-instance 'class-writer :java-instance + (jnew (jconstructor "org.objectweb.asm.ClassWriter" "boolean") (java-instance v1)))) +(defmethod visit-end-0 ((instance class-writer)) + (jcall (jmethod "org.objectweb.asm.ClassWriter" "visitEnd") (java-instance instance))) +(defmethod to-byte-array-0 ((instance class-writer)) + (make-instance 'jarray :java-instance + (jcall (jmethod "org.objectweb.asm.ClassWriter" "toByteArray") (java-instance instance)))) +(defmethod visit-insn-1 ((instance code-visitor) (v1 fixnum)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitInsn" "int") (java-instance instance) v1)) +(defmethod visit-int-insn-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitIntInsn" "int" "int") (java-instance instance) v1 + v2)) +(defmethod visit-var-insn-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitVarInsn" "int" "int") (java-instance instance) v1 + v2)) +(defmethod visit-type-insn-2 ((instance code-visitor) (v1 fixnum) (v2 string)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitTypeInsn" "int" "java.lang.String") + (java-instance instance) v1 v2)) +(defmethod visit-field-insn-4 ((instance code-visitor) (v1 fixnum) (v2 string) (v3 string) (v4 string)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitFieldInsn" "int" "java.lang.String" + "java.lang.String" "java.lang.String") + (java-instance instance) v1 v2 v3 v4)) +(defmethod visit-method-insn-4 ((instance code-visitor) (v1 fixnum) (v2 string) (v3 string) (v4 string)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitMethodInsn" "int" "java.lang.String" + "java.lang.String" "java.lang.String") + (java-instance instance) v1 v2 v3 v4)) +(defmethod visit-jump-insn-2 ((instance code-visitor) (v1 fixnum) (v2 label)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitJumpInsn" "int" "org.objectweb.asm.Label") + (java-instance instance) v1 (java-instance v2))) +(defmethod visit-label-1 ((instance code-visitor) (v1 label)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitLabel" "org.objectweb.asm.Label") + (java-instance instance) (java-instance v1))) +(defmethod visit-ldc-insn-1 ((instance code-visitor) (v1 |java.lang.Object|)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitLdcInsn" "java.lang.Object") + (java-instance instance) (java-instance v1))) +(defmethod visit-try-catch-block-4 ((instance code-visitor) (v1 label) (v2 label) (v3 label) (v4 string)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitTryCatchBlock" "org.objectweb.asm.Label" + "org.objectweb.asm.Label" "org.objectweb.asm.Label" "java.lang.String") + (java-instance instance) (java-instance v1) (java-instance v2) (java-instance v3) v4)) +(defmethod visit-maxs-2 ((instance code-visitor) (v1 fixnum) (v2 fixnum)) + (jcall (jmethod "org.objectweb.asm.CodeVisitor" "visitMaxs" "int" "int") (java-instance instance) v1 v2)) +(defconstant constants.ifnonnull (jfield "org.objectweb.asm.Constants" "IFNONNULL")) +(defconstant constants.ifnull (jfield "org.objectweb.asm.Constants" "IFNULL")) +(defconstant constants.multianewarray (jfield "org.objectweb.asm.Constants" "MULTIANEWARRAY")) +(defconstant constants.monitorexit (jfield "org.objectweb.asm.Constants" "MONITOREXIT")) +(defconstant constants.monitorenter (jfield "org.objectweb.asm.Constants" "MONITORENTER")) +(defconstant constants.instanceof (jfield "org.objectweb.asm.Constants" "INSTANCEOF")) +(defconstant constants.checkcast (jfield "org.objectweb.asm.Constants" "CHECKCAST")) +(defconstant constants.athrow (jfield "org.objectweb.asm.Constants" "ATHROW")) +(defconstant constants.arraylength (jfield "org.objectweb.asm.Constants" "ARRAYLENGTH")) +(defconstant constants.anewarray (jfield "org.objectweb.asm.Constants" "ANEWARRAY")) +(defconstant constants.newarray (jfield "org.objectweb.asm.Constants" "NEWARRAY")) +(defconstant constants.new (jfield "org.objectweb.asm.Constants" "NEW")) +(defconstant constants.invokeinterface (jfield "org.objectweb.asm.Constants" "INVOKEINTERFACE")) +(defconstant constants.invokestatic (jfield "org.objectweb.asm.Constants" "INVOKESTATIC")) +(defconstant constants.invokespecial (jfield "org.objectweb.asm.Constants" "INVOKESPECIAL")) +(defconstant constants.invokevirtual (jfield "org.objectweb.asm.Constants" "INVOKEVIRTUAL")) +(defconstant constants.putfield (jfield "org.objectweb.asm.Constants" "PUTFIELD")) +(defconstant constants.getfield (jfield "org.objectweb.asm.Constants" "GETFIELD")) +(defconstant constants.putstatic (jfield "org.objectweb.asm.Constants" "PUTSTATIC")) +(defconstant constants.getstatic (jfield "org.objectweb.asm.Constants" "GETSTATIC")) +(defconstant constants.return (jfield "org.objectweb.asm.Constants" "RETURN")) +(defconstant constants.areturn (jfield "org.objectweb.asm.Constants" "ARETURN")) +(defconstant constants.dreturn (jfield "org.objectweb.asm.Constants" "DRETURN")) +(defconstant constants.freturn (jfield "org.objectweb.asm.Constants" "FRETURN")) +(defconstant constants.lreturn (jfield "org.objectweb.asm.Constants" "LRETURN")) +(defconstant constants.ireturn (jfield "org.objectweb.asm.Constants" "IRETURN")) +(defconstant constants.lookupswitch (jfield "org.objectweb.asm.Constants" "LOOKUPSWITCH")) +(defconstant constants.tableswitch (jfield "org.objectweb.asm.Constants" "TABLESWITCH")) +(defconstant constants.ret (jfield "org.objectweb.asm.Constants" "RET")) +(defconstant constants.jsr (jfield "org.objectweb.asm.Constants" "JSR")) +(defconstant constants.goto (jfield "org.objectweb.asm.Constants" "GOTO")) +(defconstant constants.if-acmpne (jfield "org.objectweb.asm.Constants" "IF_ACMPNE")) +(defconstant constants.if-acmpeq (jfield "org.objectweb.asm.Constants" "IF_ACMPEQ")) +(defconstant constants.if-icmple (jfield "org.objectweb.asm.Constants" "IF_ICMPLE")) +(defconstant constants.if-icmpgt (jfield "org.objectweb.asm.Constants" "IF_ICMPGT")) +(defconstant constants.if-icmpge (jfield "org.objectweb.asm.Constants" "IF_ICMPGE")) +(defconstant constants.if-icmplt (jfield "org.objectweb.asm.Constants" "IF_ICMPLT")) +(defconstant constants.if-icmpne (jfield "org.objectweb.asm.Constants" "IF_ICMPNE")) +(defconstant constants.if-icmpeq (jfield "org.objectweb.asm.Constants" "IF_ICMPEQ")) +(defconstant constants.ifle (jfield "org.objectweb.asm.Constants" "IFLE")) +(defconstant constants.ifgt (jfield "org.objectweb.asm.Constants" "IFGT")) +(defconstant constants.ifge (jfield "org.objectweb.asm.Constants" "IFGE")) +(defconstant constants.iflt (jfield "org.objectweb.asm.Constants" "IFLT")) +(defconstant constants.ifne (jfield "org.objectweb.asm.Constants" "IFNE")) +(defconstant constants.ifeq (jfield "org.objectweb.asm.Constants" "IFEQ")) +(defconstant constants.dcmpg (jfield "org.objectweb.asm.Constants" "DCMPG")) +(defconstant constants.dcmpl (jfield "org.objectweb.asm.Constants" "DCMPL")) +(defconstant constants.fcmpg (jfield "org.objectweb.asm.Constants" "FCMPG")) +(defconstant constants.fcmpl (jfield "org.objectweb.asm.Constants" "FCMPL")) +(defconstant constants.lcmp (jfield "org.objectweb.asm.Constants" "LCMP")) +(defconstant constants.i2s (jfield "org.objectweb.asm.Constants" "I2S")) +(defconstant constants.i2c (jfield "org.objectweb.asm.Constants" "I2C")) +(defconstant constants.i2b (jfield "org.objectweb.asm.Constants" "I2B")) +(defconstant constants.d2f (jfield "org.objectweb.asm.Constants" "D2F")) +(defconstant constants.d2l (jfield "org.objectweb.asm.Constants" "D2L")) +(defconstant constants.d2i (jfield "org.objectweb.asm.Constants" "D2I")) +(defconstant constants.f2d (jfield "org.objectweb.asm.Constants" "F2D")) +(defconstant constants.f2l (jfield "org.objectweb.asm.Constants" "F2L")) +(defconstant constants.f2i (jfield "org.objectweb.asm.Constants" "F2I")) +(defconstant constants.l2d (jfield "org.objectweb.asm.Constants" "L2D")) +(defconstant constants.l2f (jfield "org.objectweb.asm.Constants" "L2F")) +(defconstant constants.l2i (jfield "org.objectweb.asm.Constants" "L2I")) +(defconstant constants.i2d (jfield "org.objectweb.asm.Constants" "I2D")) +(defconstant constants.i2f (jfield "org.objectweb.asm.Constants" "I2F")) +(defconstant constants.i2l (jfield "org.objectweb.asm.Constants" "I2L")) +(defconstant constants.iinc (jfield "org.objectweb.asm.Constants" "IINC")) +(defconstant constants.lxor (jfield "org.objectweb.asm.Constants" "LXOR")) +(defconstant constants.ixor (jfield "org.objectweb.asm.Constants" "IXOR")) +(defconstant constants.lor (jfield "org.objectweb.asm.Constants" "LOR")) +(defconstant constants.ior (jfield "org.objectweb.asm.Constants" "IOR")) +(defconstant constants.land (jfield "org.objectweb.asm.Constants" "LAND")) +(defconstant constants.iand (jfield "org.objectweb.asm.Constants" "IAND")) +(defconstant constants.lushr (jfield "org.objectweb.asm.Constants" "LUSHR")) +(defconstant constants.iushr (jfield "org.objectweb.asm.Constants" "IUSHR")) +(defconstant constants.lshr (jfield "org.objectweb.asm.Constants" "LSHR")) +(defconstant constants.ishr (jfield "org.objectweb.asm.Constants" "ISHR")) +(defconstant constants.lshl (jfield "org.objectweb.asm.Constants" "LSHL")) +(defconstant constants.ishl (jfield "org.objectweb.asm.Constants" "ISHL")) +(defconstant constants.dneg (jfield "org.objectweb.asm.Constants" "DNEG")) +(defconstant constants.fneg (jfield "org.objectweb.asm.Constants" "FNEG")) +(defconstant constants.lneg (jfield "org.objectweb.asm.Constants" "LNEG")) +(defconstant constants.ineg (jfield "org.objectweb.asm.Constants" "INEG")) +(defconstant constants.drem (jfield "org.objectweb.asm.Constants" "DREM")) +(defconstant constants.frem (jfield "org.objectweb.asm.Constants" "FREM")) +(defconstant constants.lrem (jfield "org.objectweb.asm.Constants" "LREM")) +(defconstant constants.irem (jfield "org.objectweb.asm.Constants" "IREM")) +(defconstant constants.ddiv (jfield "org.objectweb.asm.Constants" "DDIV")) +(defconstant constants.fdiv (jfield "org.objectweb.asm.Constants" "FDIV")) +(defconstant constants.ldiv (jfield "org.objectweb.asm.Constants" "LDIV")) +(defconstant constants.idiv (jfield "org.objectweb.asm.Constants" "IDIV")) +(defconstant constants.dmul (jfield "org.objectweb.asm.Constants" "DMUL")) +(defconstant constants.fmul (jfield "org.objectweb.asm.Constants" "FMUL")) +(defconstant constants.lmul (jfield "org.objectweb.asm.Constants" "LMUL")) +(defconstant constants.imul (jfield "org.objectweb.asm.Constants" "IMUL")) +(defconstant constants.dsub (jfield "org.objectweb.asm.Constants" "DSUB")) +(defconstant constants.fsub (jfield "org.objectweb.asm.Constants" "FSUB")) +(defconstant constants.lsub (jfield "org.objectweb.asm.Constants" "LSUB")) +(defconstant constants.isub (jfield "org.objectweb.asm.Constants" "ISUB")) +(defconstant constants.dadd (jfield "org.objectweb.asm.Constants" "DADD")) +(defconstant constants.fadd (jfield "org.objectweb.asm.Constants" "FADD")) +(defconstant constants.ladd (jfield "org.objectweb.asm.Constants" "LADD")) +(defconstant constants.iadd (jfield "org.objectweb.asm.Constants" "IADD")) +(defconstant constants.swap (jfield "org.objectweb.asm.Constants" "SWAP")) +(defconstant constants.dup2_x2 (jfield "org.objectweb.asm.Constants" "DUP2_X2")) +(defconstant constants.dup2_x1 (jfield "org.objectweb.asm.Constants" "DUP2_X1")) +(defconstant constants.dup2 (jfield "org.objectweb.asm.Constants" "DUP2")) +(defconstant constants.dup_x2 (jfield "org.objectweb.asm.Constants" "DUP_X2")) +(defconstant constants.dup_x1 (jfield "org.objectweb.asm.Constants" "DUP_X1")) +(defconstant constants.dup (jfield "org.objectweb.asm.Constants" "DUP")) +(defconstant constants.pop2 (jfield "org.objectweb.asm.Constants" "POP2")) +(defconstant constants.pop (jfield "org.objectweb.asm.Constants" "POP")) +(defconstant constants.sastore (jfield "org.objectweb.asm.Constants" "SASTORE")) +(defconstant constants.castore (jfield "org.objectweb.asm.Constants" "CASTORE")) +(defconstant constants.bastore (jfield "org.objectweb.asm.Constants" "BASTORE")) +(defconstant constants.aastore (jfield "org.objectweb.asm.Constants" "AASTORE")) +(defconstant constants.dastore (jfield "org.objectweb.asm.Constants" "DASTORE")) +(defconstant constants.fastore (jfield "org.objectweb.asm.Constants" "FASTORE")) +(defconstant constants.lastore (jfield "org.objectweb.asm.Constants" "LASTORE")) +(defconstant constants.iastore (jfield "org.objectweb.asm.Constants" "IASTORE")) +(defconstant constants.astore (jfield "org.objectweb.asm.Constants" "ASTORE")) +(defconstant constants.dstore (jfield "org.objectweb.asm.Constants" "DSTORE")) +(defconstant constants.fstore (jfield "org.objectweb.asm.Constants" "FSTORE")) +(defconstant constants.lstore (jfield "org.objectweb.asm.Constants" "LSTORE")) +(defconstant constants.istore (jfield "org.objectweb.asm.Constants" "ISTORE")) +(defconstant constants.saload (jfield "org.objectweb.asm.Constants" "SALOAD")) +(defconstant constants.caload (jfield "org.objectweb.asm.Constants" "CALOAD")) +(defconstant constants.baload (jfield "org.objectweb.asm.Constants" "BALOAD")) +(defconstant constants.aaload (jfield "org.objectweb.asm.Constants" "AALOAD")) +(defconstant constants.daload (jfield "org.objectweb.asm.Constants" "DALOAD")) +(defconstant constants.faload (jfield "org.objectweb.asm.Constants" "FALOAD")) +(defconstant constants.laload (jfield "org.objectweb.asm.Constants" "LALOAD")) +(defconstant constants.iaload (jfield "org.objectweb.asm.Constants" "IALOAD")) +(defconstant constants.aload (jfield "org.objectweb.asm.Constants" "ALOAD")) +(defconstant constants.dload (jfield "org.objectweb.asm.Constants" "DLOAD")) +(defconstant constants.fload (jfield "org.objectweb.asm.Constants" "FLOAD")) +(defconstant constants.lload (jfield "org.objectweb.asm.Constants" "LLOAD")) +(defconstant constants.iload (jfield "org.objectweb.asm.Constants" "ILOAD")) +(defconstant constants.ldc (jfield "org.objectweb.asm.Constants" "LDC")) +(defconstant constants.sipush (jfield "org.objectweb.asm.Constants" "SIPUSH")) +(defconstant constants.bipush (jfield "org.objectweb.asm.Constants" "BIPUSH")) +(defconstant constants.dconst_1 (jfield "org.objectweb.asm.Constants" "DCONST_1")) +(defconstant constants.dconst_0 (jfield "org.objectweb.asm.Constants" "DCONST_0")) +(defconstant constants.fconst_2 (jfield "org.objectweb.asm.Constants" "FCONST_2")) +(defconstant constants.fconst_1 (jfield "org.objectweb.asm.Constants" "FCONST_1")) +(defconstant constants.fconst_0 (jfield "org.objectweb.asm.Constants" "FCONST_0")) +(defconstant constants.lconst_1 (jfield "org.objectweb.asm.Constants" "LCONST_1")) +(defconstant constants.lconst_0 (jfield "org.objectweb.asm.Constants" "LCONST_0")) +(defconstant constants.iconst_5 (jfield "org.objectweb.asm.Constants" "ICONST_5")) +(defconstant constants.iconst_4 (jfield "org.objectweb.asm.Constants" "ICONST_4")) +(defconstant constants.iconst_3 (jfield "org.objectweb.asm.Constants" "ICONST_3")) +(defconstant constants.iconst_2 (jfield "org.objectweb.asm.Constants" "ICONST_2")) +(defconstant constants.iconst_1 (jfield "org.objectweb.asm.Constants" "ICONST_1")) +(defconstant constants.iconst_0 (jfield "org.objectweb.asm.Constants" "ICONST_0")) +(defconstant constants.iconst_m1 (jfield "org.objectweb.asm.Constants" "ICONST_M1")) +(defconstant constants.aconst-null (jfield "org.objectweb.asm.Constants" "ACONST_NULL")) +(defconstant constants.nop (jfield "org.objectweb.asm.Constants" "NOP")) +(defconstant constants.t-long (jfield "org.objectweb.asm.Constants" "T_LONG")) +(defconstant constants.t-int (jfield "org.objectweb.asm.Constants" "T_INT")) +(defconstant constants.t-short (jfield "org.objectweb.asm.Constants" "T_SHORT")) +(defconstant constants.t-byte (jfield "org.objectweb.asm.Constants" "T_BYTE")) +(defconstant constants.t-double (jfield "org.objectweb.asm.Constants" "T_DOUBLE")) +(defconstant constants.t-float (jfield "org.objectweb.asm.Constants" "T_FLOAT")) +(defconstant constants.t-char (jfield "org.objectweb.asm.Constants" "T_CHAR")) +(defconstant constants.t-boolean (jfield "org.objectweb.asm.Constants" "T_BOOLEAN")) +(defconstant constants.acc-deprecated (jfield "org.objectweb.asm.Constants" "ACC_DEPRECATED")) +(defconstant constants.acc-synthetic (jfield "org.objectweb.asm.Constants" "ACC_SYNTHETIC")) +(defconstant constants.acc-super (jfield "org.objectweb.asm.Constants" "ACC_SUPER")) +(defconstant constants.acc-strict (jfield "org.objectweb.asm.Constants" "ACC_STRICT")) +(defconstant constants.acc-abstract (jfield "org.objectweb.asm.Constants" "ACC_ABSTRACT")) +(defconstant constants.acc-interface (jfield "org.objectweb.asm.Constants" "ACC_INTERFACE")) +(defconstant constants.acc-enum (jfield "org.objectweb.asm.Constants" "ACC_ENUM")) +(defconstant constants.acc-native (jfield "org.objectweb.asm.Constants" "ACC_NATIVE")) +(defconstant constants.acc-transient (jfield "org.objectweb.asm.Constants" "ACC_TRANSIENT")) +(defconstant constants.acc-varargs (jfield "org.objectweb.asm.Constants" "ACC_VARARGS")) +(defconstant constants.acc-bridge (jfield "org.objectweb.asm.Constants" "ACC_BRIDGE")) +(defconstant constants.acc-volatile (jfield "org.objectweb.asm.Constants" "ACC_VOLATILE")) +(defconstant constants.acc-synchronized (jfield "org.objectweb.asm.Constants" "ACC_SYNCHRONIZED")) +(defconstant constants.acc-final (jfield "org.objectweb.asm.Constants" "ACC_FINAL")) +(defconstant constants.acc-static (jfield "org.objectweb.asm.Constants" "ACC_STATIC")) +(defconstant constants.acc-protected (jfield "org.objectweb.asm.Constants" "ACC_PROTECTED")) +(defconstant constants.acc-private (jfield "org.objectweb.asm.Constants" "ACC_PRIVATE")) +(defconstant constants.acc-public (jfield "org.objectweb.asm.Constants" "ACC_PUBLIC")) +(defconstant constants.v1-1 (jfield "org.objectweb.asm.Constants" "V1_1")) +(defmethod make-label-0 nil + (make-instance 'label :java-instance (jnew (jconstructor "org.objectweb.asm.Label")))) + +;;end of jparse generated definitions + + +(defmethod visit-4 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string) v4) + (jcall + (jmethod "org.objectweb.asm.ClassWriter" "visit" "int" "int" "java.lang.String" "java.lang.String" "[Ljava.lang.String;" "java.lang.String") + (java-instance instance) constants.v1-1 v1 v2 v3 v4 nil)) + +(defmethod visit-field-3 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string)) + (jcall + (jmethod "org.objectweb.asm.ClassWriter" "visitField" "int" "java.lang.String" "java.lang.String" "java.lang.Object" "org.objectweb.asm.Attribute") + (java-instance instance) v1 v2 v3 nil nil)) + +(defmethod visit-method-3 ((instance class-writer) (v1 fixnum) (v2 string) (v3 string)) + (make-instance 'code-visitor :java-instance + (jcall + (jmethod "org.objectweb.asm.ClassWriter" "visitMethod" "int" "java.lang.String" "java.lang.String" "[Ljava.lang.String;" "org.objectweb.asm.Attribute") + (java-instance instance) v1 v2 v3 nil nil))) + +(defun make-java-string (string) + (make-instance '|java.lang.Object| + :java-instance (jnew (jconstructor "java.lang.String" "[C") (jnew-array-from-array "char" string)))) + +(defparameter *primitive-types* + (acons + "void" (list "V" (list "" "" "") -1 constants.return -1) + (acons + "byte" + (list "B" (list "org/armedbear/lisp/Fixnum" "java/lang/Byte" "byteValue") + constants.iload constants.ireturn constants.iconst_0) + (acons + "short" + (list "S" (list "org/armedbear/lisp/Fixnum" "java/lang/Short" "shortValue") + constants.iload constants.ireturn constants.iconst_0) + (acons + "int" + (list "I" (list "org/armedbear/lisp/Fixnum" "java/lang/Integer" "intValue") + constants.iload constants.ireturn constants.iconst_0) + (acons + "long" + (list "J" (list "org/armedbear/lisp/Fixnum" "java/lang/Long" "longValue") + constants.lload constants.lreturn constants.lconst_0) + (acons + "float" + (list "F" (list "org/armedbear/lisp/SingleFloat" "java/lang/Float" "floatValue") + constants.fload constants.freturn constants.fconst_0) + (acons + "double" + (list "D" (list "org/armedbear/lisp/DoubleFloat" "java/lang/Double" "doubleValue") + constants.dload constants.dreturn constants.dconst_0) + (acons + "char" + (list "C" (list "org/armedbear/lisp/LispCharacter" "java/lang/Character" "charValue") + constants.iload constants.ireturn constants.iconst_0) + (acons + "boolean" + (list "Z" (list "org/armedbear/lisp/LispObject" "" "") + constants.iload constants.ireturn constants.iconst_0) + nil)))))))))) + +(defun primitive-type-p (type) + (assoc type *primitive-types* :test #'string=)) + +(defun type-name (type) + (let* ((dim (count #\[ type :test #'char=)) + (prefix (make-string dim :initial-element #\[)) + (base-type (string-right-trim "[ ]" type)) + (base-name (assoc base-type *primitive-types* :test #'string=))) + (concatenate 'string prefix + (if base-name (cadr base-name) + (substitute #\/ #\. + (if (zerop dim) base-type (decorate-type-name base-type))))))) + + +(defun decorate-type-name (type) + (if (char= (char type 0) #\[) type + (format nil "L~a;" type))) + +(defun decorated-type-name (type) + (let ((name (type-name type))) + (if (primitive-type-p type) name (decorate-type-name name)))) + +(defun arg-type-for-make-lisp-object (type) + (if (primitive-type-p type) + (decorated-type-name type) + "Ljava/lang/Object;")) + +(defun return-type-for-make-lisp-object (type) + (let ((name (assoc type *primitive-types* :test #'string=))) + (if name (caaddr name) "org/armedbear/lisp/LispObject"))) + +(defun cast-type (type) + (let ((name (assoc type *primitive-types* :test #'string=))) + (if name (cadr (caddr name)) (type-name type)))) + +(defun converter-for-primitive-return-type (type) + (assert (and (primitive-type-p type) + (not (or (string= type "void")(string= type "boolean"))))) + (caddr (caddr (assoc type *primitive-types* :test #'string=)))) + +(defun load-instruction (type) + (let ((name (assoc type *primitive-types* :test #'string=))) + (if name (cadddr name) constants.aload))) + +(defun return-instruction (type) + (let ((name (assoc type *primitive-types* :test #'string=))) + (if name (car (cddddr name)) constants.areturn))) + +(defun error-constant (type) + (let ((name (assoc type *primitive-types* :test #'string=))) + (if name (cadr (cddddr name)) constants.aconst-null))) + + +(defun size (type) + (if (or (string= type "long") (string= type "double")) 2 1)) + +(defun modifier (m) + (cond ((string= "public" m) constants.acc-public) + ((string= "protected" m) constants.acc-protected) + ((string= "private" m) constants.acc-private) + ((string= "static" m) constants.acc-static) + ((string= "abstract" m) constants.acc-abstract) + ((string= "final" m) constants.acc-final) + ((string= "transient" m) constants.acc-transient) + ((string= "volatile" m) constants.acc-volatile) + ((string= "synchronized" m) constants.acc-synchronized) + (t (error "Invalid modifier ~s." m)))) + + +(defun write-method + (class-writer class-name class-type-name method-name unique-method-name modifiers result-type arg-types &optional super-invocation) + + (let* ((args-size (reduce #'+ arg-types :key #'size)) + (index (+ 2 args-size)) + (cv (visit-method-3 + class-writer + (reduce #'+ modifiers :key #'modifier) + method-name + (format nil "(~{~a~})~a" + (mapcar #'decorated-type-name arg-types) (decorated-type-name result-type))))) + + (when super-invocation + (visit-var-insn-2 cv constants.aload 0) + (loop for arg-number in (cdr super-invocation) + with super-arg-types = (make-string-output-stream) + do + (visit-var-insn-2 cv + (load-instruction (nth (1- arg-number) arg-types)) + (reduce #'+ arg-types :end (1- arg-number) :key #'size :initial-value 1)) + (write-string (decorated-type-name (nth (1- arg-number) arg-types)) super-arg-types) + finally + (visit-method-insn-4 cv constants.invokespecial + (type-name (car super-invocation)) "" + (format nil "(~a)~a" + (get-output-stream-string super-arg-types) "V")))) + (visit-ldc-insn-1 cv (make-java-string class-name)) + (visit-method-insn-4 cv constants.invokestatic + "org/armedbear/lisp/RuntimeClass" + "getRuntimeClass" + "(Ljava/lang/String;)Lorg/armedbear/lisp/RuntimeClass;") + (visit-field-insn-4 cv constants.putstatic + class-type-name "rc" "Lorg/armedbear/lisp/RuntimeClass;") + (visit-field-insn-4 cv constants.getstatic + class-type-name "rc" "Lorg/armedbear/lisp/RuntimeClass;") + (visit-ldc-insn-1 cv (make-java-string unique-method-name)) + (visit-method-insn-4 cv constants.invokevirtual + "org/armedbear/lisp/RuntimeClass" + "getLispMethod" + "(Ljava/lang/String;)Lorg/armedbear/lisp/Function;") + (visit-var-insn-2 cv constants.astore (1+ args-size)) + (visit-field-insn-4 cv constants.getstatic + "org/armedbear/lisp/Lisp" "NIL" "Lorg/armedbear/lisp/LispObject;") + (visit-var-insn-2 cv constants.astore (+ 2 args-size)) + + + (let ((l0 (make-label-0))(l1 (make-label-0))(l2 (make-label-0))(l3 (make-label-0))) + (visit-label-1 cv l0) + + (visit-var-insn-2 cv constants.aload index) + (visit-var-insn-2 cv constants.aload 0) ; (visit-var-insn-2 cv constants.aload 0) + (visit-method-insn-4 cv constants.invokestatic + "org/armedbear/lisp/RuntimeClass" "makeLispObject" + (format nil "(~a)~a" + (arg-type-for-make-lisp-object "java.lang.Object") + (decorate-type-name (return-type-for-make-lisp-object "java.lang.Object")))) + (visit-method-insn-4 cv constants.invokevirtual + "org/armedbear/lisp/LispObject" + "push" + "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") + (visit-var-insn-2 cv constants.astore (+ 2 args-size)) + + (loop for arg-type in (reverse arg-types) and j = args-size then (- j (size arg-type)) + do + (visit-var-insn-2 cv constants.aload index) + + (visit-var-insn-2 cv (load-instruction arg-type) j) + (visit-method-insn-4 cv constants.invokestatic + "org/armedbear/lisp/RuntimeClass" "makeLispObject" + (format nil "(~a)~a" + (arg-type-for-make-lisp-object arg-type) + (decorate-type-name (return-type-for-make-lisp-object arg-type)))) + (visit-method-insn-4 cv constants.invokevirtual + "org/armedbear/lisp/LispObject" + "push" + "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") ;uj + (visit-var-insn-2 cv constants.astore (+ 2 args-size))) + + + (visit-var-insn-2 cv constants.aload (1- index)) + (visit-var-insn-2 cv constants.aload index) + + (visit-type-insn-2 cv constants.new "org/armedbear/lisp/Environment") + (visit-insn-1 cv constants.dup) + (visit-method-insn-4 cv constants.invokespecial "org/armedbear/lisp/Environment" "" "()V") + (visit-method-insn-4 cv constants.invokestatic + "org/armedbear/lisp/LispThread" + "currentThread" + "()Lorg/armedbear/lisp/LispThread;") + (visit-method-insn-4 cv constants.invokestatic + "org/armedbear/lisp/RuntimeClass" + "evalC" + "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;") + (cond + ((string= "void" result-type) + (visit-insn-1 cv constants.pop)) + ((string= "boolean" result-type) + (visit-method-insn-4 cv constants.invokevirtual + (return-type-for-make-lisp-object result-type) + "getBooleanValue" + (concatenate 'string "()" (type-name result-type)))) + ((primitive-type-p result-type) + (visit-method-insn-4 cv constants.invokevirtual + "org/armedbear/lisp/LispObject" + "javaInstance" + "()Ljava/lang/Object;") + (visit-type-insn-2 cv constants.checkcast (cast-type result-type)) + (visit-method-insn-4 cv constants.invokevirtual + (cast-type result-type) + (converter-for-primitive-return-type result-type) + (concatenate 'string "()" (type-name result-type)) + )) + (t + (visit-method-insn-4 cv constants.invokevirtual + "org/armedbear/lisp/LispObject" "javaInstance" "()Ljava/lang/Object;") + (visit-type-insn-2 cv constants.checkcast (cast-type result-type)))) + + + (visit-label-1 cv l1) + (if (string= "void" result-type) + (visit-jump-insn-2 cv constants.goto l3) + (visit-insn-1 cv (return-instruction result-type))) + (visit-label-1 cv l2) + (visit-var-insn-2 cv constants.astore (1+ index)) + (visit-var-insn-2 cv constants.aload (1+ index)) + (visit-method-insn-4 cv constants.invokevirtual + "org/armedbear/lisp/ConditionThrowable" "printStackTrace" "()V") + + (if (string= "void" result-type) + (progn (visit-insn-1 cv (return-instruction result-type))(visit-label-1 cv l3) ) + (visit-insn-1 cv (error-constant result-type))) + + (visit-insn-1 cv (return-instruction result-type)) + (visit-try-catch-block-4 cv l0 l1 l2 "org/armedbear/lisp/ConditionThrowable") + + (visit-maxs-2 cv 0 0)))) + + + +(defun jnew-runtime-class (class-name super-name interfaces constructors methods fields &optional filename) + "Creates and loads a Java class with methods calling Lisp closures + as given in METHODS. CLASS-NAME and SUPER-NAME are strings, + INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are + lists of constructor, method and field definitions. + + Constructor definitions are lists of the form + (argument-types function &optional super-invocation-arguments) + where argument-types is a list of strings and function is a lisp function of + (1+ (length argument-types)) arguments; the instance (`this') is passed in as + the last argument. The optional super-invocation-arguments is a list of numbers + between 1 and (length argument-types), where the number k stands for the kth argument + to the just defined constructor. If present, the constructor of the superclass + will be called with the appropriate arguments. E.g., if the constructor definition is + ((\"java.lang.String\" \"int\") #'(lambda (string i this) ...) (2 1)) + then the constructor of the superclass with argument types (int, java.lang.String) will + be called with the second and first arguments. + + Method definitions are lists of the form + (method-name return-type argument-types function modifier*) + where method-name and return-type are strings, argument-types is a list of strings and function + is a lisp function of (1+ (length argument-types)) arguments; the instance (`this') is + passed in as the last argument. + + Field definitions are lists of the form + (field-name type modifier*) + + If FILE-NAME is given, a .class file will be written; this is useful for debugging only." + + (let ((cw (make-class-writer-1 (make-instance 'jboolean :java-instance t))) + (class-type-name (type-name class-name)) + (super-type-name (type-name super-name)) + (interface-type-names + (when interfaces + (let* ((no-of-interfaces (length interfaces)) + (ifarray (jnew-array "java.lang.String" no-of-interfaces))) + (dotimes (i no-of-interfaces ifarray) + (setf (jarray-ref ifarray i) (type-name (nth i interfaces))))))) + (args-for-%jnew)) + (visit-4 cw (+ constants.acc-public constants.acc-super) + class-type-name super-type-name interface-type-names) + (visit-field-3 cw (+ constants.acc-private constants.acc-static) + "rc" "Lorg/armedbear/lisp/RuntimeClass;") + + (dolist (field-def fields) + (visit-field-3 cw + (reduce #'+ (cddr field-def) :key #'modifier) + (car field-def) + (decorated-type-name (cadr field-def)))) + + + (if constructors + (loop for (arg-types constr-def super-invocation-args) in constructors + for unique-method-name = (apply #'concatenate 'string "|" arg-types) + then (apply #'concatenate 'string "|" arg-types) + collect unique-method-name into args + collect (coerce constr-def 'function) into args + do + (write-method + cw class-name class-type-name "" unique-method-name '("public") "void" arg-types + (cons super-type-name super-invocation-args)) + finally + (setf args-for-%jnew (append args-for-%jnew args))) + (let ((cv (visit-method-3 cw constants.acc-public "" "()V"))) + (visit-var-insn-2 cv constants.aload 0) + (visit-method-insn-4 cv constants.invokespecial super-type-name "" "()V") + (visit-insn-1 cv constants.return) + (visit-maxs-2 cv 1 1))) + + (loop for (method-name ret-type arg-types method-def . modifiers) in methods + for unique-method-name = (apply #'concatenate 'string method-name "|" arg-types) + then (apply #'concatenate 'string method-name "|" arg-types) + collect unique-method-name into args + collect (coerce method-def 'function) into args + do + (write-method + cw class-name class-type-name method-name unique-method-name modifiers ret-type arg-types) + finally + (apply #'java::%jnew-runtime-class class-name (append args-for-%jnew args))) + + (visit-end-0 cw) + + (when filename + (let ((os (make-file-output-stream-1 filename))) + (write-1 os (to-byte-array-0 cw)) + (close-0 os))) + + (java::%load-java-class-from-byte-array class-name (java-instance (to-byte-array-0 cw))))) + +(defun jredefine-method (class-name method-name arg-types method-def) + "Replace the definition of the method named METHDO-NAME (or + constructor, if METHD-NAME is nil) of argument types ARG-TYPES of the + class named CLASS-NAME defined with JNEW-RUNTIME-CLASS with + METHOD-DEF. See the documentation of JNEW-RUNTIME-CLASS." + (assert (jruntime-class-exists-p class-name) (class-name) + "Can't redefine methods of undefined runtime class ~a" class-name) + (let ((unique-method-name + (apply #'concatenate 'string (if method-name method-name "") "|" arg-types))) + (java::%jredefine-method class-name unique-method-name (compile nil method-def)))) + +(defun jruntime-class-exists-p (class-name) + "Returns true if a class named CLASS-NAME has been created and loaded by JNEW-RUNTIME-CLASS. + Needed because Java classes cannot be reloaded." + (when + (jstatic (jmethod "org.armedbear.lisp.RuntimeClass" "getRuntimeClass" "java.lang.String") + "org.armedbear.lisp.RuntimeClass" + class-name) + t)) Added: branches/save-image/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,460 @@ +/* + * AbclScriptEngine.java + * + * Copyright (C) 2008 Alessio Stalla + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.scripting; + +import java.io.File; +import java.io.IOException; +import java.io.InputStream; +import java.io.Reader; +import java.io.StringWriter; +import java.math.BigInteger; +import java.util.Map; +import java.util.Properties; + +import javax.script.*; + +import org.armedbear.lisp.*; +import org.armedbear.lisp.scripting.util.ReaderInputStream; +import org.armedbear.lisp.scripting.util.WriterOutputStream; + + +public class AbclScriptEngine extends AbstractScriptEngine implements Invocable, Compilable { + + private Interpreter interpreter; + private LispObject nonThrowingDebugHook; + private Function evalScript; + private Function compileScript; + private Function evalCompiledScript; + + public AbclScriptEngine() { + interpreter = Interpreter.getInstance(); + if(interpreter == null) { + interpreter = Interpreter.createInstance(); + } + this.nonThrowingDebugHook = Symbol.DEBUGGER_HOOK.getSymbolValue(); + try { + loadFromClasspath("/org/armedbear/lisp/scripting/lisp/packages.lisp"); + loadFromClasspath("/org/armedbear/lisp/scripting/lisp/abcl-script.lisp"); + loadFromClasspath("/org/armedbear/lisp/scripting/lisp/config.lisp"); + if(getClass().getResource("/abcl-script-config.lisp") != null) { + System.out.println("ABCL: loading configuration from " + getClass().getResource("/abcl-script-config.lisp")); + loadFromClasspath("/abcl-script-config.lisp"); + } + interpreter.eval("(abcl-script:configure-abcl)"); + System.out.println("ABCL: configured"); + evalScript = (Function) this.findSymbol("EVAL-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + compileScript = (Function) this.findSymbol("COMPILE-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + evalCompiledScript = (Function) this.findSymbol("EVAL-COMPILED-SCRIPT", "ABCL-SCRIPT").getSymbolFunction(); + } catch (ConditionThrowable e) { + throw new RuntimeException(e); + } + } + + public Interpreter getInterpreter() { + return interpreter; + } + + public void installNonThrowingDebugHook() { + installNonThrowingDebugHook(LispThread.currentThread()); + } + + public void installNonThrowingDebugHook(LispThread thread) { + thread.setSpecialVariable(Symbol.DEBUGGER_HOOK, this.nonThrowingDebugHook); + } + + public void installThrowingDebuggerHook(LispThread thread) throws ConditionThrowable { + Symbol dbgrhkfunSym; + dbgrhkfunSym = Lisp.PACKAGE_SYS.findAccessibleSymbol("%DEBUGGER-HOOK-FUNCTION"); + LispObject throwingDebugHook = dbgrhkfunSym.getSymbolFunction(); + thread.setSpecialVariable(Symbol.DEBUGGER_HOOK, throwingDebugHook); + } + + public void installThrowingDebuggerHook() throws ConditionThrowable { + installThrowingDebuggerHook(LispThread.currentThread()); + } + + public void setStandardInput(InputStream stream, LispThread thread) { + thread.setSpecialVariable(Symbol.STANDARD_INPUT, new Stream(stream, Symbol.CHARACTER, true)); + } + + public void setStandardInput(InputStream stream) { + setStandardInput(stream, LispThread.currentThread()); + } + + public void setInterpreter(Interpreter interpreter) { + this.interpreter = interpreter; + } + + public static String escape(String s) { + StringBuffer b = new StringBuffer(); + int len = s.length(); + char c; + for (int i = 0; i < len; ++i) { + c = s.charAt(i); + if (c == '\\' || c == '"') { + b.append('\\'); + } + b.append(c); + } + return b.toString(); + } + + public LispObject loadFromClasspath(String classpathResource) throws ConditionThrowable { + InputStream istream = getClass().getResourceAsStream(classpathResource); + Stream stream = new Stream(istream, Symbol.CHARACTER); + return load(stream); + } + + public LispObject load(Stream stream) throws ConditionThrowable { + Symbol keyword_verbose = Lisp.internKeyword("VERBOSE"); + Symbol keyword_print = Lisp.internKeyword("PRINT"); + /* + * load (filespec &key (verbose *load-verbose*) (print *load-print*) + * (if-does-not-exist t) (external-format :default) + */ + return Symbol.LOAD.getSymbolFunction().execute( + new LispObject[] { stream, keyword_verbose, Lisp.NIL, + keyword_print, Lisp.T, Keyword.IF_DOES_NOT_EXIST, + Lisp.T, Keyword.EXTERNAL_FORMAT, Keyword.DEFAULT }); + } + + public LispObject load(String filespec) throws ConditionThrowable { + return load(filespec, true); + } + + public LispObject load(String filespec, boolean compileIfNecessary) throws ConditionThrowable { + if (isCompiled(filespec) || !compileIfNecessary) { + return interpreter.eval("(load \"" + escape(filespec) + "\")"); + } else { + return compileAndLoad(filespec); + } + } + + public static boolean isCompiled(String filespec) { + if (filespec.endsWith(".abcl")) { + return true; + } + File source; + File compiled; + if (filespec.endsWith(".lisp")) { + source = new File(filespec); + compiled = new File(filespec.substring(0, filespec.length() - 5) + + ".abcl"); + } else { + source = new File(filespec + ".lisp"); + compiled = new File(filespec + ".abcl"); + } + if (!source.exists()) { + throw new IllegalArgumentException("The source file " + filespec + " cannot be found"); + } + return compiled.exists() + && compiled.lastModified() >= source.lastModified(); + } + + public LispObject compileFile(String filespec) throws ConditionThrowable { + return interpreter.eval("(compile-file \"" + escape(filespec) + "\")"); + } + + public LispObject compileAndLoad(String filespec) throws ConditionThrowable { + return interpreter.eval("(load (compile-file \"" + escape(filespec) + "\"))"); + } + + public static boolean functionp(LispObject obj) { + return obj instanceof Function; + } + + public JavaObject jsetq(String symbol, Object value) throws ConditionThrowable { + Symbol s = findSymbol(symbol); + JavaObject jo; + if (value instanceof JavaObject) { + jo = (JavaObject) value; + } else { + jo = new JavaObject(value); + } + s.setSymbolValue(jo); + return jo; + } + + public Symbol findSymbol(String name, String pkg) throws ConditionThrowable { + Cons values = (Cons) (interpreter.eval("(cl:multiple-value-list (find-symbol (symbol-name '#:" + + escape(name) + ")" + (pkg == null ? "" : " :" + escape(pkg)) + + "))")); + if(values.cadr() == Lisp.NIL) { + return null; + } else { + return (Symbol) values.car(); + } + } + + public Symbol findSymbol(String name) throws ConditionThrowable { + //Known bug: doesn't handle escaped ':' e.g. |a:b| + int i = name.indexOf(':'); + if(i < 0) { + return findSymbol(name, null); + } else { + if((i < name.length() - 1) && (name.charAt(i + 1) == ':')) { + return findSymbol(name.substring(i + 2), name.substring(0, i)); + } else { + return findSymbol(name.substring(i + 1), name.substring(0, i)); + } + } + } + + public Function findFunction(String name) throws ConditionThrowable { + return (Function) interpreter.eval("#'" + name); + } + + @Override + public Bindings createBindings() { + return new SimpleBindings(); + } + + private static LispObject makeBindings(Bindings bindings) throws ConditionThrowable { + if (bindings == null || bindings.size() == 0) { + return Lisp.NIL; + } + LispObject[] argList = new LispObject[bindings.size()]; + int i = 0; + for (Map.Entry entry : bindings.entrySet()) { + argList[i++] = Symbol.CONS.execute(new SimpleString(entry.getKey()), toLisp(entry.getValue())); + } + return Symbol.LIST.getSymbolFunction().execute(argList); + } + + @Override + public ScriptContext getContext() { + return super.getContext(); + } + + private Object eval(Function evaluator, LispObject code, ScriptContext ctx) throws ScriptException { + ReaderInputStream in = null; + WriterOutputStream out = null; + LispObject retVal = null; + try { + in = new ReaderInputStream(ctx.getReader()); + out = new WriterOutputStream(ctx.getWriter()); + Stream outStream = new Stream(out, Symbol.CHARACTER); + Stream inStream = new Stream(in, Symbol.CHARACTER); + retVal = evaluator.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)), + makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)), + inStream, outStream, + code, new JavaObject(ctx)); + return toJava(retVal); + } catch (ConditionThrowable e) { + throw new ScriptException(new Exception(e)); + } catch (IOException e) { + throw new ScriptException(e); + } + } + + @Override + public Object eval(String code, ScriptContext ctx) throws ScriptException { + return eval(evalScript, new SimpleString(code), ctx); + } + + private static String toString(Reader reader) throws IOException { + StringWriter w = new StringWriter(); + int i; + i = reader.read(); + while (i != -1) { + w.write(i); + i = reader.read(); + } + return w.toString(); + } + + @Override + public Object eval(Reader code, ScriptContext ctx) throws ScriptException { + try { + return eval(toString(code), ctx); + } catch (IOException e) { + return new ScriptException(e); + } + } + + @Override + public ScriptEngineFactory getFactory() { + return new AbclScriptEngineFactory(); + } + + private static Object toJava(LispObject lispObject) throws ConditionThrowable { + return lispObject.javaInstance(); + } + + public static LispObject toLisp(Object javaObject) { + if(javaObject == null) { + return Lisp.NIL; + } else if(javaObject instanceof Boolean) { + return ((Boolean)javaObject).booleanValue() ? Lisp.T : Lisp.NIL; + } else if(javaObject instanceof Byte) { + return new Fixnum(((Byte)javaObject).intValue()); + } else if(javaObject instanceof Integer) { + return new Fixnum(((Integer)javaObject).intValue()); + } else if(javaObject instanceof Short) { + return new Fixnum(((Short)javaObject).shortValue()); + } else if(javaObject instanceof Long) { + return new Bignum((Long)javaObject); + } else if(javaObject instanceof BigInteger) { + return new Bignum((BigInteger) javaObject); + } else if(javaObject instanceof Float) { + return new SingleFloat(((Float)javaObject).floatValue()); + } else if(javaObject instanceof Double) { + return new DoubleFloat(((Double)javaObject).doubleValue()); + } else if(javaObject instanceof String) { + return new SimpleString((String)javaObject); + } else if(javaObject instanceof Character) { + return LispCharacter.getInstance((Character)javaObject); + } else if(javaObject instanceof Object[]) { + Object[] array = (Object[]) javaObject; + SimpleVector v = new SimpleVector(array.length); + for(int i = array.length; i > 0; --i) { + try { + v.aset(i, new JavaObject(array[i])); + } catch (ConditionThrowable e) { + throw new Error("Can't set SimpleVector index " + i, e); + } + } + return v; + } else if(javaObject instanceof LispObject) { + return (LispObject) javaObject; + } else { + return new JavaObject(javaObject); + } + } + + @Override + public T getInterface(Class clasz) { + try { + return getInterface(eval("(cl:find-package '#:ABCL-SCRIPT-USER)"), clasz); + } catch (ScriptException e) { + throw new Error(e); + } + } + + @SuppressWarnings("unchecked") + @Override + public T getInterface(Object thiz, Class clasz) { + try { + Symbol s = findSymbol("jmake-proxy", "JAVA"); + JavaObject iface = new JavaObject(clasz); + return (T) ((JavaObject) s.execute(iface, (LispObject) thiz)).javaInstance(); + } catch (ConditionThrowable e) { + throw new Error(e); + } + } + + @Override + public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { + try { + Symbol s; + if(name.indexOf(':') >= 0) { + s = findSymbol(name); + } else { + s = findSymbol(name, "ABCL-SCRIPT-USER"); + } + if(s != null) { + LispObject f = s.getSymbolFunction(); + if(f != null && f instanceof Function) { + LispObject[] wrappedArgs = new LispObject[args.length]; + for(int i = 0; i < args.length; ++i) { + wrappedArgs[i] = toLisp(args[i]); + } + switch(args.length) { + case 0: + return LispThread.currentThread().execute(f); + case 1: + return LispThread.currentThread().execute(f, wrappedArgs[0]); + case 2: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1]); + case 3: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2]); + case 4: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3]); + case 5: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4]); + case 6: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5]); + case 7: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6]); + case 8: + return LispThread.currentThread().execute(f, wrappedArgs[0], wrappedArgs[1], wrappedArgs[2], wrappedArgs[3], wrappedArgs[4], wrappedArgs[5], wrappedArgs[6], wrappedArgs[7]); + default: + return LispThread.currentThread().execute(f, wrappedArgs); + } + } else { + throw new NoSuchMethodException(name); + } + } else { + throw new NoSuchMethodException(name); + } + } catch (ConditionThrowable e) { + throw new ScriptException(new RuntimeException(e)); + } + } + + @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."); + } + + public class AbclCompiledScript extends CompiledScript { + + private LispObject function; + + public AbclCompiledScript(LispObject function) { + this.function = function; + } + + @Override + public Object eval(ScriptContext context) throws ScriptException { + return AbclScriptEngine.this.eval(evalCompiledScript, function, context); + } + + @Override + public ScriptEngine getEngine() { + return AbclScriptEngine.this; + } + + } + + + @Override + public CompiledScript compile(String script) throws ScriptException { + try { + Function f = (Function) compileScript.execute(new SimpleString(script)); + return new AbclCompiledScript(f); + } catch (ConditionThrowable e) { + throw new ScriptException(new Exception(e)); + } catch(ClassCastException e) { + throw new ScriptException(e); + } + } + + @Override + public CompiledScript compile(Reader script) throws ScriptException { + try { + return compile(toString(script)); + } catch (IOException e) { + throw new ScriptException(e); + } + } + +} Added: branches/save-image/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,133 @@ +/* + * AbclScriptEngineFactory.java + * + * Copyright (C) 2008 Alessio Stalla + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + */ + +package org.armedbear.lisp.scripting; + +import java.util.ArrayList; +import java.util.List; + +import javax.script.ScriptEngine; +import javax.script.ScriptEngineFactory; + +public class AbclScriptEngineFactory implements ScriptEngineFactory { + + 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 getExtensions() { + List extensions = new ArrayList(1); + extensions.add("lisp"); + return 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(); + } + + @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 getMimeTypes() { + return new ArrayList(); + } + + @Override + public List getNames() { + List names = new ArrayList(1); + names.add("ABCL"); + names.add("cl"); + names.add("Lisp"); + names.add("Common Lisp"); + return 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; + } + +} Added: branches/save-image/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,140 @@ +;;; abcl-script.lisp +;;; +;;; Copyright (C) 2008 Alessio Stalla +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package :abcl-script) + +(defconstant +global-scope+ + (jfield "javax.script.ScriptContext" "GLOBAL_SCOPE")) + +(defconstant +engine-scope+ + (jfield "javax.script.ScriptContext" "ENGINE_SCOPE")) + +(defconstant +put-binding+ (jmethod "javax.script.Bindings" + "put" + "java.lang.String" + "java.lang.Object")) + +(defconstant +get-bindings+ (jmethod "javax.script.ScriptContext" + "getBindings" + "int")) + +(defun generate-bindings (bindings) + (let ((*package* (find-package :abcl-script-user))) + (mapcar (lambda (binding) (list (read-from-string (car binding)) + (cdr binding))) + bindings))) + +(defun generate-java-bindings (bindings-list actual-bindings java-bindings) + (loop :for binding :in actual-bindings + :for jbinding :in bindings-list + :collect `(jcall +put-binding+ + ,java-bindings ,(car jbinding) ,(car binding)))) + +(defmacro with-script-context ((global-bindings engine-bindings stdin stdout script-context) + body) + (let ((actual-global-bindings (gensym)) + (actual-engine-bindings (gensym))) + `(let ((*package* (find-package :abcl-script-user)) + (*standard-input* ,stdin) + (*standard-output* ,stdout) + (,actual-global-bindings (generate-bindings ,global-bindings)) + (,actual-engine-bindings (generate-bindings ,engine-bindings))) + (eval `(let ((*standard-input* ,,stdin) + (*standard-output* ,,stdout) + (*package* (find-package :abcl-script-user))) + (let (,@,actual-global-bindings) + (let (,@,actual-engine-bindings) + (prog1 + (progn ,@,body) + (finish-output *standard-output*) + ,@(generate-java-bindings + ,global-bindings + ,actual-global-bindings + (jcall +get-bindings+ ,script-context +global-scope+)) + ,@(generate-java-bindings + ,engine-bindings + ,actual-engine-bindings + (jcall +get-bindings+ ,script-context +engine-scope+)))))))))) + +(defun eval-script (global-bindings engine-bindings stdin stdout + code-string script-context) + (with-script-context (global-bindings engine-bindings stdin stdout script-context) + (read-from-string + (concatenate 'string "(" code-string ")")))) + +(defun eval-compiled-script (global-bindings engine-bindings stdin stdout + function script-context) + (with-script-context (global-bindings engine-bindings stdin stdout script-context) + `((funcall ,function)))) + +(defun compile-script (code-string) + (if *compile-using-temp-files* + (let* ((tmp-file (jstatic (jmethod "java.io.File" "createTempFile" "java.lang.String" "java.lang.String") + nil "abcl-src-file-" ".lisp")) + (tmp-file-path (jcall (jmethod "java.io.File" "getAbsolutePath") tmp-file))) + (jcall (jmethod "java.io.File" "deleteOnExit") tmp-file) ;to be really-really-really sure... + (unwind-protect + (progn + (with-open-file (stream tmp-file-path :direction :output :if-exists :overwrite) + (prin1 code-string stream) + (finish-output stream)) + (let ((compiled-file (compile-file tmp-file-path))) + (jcall (jmethod "java.io.File" "deleteOnExit") + (jnew (jconstructor "java.io.File" "java.lang.String") + (namestring compiled-file))) + (lambda () (load compiled-file)))) + (delete-file tmp-file-path))) + (eval + `(compile + nil + (lambda () + ,@(let ((*package* (find-package :abcl-script-user))) + (read-from-string (concatenate 'string "(" code-string ")")))))))) + +;;Java interface implementation + +(defvar *interface-implementation-map* (make-hash-table :test #'equal)) + +(defun find-java-interface-implementation (interface) + (gethash interface *interface-implementation-map*)) + +(defun register-java-interface-implementation (interface impl) + (setf (gethash interface *interface-implementation-map*) impl)) + +(defun remove-java-interface-implementation (interface) + (remhash interface *interface-implementation-map*)) + +(defun define-java-interface-implementation (interface implementation &optional lisp-this) + (register-java-interface-implementation + interface + (jmake-proxy interface implementation lisp-this))) + +;Let's load it so asdf package is already defined when loading config.lisp +(require 'asdf) \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/scripting/lisp/config.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/lisp/config.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +;;; config.lisp +;;; +;;; Copyright (C) 2008 Alessio Stalla +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + + +(in-package :abcl-script) + +(defparameter *launch-swank-at-startup* nil) + +(defparameter *swank-dir* nil) + +(defparameter *swank-port* 4005) + +(defparameter *use-throwing-debugger* t) + +(defparameter *compile-using-temp-files* t) + +(defconstant +standard-debugger-hook+ *debugger-hook*) + +(defun configure-abcl () + (setq *debugger-hook* + (if *use-throwing-debugger* + #'sys::%debugger-hook-function + +standard-debugger-hook+)) + (when *launch-swank-at-startup* + (unless *swank-dir* + (error "Swank directory not specified, please set *swank-dir*")) + (pushnew *swank-dir* asdf:*central-registry* :test #'equal) + (asdf:oos 'asdf:load-op :swank) + (ext:make-thread (lambda () (funcall (find-symbol + (symbol-name '#:create-server) + :swank) + :port *swank-port*)) + :name "ABCL script - Swank thread"))) Added: branches/save-image/src/org/armedbear/lisp/scripting/lisp/packages.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/lisp/packages.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +;;; packages.lisp +;;; +;;; Copyright (C) 2008 Alessio Stalla +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(defpackage :abcl-script + (:use :cl :java) + (:export + #:eval-script + #:compile-script + #:*compile-using-temp-files* + #:configure-abcl + #:eval-compiled-script + #:define-java-interface-implementation + #:find-java-interface-implementation + #:*launch-swank-at-startup* + #:register-java-interface-implementation + #:remove-java-interface-implementation + #:+standard-debugger-hook+ + #:*swank-dir* + #:*swank-port* + #:*use-throwing-debugger*)) + +(defpackage :abcl-script-user + (:use :cl :ext :java :abcl-script)) \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/scripting/util/ReaderInputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/util/ReaderInputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,79 @@ +package org.armedbear.lisp.scripting.util; + +import java.io.*; + +public class ReaderInputStream extends InputStream { + + private final Reader reader; + private final Writer writer; + private final PipedInputStream inPipe; + + public ReaderInputStream(Reader reader) throws IOException { + this(reader, null); + } + + public ReaderInputStream(final Reader reader, String encoding) throws IOException { + this.reader = reader; + inPipe = new PipedInputStream(); + OutputStream outPipe = new PipedOutputStream(inPipe); + writer = (encoding == null) ? new OutputStreamWriter(outPipe) : new OutputStreamWriter(outPipe, encoding); + } + + public int read() throws IOException { + if(doRead()) { + return inPipe.read(); + } else { + return -1; + } + } + + public int read(byte b[]) throws IOException { + return super.read(b); + } + + public int read(byte b[], int off, int len) throws IOException { + if(len <= 0) { + return 0; + } + int n = read(); + if(n == -1) { + return -1; + } else { + b[off] = (byte)n; + } + return 1; + } + + public long skip(long n) throws IOException { + return super.skip(n); + } + + public int available() throws IOException { + return 0; + } + + public synchronized void close() throws IOException { + close(reader); + close(writer); + close(inPipe); + } + + private static void close(Closeable cl) { + try { + cl.close(); + } catch (IOException e) { + e.printStackTrace(); + } + } + + private boolean doRead() throws IOException { + int n = reader.read(); + if(n == -1) { + return false; + } + writer.write(n); + writer.flush(); + return true; + } + +} \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/scripting/util/WriterOutputStream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/scripting/util/WriterOutputStream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,64 @@ +package org.armedbear.lisp.scripting.util; + +import java.io.*; + +public class WriterOutputStream extends OutputStream { + + private final Reader reader; + private final Writer writer; + private final PipedOutputStream outPipe; + + public WriterOutputStream(Writer writer) throws IOException { + this(writer, null); + } + + public WriterOutputStream(final Writer writer, String encoding) throws IOException { + this.writer = writer; + outPipe = new PipedOutputStream(); + InputStream inPipe = new PipedInputStream(outPipe); + reader = (encoding == null) ? new InputStreamReader(inPipe) : new InputStreamReader(inPipe, encoding); + } + + @Override + public void write(int b) throws IOException { + doWrite(b); + writer.flush(); + } + + @Override + public void flush() throws IOException { + super.flush(); + } + + @Override + public void write(byte[] b, int off, int len) throws IOException { + super.write(b, off, len); + } + + @Override + public void write(byte[] b) throws IOException { + super.write(b); + } + + public synchronized void close() throws IOException { + close(reader); + close(writer); + close(outPipe); + } + + private static void close(Closeable cl) { + try { + cl.close(); + } catch (IOException e) { + e.printStackTrace(); + } + } + + private void doWrite(int n) throws IOException { + outPipe.write(n); + outPipe.flush(); + n = reader.read(); + writer.write(n); + } + +} \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/search.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/search.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,129 @@ +;;; search.lisp +;;; +;;; Copyright (C) 2003-2004 Peter Graves +;;; $Id: search.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;; From CMUCL. + +(eval-when (:compile-toplevel :execute) + + (defmacro compare-elements (elt1 elt2) + `(if test-not + (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) + (return nil) + t) + (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) + (return nil) + t))) + + + (defmacro search-compare-list-list (main sub) + `(do ((main ,main (cdr main)) + (jndex start1 (1+ jndex)) + (sub (nthcdr start1 ,sub) (cdr sub))) + ((or (null main) (null sub) (= end1 jndex)) + t) + (compare-elements (car sub) (car main)))) + + + (defmacro search-compare-list-vector (main sub) + `(do ((main ,main (cdr main)) + (index start1 (1+ index))) + ((or (null main) (= index end1)) t) + (compare-elements (aref ,sub index) (car main)))) + + + (defmacro search-compare-vector-list (main sub index) + `(do ((sub (nthcdr start1 ,sub) (cdr sub)) + (jndex start1 (1+ jndex)) + (index ,index (1+ index))) + ((or (= end1 jndex) (null sub)) t) + (compare-elements (car sub) (aref ,main index)))) + + + (defmacro search-compare-vector-vector (main sub index) + `(do ((index ,index (1+ index)) + (sub-index start1 (1+ sub-index))) + ((= sub-index end1) t) + (compare-elements (aref ,sub sub-index) (aref ,main index)))) + + + (defmacro search-compare (main-type main sub index) + (if (eq main-type 'list) + `(if (listp ,sub) + (search-compare-list-list ,main ,sub) + (search-compare-list-vector ,main ,sub)) + `(if (listp ,sub) + (search-compare-vector-list ,main ,sub ,index) + (search-compare-vector-vector ,main ,sub ,index)))) + + + (defmacro list-search (main sub) + `(do ((main (nthcdr start2 ,main) (cdr main)) + (index2 start2 (1+ index2)) + (terminus (- end2 (- end1 start1))) + (last-match ())) + ((> index2 terminus) last-match) + (if (search-compare list main ,sub index2) + (if from-end + (setq last-match index2) + (return index2))))) + + + (defmacro vector-search (main sub) + `(do ((index2 start2 (1+ index2)) + (terminus (- end2 (- end1 start1))) + (last-match ())) + ((> index2 terminus) last-match) + (if (search-compare vector ,main ,sub index2) + (if from-end + (setq last-match index2) + (return index2))))) + + ) ; eval-when + +(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not + (start1 0) end1 (start2 0) end2 key) + (let ((end1 (or end1 (length sequence1))) + (end2 (or end2 (length sequence2)))) + (when key + (setq key (coerce-to-function key))) + (if (listp sequence2) + (list-search sequence2 sequence1) + (vector-search sequence2 sequence1)))) + +(defun simple-search (sequence1 sequence2) + (cond ((and (stringp sequence1) (stringp sequence2)) + (simple-string-search sequence1 sequence2)) + ((vectorp sequence2) + (simple-vector-search sequence1 sequence2)) + (t + (search sequence1 sequence2 :from-end nil)))) Added: branches/save-image/src/org/armedbear/lisp/sequences.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/sequences.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,59 @@ +;;; sequences.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: sequences.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defmacro type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type))) + +(defun make-sequence-of-type (type length) + (case (type-specifier-atom type) + (list + (make-list length)) + ((bit-vector simple-bit-vector) + (make-array length :element-type 'bit)) + ((simple-base-string simple-string string) + (make-string length)) + ((simple-vector vector) + (if (cadr type) + (make-array length :element-type (cadr type)) + (make-array length))) + (nil-vector + (make-array length :element-type nil)) + (simple-array + (if (cadr type) + (make-array length :element-type (cadr type)) + (make-array length))) + (t + (error "MAKE-SEQUENCE-OF-TYPE: unsupported case ~S" type)))) + +(defmacro make-sequence-like (sequence length) + `(make-sequence-of-type (type-of ,sequence) ,length)) Added: branches/save-image/src/org/armedbear/lisp/server_socket_close.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/server_socket_close.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +/* + * server_socket_close.java + * + * Copyright (C) 2004 Peter Graves + * $Id: server_socket_close.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.ServerSocket; + +// ### %server-socket-close +public final class server_socket_close extends Primitive +{ + private server_socket_close() + { + super("%server-socket-close", PACKAGE_SYS, false, "socket"); + } + + @Override + public LispObject execute(LispObject first) + throws ConditionThrowable + { + try { + ServerSocket serverSocket = (ServerSocket) JavaObject.getObject(first); + serverSocket.close(); + return T; + } + catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + private static final Primitive SERVER_SOCKET_CLOSE = new server_socket_close(); +} Added: branches/save-image/src/org/armedbear/lisp/setf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/setf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,236 @@ +;;; setf.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: setf.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun get-setf-method-inverse (form inverse setf-function) + (let ((new-var (gensym)) + (vars nil) + (vals nil)) + (dolist (x (cdr form)) + (push (gensym) vars) + (push x vals)) + (setq vals (nreverse vals)) + (values vars vals (list new-var) + (if setf-function + `(, at inverse ,new-var , at vars) + (if (functionp (car inverse)) + `(funcall , at inverse , at vars ,new-var) + `(, at inverse , at vars ,new-var))) + `(,(car form) , at vars)))) + +;;; If a macro, expand one level and try again. If not, go for the +;;; SETF function. +(defun expand-or-get-setf-inverse (form environment) + (multiple-value-bind (expansion expanded) + (macroexpand-1 form environment) + (if expanded + (get-setf-expansion expansion environment) + (get-setf-method-inverse form `(funcall #'(setf ,(car form))) + t)))) + +(defun get-setf-expansion (form &optional environment) + (when (and (consp form) + (autoloadp (%car form))) + (resolve (%car form))) + (let (temp) + (cond ((symbolp form) + (let ((new-var (gensym))) + (values nil nil (list new-var) + `(setq ,form ,new-var) form))) + ((setq temp (get (car form) 'setf-inverse)) + (get-setf-method-inverse form `(,temp) nil)) + ((setq temp (get (car form) 'setf-expander)) + (funcall temp form environment)) + (t + (expand-or-get-setf-inverse form environment))))) + +(defmacro setf (&rest args &environment environment) + (let ((numargs (length args))) + (cond + ((= numargs 2) + (let ((place (first args)) + (value-form (second args))) + (if (atom place) + `(setq ,place ,value-form) + (progn + (when (symbolp (%car place)) + (resolve (%car place))) + (multiple-value-bind (dummies vals store-vars setter getter) + (get-setf-expansion place environment) + (let ((inverse (get (car place) 'setf-inverse))) + (if (and inverse (eq inverse (car setter))) + (if (functionp inverse) + `(funcall ,inverse ,@(cdr place) ,value-form) + `(,inverse ,@(cdr place) ,value-form)) + (if (or (null store-vars) (cdr store-vars)) + `(let* (,@(mapcar #'list dummies vals)) + (multiple-value-bind ,store-vars ,value-form + ,setter)) + `(let* (,@(mapcar #'list dummies vals) + ,(list (car store-vars) value-form)) + ,setter))))))))) + ((oddp numargs) + (error "Odd number of arguments to SETF.")) + (t + (do ((a args (cddr a)) (l nil)) + ((null a) `(progn ,@(nreverse l))) + (setq l (cons (list 'setf (car a) (cadr a)) l))))))) + +;;; Redefined in define-modify-macro.lisp. +(defmacro incf (place &optional (delta 1)) + `(setf ,place (+ ,place ,delta))) + +;;; Redefined in define-modify-macro.lisp. +(defmacro decf (place &optional (delta 1)) + `(setf ,place (- ,place ,delta))) + +;; (defsetf subseq (sequence start &optional (end nil)) (v) +;; `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) +;; ,v)) +(defun %set-subseq (sequence start &rest rest) + (let ((end nil) v) + (ecase (length rest) + (1 + (setq v (car rest))) + (2 + (setq end (car rest) + v (cadr rest)))) + (progn + (replace sequence v :start1 start :end1 end) + v))) + +(defun %define-setf-macro (name expander inverse doc) + (declare (ignore doc)) ; FIXME + (when inverse + (put name 'setf-inverse inverse)) + (when expander + (put name 'setf-expander expander)) + name) + +(defmacro defsetf (access-function update-function) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (put ',access-function 'setf-inverse ',update-function))) + +(defun %set-caar (x v) (set-car (car x) v)) +(defun %set-cadr (x v) (set-car (cdr x) v)) +(defun %set-cdar (x v) (set-cdr (car x) v)) +(defun %set-cddr (x v) (set-cdr (cdr x) v)) +(defun %set-caaar (x v) (set-car (caar x) v)) +(defun %set-cadar (x v) (set-car (cdar x) v)) +(defun %set-cdaar (x v) (set-cdr (caar x) v)) +(defun %set-cddar (x v) (set-cdr (cdar x) v)) +(defun %set-caadr (x v) (set-car (cadr x) v)) +(defun %set-caddr (x v) (set-car (cddr x) v)) +(defun %set-cdadr (x v) (set-cdr (cadr x) v)) +(defun %set-cdddr (x v) (set-cdr (cddr x) v)) +(defun %set-caaaar (x v) (set-car (caaar x) v)) +(defun %set-cadaar (x v) (set-car (cdaar x) v)) +(defun %set-cdaaar (x v) (set-cdr (caaar x) v)) +(defun %set-cddaar (x v) (set-cdr (cdaar x) v)) +(defun %set-caadar (x v) (set-car (cadar x) v)) +(defun %set-caddar (x v) (set-car (cddar x) v)) +(defun %set-cdadar (x v) (set-cdr (cadar x) v)) +(defun %set-cdddar (x v) (set-cdr (cddar x) v)) +(defun %set-caaadr (x v) (set-car (caadr x) v)) +(defun %set-cadadr (x v) (set-car (cdadr x) v)) +(defun %set-cdaadr (x v) (set-cdr (caadr x) v)) +(defun %set-cddadr (x v) (set-cdr (cdadr x) v)) +(defun %set-caaddr (x v) (set-car (caddr x) v)) +(defun %set-cadddr (x v) (set-car (cdddr x) v)) +(defun %set-cdaddr (x v) (set-cdr (caddr x) v)) +(defun %set-cddddr (x v) (set-cdr (cdddr x) v)) + +(defsetf car set-car) +(defsetf cdr set-cdr) +(defsetf caar %set-caar) +(defsetf cadr %set-cadr) +(defsetf cdar %set-cdar) +(defsetf cddr %set-cddr) +(defsetf caaar %set-caaar) +(defsetf cadar %set-cadar) +(defsetf cdaar %set-cdaar) +(defsetf cddar %set-cddar) +(defsetf caadr %set-caadr) +(defsetf caddr %set-caddr) +(defsetf cdadr %set-cdadr) +(defsetf cdddr %set-cdddr) +(defsetf caaaar %set-caaaar) +(defsetf cadaar %set-cadaar) +(defsetf cdaaar %set-cdaaar) +(defsetf cddaar %set-cddaar) +(defsetf caadar %set-caadar) +(defsetf caddar %set-caddar) +(defsetf cdadar %set-cdadar) +(defsetf cdddar %set-cdddar) +(defsetf caaadr %set-caaadr) +(defsetf cadadr %set-cadadr) +(defsetf cdaadr %set-cdaadr) +(defsetf cddadr %set-cddadr) +(defsetf caaddr %set-caaddr) +(defsetf cadddr %set-cadddr) +(defsetf cdaddr %set-cdaddr) +(defsetf cddddr %set-cddddr) + +(defsetf first set-car) +(defsetf second %set-cadr) +(defsetf third %set-caddr) +(defsetf fourth %set-cadddr) +(defun %set-fifth (x v) (set-car (cddddr x) v)) +(defsetf fifth %set-fifth) +(defun %set-sixth (x v) (set-car (cdr (cddddr x)) v)) +(defsetf sixth %set-sixth) +(defun %set-seventh (x v) (set-car (cddr (cddddr x)) v)) +(defsetf seventh %set-seventh) +(defun %set-eighth (x v) (set-car (cdddr (cddddr x)) v)) +(defsetf eighth %set-eighth) +(defun %set-ninth (x v) (set-car (cddddr (cddddr x)) v)) +(defsetf ninth %set-ninth) +(defun %set-tenth (x v) (set-car (cdr (cddddr (cddddr x))) v)) +(defsetf tenth %set-tenth) + +(defsetf rest set-cdr) +(defsetf elt %set-elt) +(defsetf nth %set-nth) +(defsetf svref svset) +(defsetf fill-pointer %set-fill-pointer) +(defsetf subseq %set-subseq) +(defsetf symbol-value set) +(defsetf symbol-function %set-symbol-function) +(defsetf symbol-plist %set-symbol-plist) +(defsetf get put) +(defsetf gethash puthash) +(defsetf char set-char) +(defsetf schar set-schar) +(defsetf logical-pathname-translations %set-logical-pathname-translations) +(defsetf readtable-case %set-readtable-case) + +(defsetf function-info %set-function-info) Added: branches/save-image/src/org/armedbear/lisp/sets.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/sets.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,213 @@ +;;; sets.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: sets.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; From CMUCL. + +(defmacro with-set-keys (funcall) + `(cond (notp ,(append funcall '(:key key :test-not test-not))) + (t ,(append funcall '(:key key :test test))))) + +(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (require-type list2 'list) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (let ((res list2)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall-key key elt) list2)) + (push elt res))) + res)) + +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) + +(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (let ((res list2) + (list1 list1)) + (do () + ((endp list1)) + (if (not (with-set-keys (member (funcall-key key (car list1)) list2))) + (steve-splice list1 res) + (setf list1 (cdr list1)))) + res)) + + +(defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (funcall-key key elt) list2)) + (push elt res))) + res)) + +(defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (let ((res nil) + (list1 list1)) + (do () ((endp list1)) + (if (with-set-keys (member (funcall-key key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (if (null list2) + list1 + (let ((res nil)) + (dolist (elt list1) + (if (not (with-set-keys (member (funcall-key key elt) list2))) + (push elt res))) + res))) + + +(defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (let ((res nil) + (list1 list1)) + (do () ((endp list1)) + (if (not (with-set-keys (member (funcall-key key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + + +(defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (when key + (setq key (coerce-to-function key))) + (let ((result nil) + (key (when key (coerce key 'function))) + (test (coerce test 'function)) + (test-not (if test-not (coerce test-not 'function) #'eql))) + (dolist (elt list1) + (unless (with-set-keys (member (funcall-key key elt) list2)) + (setq result (cons elt result)))) + (let ((test (if testp + (lambda (x y) (funcall test y x)) + test)) + (test-not (if notp + (lambda (x y) (funcall test-not y x)) + test-not))) + (dolist (elt list2) + (unless (with-set-keys (member (funcall-key key elt) list1)) + (setq result (cons elt result))))) + result)) + +;;; Adapted from SBCL. +(defun nset-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not #'eql notp)) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (let ((key (and key (coerce-to-function key))) + (test (if testp (coerce-to-function test) test)) + (test-not (if notp (coerce-to-function test-not) test-not))) + ;; The outer loop examines LIST1 while the inner loop examines + ;; LIST2. If an element is found in LIST2 "equal" to the element + ;; in LIST1, both are spliced out. When the end of LIST1 is + ;; reached, what is left of LIST2 is tacked onto what is left of + ;; LIST1. The splicing operation ensures that the correct + ;; operation is performed depending on whether splice is at the + ;; top of the list or not. + (do ((list1 list1) + (list2 list2) + (x list1 (cdr x)) + (splicex ()) + (deleted-y ()) + ;; elements of LIST2, which are "equal" to some processed + ;; earlier elements of LIST1 + ) + ((endp x) + (if (null splicex) + (setq list1 list2) + (rplacd splicex list2)) + list1) + (let ((key-val-x (apply-key key (car x))) + (found-duplicate nil)) + + ;; Move all elements from LIST2, which are "equal" to (CAR X), + ;; to DELETED-Y. + (do* ((y list2 next-y) + (next-y (cdr y) (cdr y)) + (splicey ())) + ((endp y)) + (cond ((let ((key-val-y (apply-key key (car y)))) + (if notp + (not (funcall test-not key-val-x key-val-y)) + (funcall test key-val-x key-val-y))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (setq deleted-y (rplacd y deleted-y)) + (setq found-duplicate t)) + (t (setq splicey y)))) + + (unless found-duplicate + (setq found-duplicate (with-set-keys (member key-val-x deleted-y)))) + + (if found-duplicate + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (setq splicex x)))))) + +;;; Adapted from SBCL. +(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) + (require-type list2 'list) + (when (and testp notp) + (error "Both :TEST and :TEST-NOT were supplied.")) + (let ((key (and key (coerce-to-function key)))) + (dolist (elt list1) + (unless (with-set-keys (member (funcall-key key elt) list2)) + (return-from subsetp nil))) + t)) Added: branches/save-image/src/org/armedbear/lisp/shiftf.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/shiftf.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,75 @@ +;;; shiftf.lisp +;;; +;;; Copyright (C) 2003-2004 Peter Graves +;;; $Id: shiftf.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From CMUCL. + +(in-package "SYSTEM") + +(require '#:collect) + +(defmacro shiftf (&rest args &environment env) + "One or more SETF-style place expressions, followed by a single + value expression. Evaluates all of the expressions in turn, then + assigns the value of each expression to the place on its left, + returning the value of the leftmost." + (when args + (collect ((let*-bindings) (mv-bindings) (setters) (getters)) + ;; The last arg isn't necessarily a place, so we have to handle + ;; that separately. + (dolist (arg (butlast args)) + (multiple-value-bind + (temps subforms store-vars setter getter) + (get-setf-expansion arg env) + (loop + for temp in temps + for subform in subforms + do (let*-bindings `(,temp ,subform))) + (mv-bindings store-vars) + (setters setter) + (getters getter))) + ;; Handle the last arg specially here. Just put something to + ;; force the setter so the setter for the previous var gets set, + ;; and the getter is just the last arg itself. + (setters nil) + (getters (car (last args))) + + (labels ((thunk (mv-bindings getters) + (if mv-bindings + `((multiple-value-bind + ,(car mv-bindings) + ,(car getters) + ,@(thunk (cdr mv-bindings) (cdr getters)))) + `(,@(butlast (setters)))))) + `(let* ,(let*-bindings) + (multiple-value-bind ,(car (mv-bindings)) + ,(car (getters)) + ,@(thunk (mv-bindings) (cdr (getters))) + (values ,@(car (mv-bindings))))))))) Added: branches/save-image/src/org/armedbear/lisp/signal.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/signal.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,153 @@ +;;; signal.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: signal.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package "SYSTEM") + +(export 'coerce-to-condition) + +(defvar *maximum-error-depth* 10) + +(defvar *current-error-depth* 0) + +(defvar *handler-clusters* nil) + +(defvar *break-on-signals* nil) + +(defun signal (datum &rest arguments) + (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal)) + (*handler-clusters* *handler-clusters*)) + (let* ((old-bos *break-on-signals*) + (*break-on-signals* nil)) + (when (typep condition old-bos) + (let ((*saved-backtrace* (backtrace-as-list))) + (break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)." + condition)))) + (loop + (unless *handler-clusters* + (return)) + (let ((cluster (pop *handler-clusters*))) + (dolist (handler cluster) + (when (typep condition (car handler)) + (funcall (cdr handler) condition))))) + nil)) + +(defun error (datum &rest arguments) + (let ((condition (coerce-to-condition datum arguments 'simple-error 'error))) + (signal condition) + (let ((*current-error-depth* (1+ *current-error-depth*))) + (cond ((> *current-error-depth* *maximum-error-depth*) + (%format t "~%Maximum error depth exceeded (~D nested errors).~%" + *current-error-depth*) + (if (fboundp 'internal-debug) + (internal-debug) + (quit))) + (t + (invoke-debugger condition)))))) + +;; COERCE-TO-CONDITION is redefined in clos.lisp. +(defun coerce-to-condition (datum arguments default-type fun-name) + (cond ((typep datum 'condition) + (when arguments + (error 'simple-type-error + :datum arguments + :expected-type 'null + :format-control "You may not supply additional arguments when giving ~S to ~S." + :format-arguments (list datum fun-name))) + datum) + ((symbolp datum) + (%make-condition datum arguments)) + ((or (stringp datum) (functionp datum)) + (%make-condition default-type + (list :format-control datum + :format-arguments arguments))) + (t + (error 'simple-type-error + :datum datum + :expected-type '(or symbol string) + :format-control "Bad argument to ~S: ~S." + :format-arguments (list fun-name datum))))) + +(defmacro handler-bind (bindings &body forms) + (dolist (binding bindings) + (unless (and (consp binding) (= (length binding) 2)) + (error "ill-formed handler binding ~S" binding))) + `(let ((*handler-clusters* + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + bindings)) + *handler-clusters*))) + (progn + , at forms))) + +(defmacro handler-case (form &rest cases) + (let ((no-error-clause (assoc ':no-error cases))) + (if no-error-clause + (let ((normal-return (make-symbol "normal-return")) + (error-return (make-symbol "error-return"))) + `(block ,error-return + (multiple-value-call (lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause cases))))))) + (let ((tag (gensym)) + (var (gensym)) + (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) + cases))) + `(block ,tag + (let ((,var nil)) + (declare (ignorable ,var)) + (tagbody + (handler-bind + ,(mapcar (lambda (annotated-case) + (list (cadr annotated-case) + `(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag + ,form)) + ,@(mapcan + (lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from + ,tag + ,(cond ((caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + , at body)) + (t + `(locally , at body))))))) + annotated-cases)))))))) Added: branches/save-image/src/org/armedbear/lisp/simple_list_remove_duplicates.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/simple_list_remove_duplicates.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,68 @@ +/* + * simple_list_remove_duplicates.java + * + * Copyright (C) 2004 Peter Graves + * $Id: simple_list_remove_duplicates.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### simple-list-remove-duplicates +public final class simple_list_remove_duplicates extends Primitive +{ + private simple_list_remove_duplicates() + { + super("simple-list-remove-duplicates", PACKAGE_SYS, false, "list"); + } + + @Override + public LispObject execute(LispObject list) throws ConditionThrowable + { + LispObject result = NIL; + while (list != NIL) { + LispObject item = list.car(); + boolean duplicate = false; + LispObject tail = list.cdr(); + while (tail != NIL) { + if (item.eql(tail.car())) { + duplicate = true; + break; + } + tail = tail.cdr(); + } + if (!duplicate) + result = new Cons(item, result); + list = list.cdr(); + } + return result.nreverse(); + } + + private static final Primitive SIMPLE_LIST_REMOVE_DUPLICATES = + new simple_list_remove_duplicates(); +} Added: branches/save-image/src/org/armedbear/lisp/socket.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/socket.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,83 @@ +;;; socket.lisp +;;; +;;; Copyright (C) 2004-2006 Peter Graves +;;; $Id: socket.lisp 11434 2008-12-07 23:24:31Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun get-socket-stream (socket &key (element-type 'character) (external-format :default)) + ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. +EXTERNAL-FORMAT must be of the same format as specified for OPEN." + (cond ((eq element-type 'character)) + ((equal element-type '(unsigned-byte 8))) + (t + (error 'simple-type-error + :format-control + ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8)."))) + (%socket-stream socket element-type external-format)) + +(defun make-socket (host port) + (%make-socket host port)) + +(defun make-server-socket (port) + (%make-server-socket port)) + +(defun socket-accept (socket) + (%socket-accept socket)) + +(defun socket-close (socket) + (%socket-close socket)) + +(defun server-socket-close (socket) + (%server-socket-close socket)) + +(declaim (inline %socket-address %socket-port)) +(defun %socket-address (socket addressName) + (java:jcall "getHostAddress" (java:jcall-raw addressName socket))) + +(defun %socket-port (socket portName) + (java:jcall portName socket)) + +(defun socket-local-address (socket) + "Returns the local address of the given socket as a dotted quad string." + (%socket-address socket "getLocalAddress")) + +(defun socket-peer-address (socket) + "Returns the peer address of the given socket as a dotted quad string." + (%socket-address socket "getInetAddress")) + +(defun socket-local-port (socket) + "Returns the local port number of the given socket." + (%socket-port socket "getLocalPort")) + +(defun socket-peer-port (socket) + "Returns the peer port number of the given socket." + (%socket-port socket "getPort")) + +(provide '#:socket) Added: branches/save-image/src/org/armedbear/lisp/socket_accept.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/socket_accept.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,63 @@ +/* + * socket_accept.java + * + * Copyright (C) 2004 Peter Graves + * $Id: socket_accept.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.ServerSocket; +import java.net.Socket; + +// ### %socket-accept +public final class socket_accept extends Primitive +{ + private socket_accept() + { + super("%socket-accept", PACKAGE_SYS, false, "socket"); + } + + @Override + public LispObject execute(LispObject first) + throws ConditionThrowable + { + ServerSocket serverSocket = + (ServerSocket) ((JavaObject)first).getObject(); + try { + Socket socket = serverSocket.accept(); + return new JavaObject(socket); + } + catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + private static final Primitive SOCKET_ACCEPT = new socket_accept(); +} Added: branches/save-image/src/org/armedbear/lisp/socket_close.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/socket_close.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,61 @@ +/* + * socket_close.java + * + * Copyright (C) 2004 Peter Graves + * $Id: socket_close.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.Socket; + +// ### %socket-close +public final class socket_close extends Primitive +{ + private socket_close() + { + super("%socket-close", PACKAGE_SYS, false, "socket"); + } + + @Override + public LispObject execute(LispObject first) + throws ConditionThrowable + { + Socket socket = (Socket) JavaObject.getObject(first); + try { + socket.close(); + return T; + } + catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + private static final Primitive SOCKET_CLOSE = new socket_close(); +} Added: branches/save-image/src/org/armedbear/lisp/socket_stream.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/socket_stream.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,65 @@ +/* + * socket_stream.java + * + * Copyright (C) 2004 Peter Graves + * $Id: socket_stream.java 11478 2008-12-25 11:46:10Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.net.Socket; + +// ### %socket-stream +public final class socket_stream extends Primitive +{ + private socket_stream() + { + super("%socket-stream", PACKAGE_SYS, false, "socket element-type external-format"); + } + + @Override + public LispObject execute(LispObject first, LispObject second, LispObject third) + throws ConditionThrowable + { + Socket socket = (Socket) ((JavaObject)first).getObject(); + LispObject elementType = second; // Checked by caller. + try { + Stream in = + new Stream(socket.getInputStream(), elementType, third); + Stream out = + new Stream(socket.getOutputStream(), elementType, third); + return new SocketStream(socket, in, out); + } + catch (Exception e) { + return error(new LispError(e.getMessage())); + } + } + + private static final Primitive SOCKET_STREAM = new socket_stream(); +} Added: branches/save-image/src/org/armedbear/lisp/software_type.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/software_type.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,51 @@ +/* + * software_type.java + * + * Copyright (C) 2004 Peter Graves + * $Id: software_type.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### software-type +public final class software_type extends Primitive +{ + private software_type() + { + super("software-type"); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return new SimpleString(System.getProperty("os.name")); + } + + private static final Primitive SOFTWARE_TYPE = new software_type(); +} Added: branches/save-image/src/org/armedbear/lisp/software_version.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/software_version.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,51 @@ +/* + * software_version.java + * + * Copyright (C) 2004 Peter Graves + * $Id: software_version.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### software-version +public final class software_version extends Primitive +{ + private software_version() + { + super("software-version"); + } + + @Override + public LispObject execute() throws ConditionThrowable + { + return new SimpleString(System.getProperty("os.version")); + } + + private static final Primitive SOFTWARE_VERSION = new software_version(); +} Added: branches/save-image/src/org/armedbear/lisp/sort.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/sort.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,224 @@ +;;; sort.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: sort.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun sort (sequence predicate &key key) + (if (listp sequence) + (sort-list sequence predicate key) + (quick-sort sequence 0 (length sequence) predicate key))) + +(defun stable-sort (sequence predicate &key key) + (if (listp sequence) + (sort-list sequence predicate key) + (quick-sort sequence 0 (length sequence) predicate key))) + +;; Adapted from SBCL. +(declaim (ftype (function (list) cons) last-cons-of)) +(defun last-cons-of (list) + (loop + (let ((rest (rest list))) + (if rest + (setf list rest) + (return list))))) + +;; Adapted from OpenMCL. +(defun merge-lists (list1 list2 pred key) + (declare (optimize (speed 3) (safety 0))) + (if (null key) + (merge-lists-no-key list1 list2 pred) + (cond ((null list1) + (values list2 (last-cons-of list2))) + ((null list2) + (values list1 (last-cons-of list1))) + (t + (let* ((result (cons nil nil)) + (p result) ; p points to last cell of result + (key1 (funcall key (car list1))) + (key2 (funcall key (car list2)))) + (declare (type list p)) + (loop + (cond ((funcall pred key2 key1) + (rplacd p list2) ; append the lesser list to last cell of + (setf p (cdr p)) ; result. Note: test must bo done for + (pop list2) ; list2 < list1 so merge will be + (unless list2 ; stable for list1 + (rplacd p list1) + (return (values (cdr result) (last-cons-of p)))) + (setf key2 (funcall key (car list2)))) + (t + (rplacd p list1) + (setf p (cdr p)) + (pop list1) + (unless list1 + (rplacd p list2) + (return (values (cdr result) (last-cons-of p)))) + (setf key1 (funcall key (car list1))))))))))) + +(defun merge-lists-no-key (list1 list2 pred) + (declare (optimize (speed 3) (safety 0))) + (cond ((null list1) + (values list2 (last-cons-of list2))) + ((null list2) + (values list1 (last-cons-of list1))) + (t + (let* ((result (cons nil nil)) + (p result) ; p points to last cell of result + (key1 (car list1)) + (key2 (car list2))) + (declare (type list p)) + (loop + (cond ((funcall pred key2 key1) + (rplacd p list2) ; append the lesser list to last cell of + (setf p (cdr p)) ; result. Note: test must bo done for + (pop list2) ; list2 < list1 so merge will be + (unless list2 ; stable for list1 + (rplacd p list1) + (return (values (cdr result) (last-cons-of p)))) + (setf key2 (car list2))) + (t + (rplacd p list1) + (setf p (cdr p)) + (pop list1) + (unless list1 + (rplacd p list2) + (return (values (cdr result) (last-cons-of p)))) + (setf key1 (car list1))))))))) + +;;; SORT-LIST uses a bottom up merge sort. First a pass is made over +;;; the list grabbing one element at a time and merging it with the next one +;;; form pairs of sorted elements. Then n is doubled, and elements are taken +;;; in runs of two, merging one run with the next to form quadruples of sorted +;;; elements. This continues until n is large enough that the inner loop only +;;; runs for one iteration; that is, there are only two runs that can be merged, +;;; the first run starting at the beginning of the list, and the second being +;;; the remaining elements. + +(defun sort-list (list pred key) + (when (or (eq key #'identity) (eq key 'identity)) + (setf key nil)) + (let ((head (cons nil list)) ; head holds on to everything + (n 1) ; bottom-up size of lists to be merged + unsorted ; unsorted is the remaining list to be + ; broken into n size lists and merged + list-1 ; list-1 is one length n list to be merged + last ; last points to the last visited cell + ) + (declare (type fixnum n)) + (loop + ;; start collecting runs of n at the first element + (setf unsorted (cdr head)) + ;; tack on the first merge of two n-runs to the head holder + (setf last head) + (let ((n-1 (1- n))) + (declare (type fixnum n-1)) + (loop + (setf list-1 unsorted) + (let ((temp (nthcdr n-1 list-1)) + list-2) + (cond (temp + ;; there are enough elements for a second run + (setf list-2 (cdr temp)) + (setf (cdr temp) nil) + (setf temp (nthcdr n-1 list-2)) + (cond (temp + (setf unsorted (cdr temp)) + (setf (cdr temp) nil)) + ;; the second run goes off the end of the list + (t (setf unsorted nil))) + (multiple-value-bind (merged-head merged-last) + (merge-lists list-1 list-2 pred key) + (setf (cdr last) merged-head) + (setf last merged-last)) + (if (null unsorted) (return))) + ;; if there is only one run, then tack it on to the end + (t (setf (cdr last) list-1) + (return))))) + (setf n (+ n n)) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two runs given n, so all the elements have been merged + ;; into one list. This may waste one outer iteration to realize. + (if (eq list-1 (cdr head)) + (return list-1)))))) + +;;; From ECL. +(defun quick-sort (seq start end pred key) + (unless key (setq key #'identity)) + (if (<= end (1+ start)) + seq + (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d))) + (block outer-loop + (loop (loop (decf k) + (unless (< j k) (return-from outer-loop)) + (when (funcall pred (funcall key (elt seq k)) kd) + (return))) + (loop (incf j) + (unless (< j k) (return-from outer-loop)) + (unless (funcall pred (funcall key (elt seq j)) kd) + (return))) + (let ((temp (elt seq j))) + (setf (elt seq j) (elt seq k) + (elt seq k) temp)))) + (setf (elt seq start) (elt seq j) + (elt seq j) d) + (quick-sort seq start j pred key) + (quick-sort seq (1+ j) end pred key)))) + +;;; From ECL. +(defun merge (result-type sequence1 sequence2 predicate + &key key + &aux (l1 (length sequence1)) (l2 (length sequence2))) + (unless key (setq key #'identity)) + (do ((newseq (make-sequence result-type (+ l1 l2))) + (j 0 (1+ j)) + (i1 0) + (i2 0)) + ((and (= i1 l1) (= i2 l2)) newseq) + (cond ((and (< i1 l1) (< i2 l2)) + (cond ((funcall predicate + (funcall key (elt sequence1 i1)) + (funcall key (elt sequence2 i2))) + (setf (elt newseq j) (elt sequence1 i1)) + (incf i1)) + ((funcall predicate + (funcall key (elt sequence2 i2)) + (funcall key (elt sequence1 i1))) + (setf (elt newseq j) (elt sequence2 i2)) + (incf i2)) + (t + (setf (elt newseq j) (elt sequence1 i1)) + (incf i1)))) + ((< i1 l1) + (setf (elt newseq j) (elt sequence1 i1)) + (incf i1)) + (t + (setf (elt newseq j) (elt sequence2 i2)) + (incf i2))))) Added: branches/save-image/src/org/armedbear/lisp/source-transform.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/source-transform.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,82 @@ +;;; source-transform.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: source-transform.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(export '(source-transform define-source-transform expand-source-transform)) + +(defun source-transform (name) + (get-function-info-value name :source-transform)) + +(defun set-source-transform (name transform) + (set-function-info-value name :source-transform transform)) + +(defsetf source-transform set-source-transform) + +(defmacro define-source-transform (name lambda-list &rest body) + (let* ((form (gensym)) + (env (gensym)) + (body (parse-defmacro lambda-list form body name 'defmacro + :environment env)) + (expander + (if (symbolp name) + `(lambda (,form) (block ,name ,body)) + `(lambda (,form) (block ,(cadr name) ,body))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (source-transform ',name) ,expander) + ',name))) + +(defun expand-source-transform-1 (form) + (let ((expander nil) + (newdef nil)) + (cond ((atom form) + (values form nil)) + ((and (consp (%car form)) + (eq (caar form) 'SETF) + (setf expander (source-transform (%car form)))) + (values (setf newdef (funcall expander form)) + (not (eq newdef form)))) + ((and (symbolp (%car form)) + (setf expander (source-transform (%car form)))) + (values (setf newdef (funcall expander form)) + (not (eq newdef form)))) + (t + (values form nil))))) + +(defun expand-source-transform (form) + (let ((expanded-p nil)) + (loop + (multiple-value-bind (expansion exp-p) (expand-source-transform-1 form) + (if exp-p + (setf form expansion + expanded-p t) + (return)))) + (values form expanded-p))) Added: branches/save-image/src/org/armedbear/lisp/step.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/step.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,38 @@ +;;; step.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: step.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From SBCL. + +(in-package "SYSTEM") + +(defmacro step (form) + `(let () + ,form)) Added: branches/save-image/src/org/armedbear/lisp/stream_element_type.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/stream_element_type.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,56 @@ +/* + * stream_element_type.java + * + * Copyright (C) 2004-2005 Peter Graves + * $Id: stream_element_type.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### stream-element-type +public final class stream_element_type extends Primitive +{ + private stream_element_type() + { + super("stream-element-type", "stream"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + try { + return ((Stream)arg).getElementType(); + } + catch (ClassCastException e) { + return type_error(arg, Symbol.STREAM); + } + } + + private static final Primitive STREAM_ELEMENT_TYPE = new stream_element_type(); +} Added: branches/save-image/src/org/armedbear/lisp/stream_external_format.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/stream_external_format.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,55 @@ +/* + * stream_external_format.java + * + * Copyright (C) 2004 Peter Graves + * $Id: stream_external_format.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### stream-external-format +public final class stream_external_format extends Primitive +{ + private stream_external_format() + { + super("stream-external-format", "stream"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof Stream) + return Keyword.DEFAULT; + else + return error(new TypeError(arg, Symbol.STREAM)); + } + + private static final Primitive STREAM_EXTERNAL_FORMAT = + new stream_external_format(); +} Added: branches/save-image/src/org/armedbear/lisp/strings.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/strings.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,168 @@ +;;; strings.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: strings.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun string-upcase (string &key (start 0) end) + (%string-upcase string start end)) + +(defun string-downcase (string &key (start 0) end) + (%string-downcase string start end)) + +(defun string-capitalize (string &key (start 0) end) + (%string-capitalize string start end)) + +(defun nstring-upcase (string &key (start 0) end) + (%nstring-upcase string start end)) + +(defun nstring-downcase (string &key (start 0) end) + (%nstring-downcase string start end)) + +(defun nstring-capitalize (string &key (start 0) end) + (%nstring-capitalize string start end)) + +(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2) + (%string= string1 string2 start1 end1 start2 end2)) + +(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string/= string1 string2 start1 end1 start2 end2))) + +(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string-equal string1 string2 start1 end1 start2 end2))) + +(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string-not-equal string1 string2 start1 end1 start2 end2))) + +(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string< string1 string2 start1 end1 start2 end2))) + +(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string> string1 string2 start1 end1 start2 end2))) + +(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string<= string1 string2 start1 end1 start2 end2))) + +(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string>= string1 string2 start1 end1 start2 end2))) + +(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string-lessp string1 string2 start1 end1 start2 end2))) + +(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string-greaterp string1 string2 start1 end1 start2 end2))) + +(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string-not-lessp string1 string2 start1 end1 start2 end2))) + +(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2) + (let* ((string1 (string string1)) + (string2 (string string2)) + (end1 (or end1 (length string1))) + (end2 (or end2 (length string2)))) + (%string-not-greaterp string1 string2 start1 end1 start2 end2))) + + +;;; STRING-LEFT-TRIM, STRING-RIGHT-TRIM, STRING-TRIM (from OpenMCL) + +(defun string-left-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + left end." + (setq string (string string)) + (setq end (length string)) + (do ((index 0 (+ index 1))) + ((or (= index end) (not (find (aref string index) char-bag))) + (subseq string index end)))) + +(defun string-right-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + right end." + (setq string (string string)) + (setq end (length string)) + (do ((index (- end 1) (- index 1))) + ((or (< index 0) (not (find (aref string index) char-bag))) + (subseq string 0 (+ index 1))))) + +(defun string-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns a + copy of the string with the characters in the set removed from both + ends." + (setq string (string string)) + (setq end (length string)) + (let (left-end right-end) + (do ((index 0 (+ index 1))) + ((or (= index end) (not (find (aref string index) char-bag))) + (setq left-end index))) + (do ((index (- end 1) (- index 1))) + ((or (< index left-end) (not (find (aref string index) char-bag))) + (setq right-end index))) + (subseq string left-end (+ right-end 1)))) Added: branches/save-image/src/org/armedbear/lisp/sublis.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/sublis.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,74 @@ +;;; sublis.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: sublis.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "COMMON-LISP") + +;;; From CMUCL. + +(defun sublis (alist tree &key key (test #'eql) (test-not nil notp)) + (labels ((s (subtree) + (let* ((key-val (sys::apply-key key subtree)) + (assoc (if notp + (assoc key-val alist :test-not test-not) + (assoc key-val alist :test test)))) + (cond (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (s tree))) + +(defmacro nsublis-macro () + (let ((key-tmp (gensym))) + `(let ((,key-tmp (sys::apply-key key subtree))) + (if notp + (assoc ,key-tmp alist :test-not test-not) + (assoc ,key-tmp alist :test test))))) + +(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp)) + (let (temp) + (labels ((s (subtree) + (cond ((setq temp (nsublis-macro)) + (cdr temp)) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (setq temp (nsublis-macro)) + (setf (cdr last) (cdr temp)))) + (if (setq temp (nsublis-macro)) + (return (setf (cdr last) (cdr temp))) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree)))) Added: branches/save-image/src/org/armedbear/lisp/subst.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/subst.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,125 @@ +;;; subst.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: subst.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; From CMUCL. + +(defmacro satisfies-the-test (item elt) + (let ((key-tmp (gensym))) + `(let ((,key-tmp (apply-key key ,elt))) + (cond (testp (funcall test ,item ,key-tmp)) + (notp (not (funcall test-not ,item ,key-tmp))) + (t (funcall test ,item ,key-tmp)))))) + +(defun %subst (new old tree key test testp test-not notp) + (cond ((satisfies-the-test old tree) new) + ((atom tree) tree) + (t (let ((car (%subst new old (car tree) key test testp test-not notp)) + (cdr (%subst new old (cdr tree) key test testp test-not notp))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +(defun subst (new old tree &key key (test #'eql testp) (test-not nil notp)) + (%subst new old tree key test testp test-not notp)) + +(defun %subst-if (new test tree key) + (cond ((funcall test (apply-key key tree)) new) + ((atom tree) tree) + (t (let ((car (%subst-if new test (car tree) key)) + (cdr (%subst-if new test (cdr tree) key))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +(defun subst-if (new test tree &key key) + (%subst-if new test tree key)) + +(defun %subst-if-not (new test tree key) + (cond ((not (funcall test (apply-key key tree))) new) + ((atom tree) tree) + (t (let ((car (%subst-if-not new test (car tree) key)) + (cdr (%subst-if-not new test (cdr tree) key))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +(defun subst-if-not (new test tree &key key) + (%subst-if-not new test tree key)) + +(defun nsubst (new old tree &key key (test #'eql testp) (test-not nil notp)) + (labels ((s (subtree) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (satisfies-the-test old subtree) + (setf (cdr last) new))) + (if (satisfies-the-test old subtree) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))) + +(defun nsubst-if (new test tree &key key) + (labels ((s (subtree) + (cond ((funcall test (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (funcall test (apply-key key subtree)) + (setf (cdr last) new))) + (if (funcall test (apply-key key subtree)) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))) + +(defun nsubst-if-not (new test tree &key key) + (labels ((s (subtree) + (cond ((not (funcall test (apply-key key subtree))) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (not (funcall test (apply-key key subtree))) + (setf (cdr last) new))) + (if (not (funcall test (apply-key key subtree))) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree))) Added: branches/save-image/src/org/armedbear/lisp/substitute.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/substitute.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,152 @@ +;;; substitute.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: substitute.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + + +(in-package "COMMON-LISP") + +(export '(substitute substitute-if substitute-if-not)) + +;;; From CMUCL. + +(defmacro real-count (count) + `(cond ((null ,count) most-positive-fixnum) + ((sys::fixnump ,count) (if (minusp ,count) 0 ,count)) + ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum)) + (t ,count))) + +(defun list-substitute* (pred new list start end count key test test-not old) + (let* ((result (list nil)) + elt + (splice result) + (list list)) ; Get a local list for a stepper. + (do ((index 0 (1+ index))) + ((= index start)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (do ((index start (1+ index))) + ((or (= index end) (null list) (= count 0))) + (setq elt (car list)) + (setq splice + (cdr (rplacd splice + (list + (cond + ((case pred + (normal + (if test-not + (not + (funcall test-not old (sys::apply-key key elt))) + (funcall test old (sys::apply-key key elt)))) + (if (funcall test (sys::apply-key key elt))) + (if-not (not (funcall test (sys::apply-key key elt))))) + (setq count (1- count)) + new) + (t elt)))))) + (setq list (cdr list))) + (do () + ((null list)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (cdr result))) + + +;;; Replace old with new in sequence moving from left to right by incrementer +;;; on each pass through the loop. Called by all three substitute functions. +(defun vector-substitute* (pred new sequence incrementer left right length + start end count key test test-not old) + (let ((result (sys::make-sequence-like sequence length)) + (index left)) + (do () + ((= index start)) + (setf (aref result index) (aref sequence index)) + (setq index (+ index incrementer))) + (do ((elt)) + ((or (= index end) (= count 0))) + (setq elt (aref sequence index)) + (setf (aref result index) + (cond ((case pred + (normal + (if test-not + (not (funcall test-not old (sys::apply-key key elt))) + (funcall test old (sys::apply-key key elt)))) + (if (funcall test (sys::apply-key key elt))) + (if-not (not (funcall test (sys::apply-key key elt))))) + (setq count (1- count)) + new) + (t elt))) + (setq index (+ index incrementer))) + (do () + ((= index right)) + (setf (aref result index) (aref sequence index)) + (setq index (+ index incrementer))) + result)) + +(defmacro subst-dispatch (pred) + `(if (listp sequence) + (if from-end + (nreverse (list-substitute* ,pred new (reverse sequence) + (- length end) + (- length start) + count key test test-not old)) + (list-substitute* ,pred new sequence start end count key test test-not + old)) + (if from-end + (vector-substitute* ,pred new sequence -1 (1- length) + -1 length (1- end) + (1- start) count key test test-not old) + (vector-substitute* ,pred new sequence 1 0 length length + start end count key test test-not old)))) + + +(defun substitute (new old sequence &key from-end (test #'eql) test-not + (start 0) count end key) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count))) + (subst-dispatch 'normal))) + + +(defun substitute-if (new test sequence &key from-end (start 0) end count key) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count)) + test-not + old) + (subst-dispatch 'if))) + + +(defun substitute-if-not (new test sequence &key from-end (start 0) + end count key) + (let* ((length (length sequence)) + (end (or end length)) + (count (real-count count)) + test-not + old) + (subst-dispatch 'if-not))) Added: branches/save-image/src/org/armedbear/lisp/subtypep.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/subtypep.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,780 @@ +;;; subtypep.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: subtypep.lisp 11586 2009-01-24 20:36:52Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defparameter *known-types* (make-hash-table :test 'eq)) + +(defun initialize-known-types () + (let ((ht (make-hash-table :test 'eq))) + (dolist (i '((ARITHMETIC-ERROR ERROR) + (ARRAY) + (BASE-STRING STRING) + (BIGNUM INTEGER) + (BIT FIXNUM) + (BIT-VECTOR VECTOR) + (BOOLEAN SYMBOL) + (BUILT-IN-CLASS CLASS) + (CELL-ERROR ERROR) + (CHARACTER) + (CLASS STANDARD-OBJECT) + (COMPILED-FUNCTION FUNCTION) + (COMPLEX NUMBER) + (CONDITION) + (CONS LIST) + (CONTROL-ERROR ERROR) + (DIVISION-BY-ZERO ARITHMETIC-ERROR) + (DOUBLE-FLOAT FLOAT) + (END-OF-FILE STREAM-ERROR) + (ERROR SERIOUS-CONDITION) + (EXTENDED-CHAR CHARACTER NIL) + (FILE-ERROR ERROR) + (FIXNUM INTEGER) + (FLOAT REAL) + (FLOATING-POINT-INEXACT ARITHMETIC-ERROR) + (FLOATING-POINT-INVALID-OPERATION ARITHMETIC-ERROR) + (FLOATING-POINT-OVERFLOW ARITHMETIC-ERROR) + (FLOATING-POINT-UNDERFLOW ARITHMETIC-ERROR) + (FUNCTION) + (GENERIC-FUNCTION FUNCTION) + (HASH-TABLE) + (INTEGER RATIONAL) + (KEYWORD SYMBOL) + (LIST SEQUENCE) + (LONG-FLOAT FLOAT) + (NIL-VECTOR SIMPLE-STRING) + (NULL BOOLEAN LIST) + (NUMBER) + (PACKAGE) + (PACKAGE-ERROR ERROR) + (PARSE-ERROR ERROR) + (PATHNAME) + (PRINT-NOT-READABLE ERROR) + (PROGRAM-ERROR ERROR) + (RANDOM-STATE) + (RATIO RATIONAL) + (RATIONAL REAL) + (READER-ERROR PARSE-ERROR STREAM-ERROR) + (READTABLE) + (REAL NUMBER) + (RESTART) + (SERIOUS-CONDITION CONDITION) + (SHORT-FLOAT FLOAT) + (SIMPLE-ARRAY ARRAY) + (SIMPLE-BASE-STRING SIMPLE-STRING BASE-STRING) + (SIMPLE-BIT-VECTOR BIT-VECTOR SIMPLE-ARRAY) + (SIMPLE-CONDITION CONDITION) + (SIMPLE-ERROR SIMPLE-CONDITION ERROR) + (SIMPLE-STRING BASE-STRING STRING SIMPLE-ARRAY) + (SIMPLE-TYPE-ERROR SIMPLE-CONDITION TYPE-ERROR) + (SIMPLE-VECTOR VECTOR SIMPLE-ARRAY) + (SIMPLE-WARNING SIMPLE-CONDITION WARNING) + (SINGLE-FLOAT FLOAT) + (STANDARD-CHAR CHARACTER) + (STANDARD-CLASS CLASS) + (STANDARD-GENERIC-FUNCTION GENERIC-FUNCTION) + (STANDARD-OBJECT) + (STORAGE-CONDITION SERIOUS-CONDITION) + (STREAM) + (STREAM-ERROR ERROR) + (STRING VECTOR) + (STRUCTURE-CLASS CLASS STANDARD-OBJECT) + (STYLE-WARNING WARNING) + (SYMBOL) + (TWO-WAY-STREAM STREAM) + (TYPE-ERROR ERROR) + (UNBOUND-SLOT CELL-ERROR) + (UNBOUND-VARIABLE CELL-ERROR) + (UNDEFINED-FUNCTION CELL-ERROR) + (VECTOR ARRAY SEQUENCE) + (WARNING CONDITION))) + (setf (gethash (%car i) ht) (%cdr i))) + (setf *known-types* ht))) + +(initialize-known-types) + +(defun known-type-p (type) + (multiple-value-bind (value present-p) (gethash type *known-types*) + present-p)) + +(defun sub-interval-p (i1 i2) + (let (low1 high1 low2 high2) + (if (null i1) + (setq low1 '* high1 '*) + (if (null (cdr i1)) + (setq low1 (car i1) high1 '*) + (setq low1 (car i1) high1 (cadr i1)))) + (if (null i2) + (setq low2 '* high2 '*) + (if (null (cdr i2)) + (setq low2 (car i2) high2 '*) + (setq low2 (car i2) high2 (cadr i2)))) + (when (and (consp low1) (integerp (%car low1))) + (setq low1 (1+ (car low1)))) + (when (and (consp low2) (integerp (%car low2))) + (setq low2 (1+ (car low2)))) + (when (and (consp high1) (integerp (%car high1))) + (setq high1 (1- (car high1)))) + (when (and (consp high2) (integerp (%car high2))) + (setq high2 (1- (car high2)))) + (cond ((eq low1 '*) + (unless (eq low2 '*) + (return-from sub-interval-p nil))) + ((eq low2 '*)) + ((consp low1) + (if (consp low2) + (when (< (%car low1) (%car low2)) + (return-from sub-interval-p nil)) + (when (< (%car low1) low2) + (return-from sub-interval-p nil)))) + ((if (consp low2) + (when (<= low1 (%car low2)) + (return-from sub-interval-p nil)) + (when (< low1 low2) + (return-from sub-interval-p nil))))) + (cond ((eq high1 '*) + (unless (eq high2 '*) + (return-from sub-interval-p nil))) + ((eq high2 '*)) + ((consp high1) + (if (consp high2) + (when (> (%car high1) (%car high2)) + (return-from sub-interval-p nil)) + (when (> (%car high1) high2) + (return-from sub-interval-p nil)))) + ((if (consp high2) + (when (>= high1 (%car high2)) + (return-from sub-interval-p nil)) + (when (> high1 high2) + (return-from sub-interval-p nil))))) + (return-from sub-interval-p t))) + +(defun dimension-subtypep (dim1 dim2) + (cond ((eq dim2 '*) + t) + ((equal dim1 dim2) + t) + ((integerp dim2) + (and (listp dim1) (= (length dim1) dim2))) + ((eql dim1 0) + (null dim2)) + ((integerp dim1) + (and (consp dim2) + (= (length dim2) dim1) + (equal dim2 (make-list dim1 :initial-element '*)))) + ((and (consp dim1) (consp dim2) (= (length dim1) (length dim2))) + (do* ((list1 dim1 (cdr list1)) + (list2 dim2 (cdr list2)) + (e1 (car list1) (car list1)) + (e2 (car list2) (car list2))) + ((null list1) t) + (unless (or (eq e2 '*) (eql e1 e2)) + (return nil)))) + (t + nil))) + +(defun simple-subtypep (type1 type2) + (if (eq type1 type2) + t + (multiple-value-bind (type1-supertypes type1-known-p) + (gethash type1 *known-types*) + (if type1-known-p + (if (memq type2 type1-supertypes) + t + (dolist (supertype type1-supertypes) + (when (simple-subtypep supertype type2) + (return t)))) + nil)))) + +;; (defstruct ctype +;; ((:constructor make-ctype (super type))) +;; super +;; type) + +(defun make-ctype (super type) + (cons super type)) + +(defun ctype-super (ctype) + (car ctype)) + +(defun ctype-type (ctype) + (cdr ctype)) + +(defun ctype (type) + (cond ((classp type) + nil) + (t + (let ((tp (if (atom type) type (car type)))) + (case tp + ((ARRAY VECTOR STRING SIMPLE-ARRAY SIMPLE-STRING BASE-STRING + SIMPLE-BASE-STRING BIT-VECTOR SIMPLE-BIT-VECTOR NIL-VECTOR) + (make-ctype 'ARRAY type)) + ((REAL INTEGER BIT FIXNUM SIGNED-BYTE UNSIGNED-BYTE BIGNUM RATIO + FLOAT SINGLE-FLOAT DOUBLE-FLOAT SHORT-FLOAT LONG-FLOAT) + (make-ctype 'REAL type)) + (COMPLEX + (make-ctype 'COMPLEX + (if (atom type) '* (cadr type)))) + (FUNCTION + (make-ctype 'FUNCTION type))))))) + +(defun csubtypep-array (ct1 ct2) + (let ((type1 (normalize-type (ctype-type ct1))) + (type2 (normalize-type (ctype-type ct2)))) + (when (eq type1 type2) + (return-from csubtypep-array (values t t))) + (let (t1 t2 i1 i2) + (if (atom type1) + (setf t1 type1 i1 nil) + (setf t1 (car type1) i1 (cdr type1))) + (if (atom type2) + (setf t2 type2 i2 nil) + (setf t2 (car type2) i2 (cdr type2))) + (cond ((and (classp t1) (eq (%class-name t1) 'array) (eq t2 'array)) + (values (equal i2 '(* *)) t)) + ((and (memq t1 '(array simple-array)) (eq t2 'array)) + (let ((e1 (car i1)) + (e2 (car i2)) + (d1 (cadr i1)) + (d2 (cadr i2))) + (cond ((and (eq e2 '*) (eq d2 '*)) + (values t t)) + ((or (eq e2 '*) + (equal e1 e2) + (equal (upgraded-array-element-type e1) + (upgraded-array-element-type e2))) + (values (dimension-subtypep d1 d2) t)) + (t + (values nil t))))) + ((and (memq t1 '(simple-base-string base-string simple-string string nil-vector)) + (memq t2 '(simple-base-string base-string simple-string string nil-vector))) + (if (and (simple-subtypep t1 t2) + (or (eql (car i1) (car i2)) + (eq (car i2) '*))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))) + ((and (memq t1 '(array simple-array)) (eq t2 'string)) + (let ((element-type (car i1)) + (dim (cadr i1)) + (size (car i2))) + (unless (%subtypep element-type 'character) + (return-from csubtypep-array (values nil t))) + (when (integerp size) + (if (and (consp dim) (= (length dim) 1) (eql (%car dim) size)) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))))) + ((and (eq t1 'simple-array) (eq t2 'simple-string)) + (let ((element-type (car i1)) + (dim (cadr i1)) + (size (car i2))) + (unless (%subtypep element-type 'character) + (return-from csubtypep-array (values nil t))) + (when (integerp size) + (if (and (consp dim) (= (length dim) 1) (eql (%car dim) size)) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))))) + ((and (memq t1 '(string simple-string nil-vector)) (eq t2 'array)) + (let ((element-type (car i2)) + (dim (cadr i2)) + (size (car i1))) + (unless (eq element-type '*) + (return-from csubtypep-array (values nil t))) + (when (integerp size) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) + (= (length dim) 1) + (or (eq (%car dim) '*) + (eql (%car dim) size)))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))))) + ((and (memq t1 '(bit-vector simple-bit-vector)) (eq t2 'array)) + (let ((element-type (car i2)) + (dim (cadr i2)) + (size (car i1))) + (unless (or (memq element-type '(bit *)) + (equal element-type '(integer 0 1))) + (return-from csubtypep-array (values nil t))) + (when (integerp size) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) + (= (length dim) 1) + (or (eq (%car dim) '*) + (eql (%car dim) size)))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))))) + ((eq t2 'simple-array) + (case t1 + (simple-array + (let ((e1 (car i1)) + (e2 (car i2)) + (d1 (cadr i1)) + (d2 (cadr i2))) + (cond ((and (eq e2 '*) (eq d2 '*)) + (values t t)) + ((or (eq e2 '*) + (equal e1 e2) + (equal (upgraded-array-element-type e1) + (upgraded-array-element-type e2))) + (values (dimension-subtypep d1 d2) t)) + (t + (values nil t))))) + ((simple-string simple-bit-vector nil-vector) + (let ((element-type (car i2)) + (dim (cadr i2)) + (size (car i1))) + (unless (eq element-type '*) + (return-from csubtypep-array (values nil t))) + (when (integerp size) + (if (or (eq dim '*) + (and (consp dim) (= (length dim) 1) (eql (%car dim) size))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from csubtypep-array (values t t)) + (return-from csubtypep-array (values nil t)))))) + (t + (values nil t)))) + ((eq t2 'bit-vector) + (let ((size1 (car i1)) + (size2 (car i2))) + (case t1 + ((bit-vector simple-bit-vector) + (values (if (or (eq size2 '*) (eql size1 size2)) + t + nil) t)) + (t + (values nil t))))) + ((eq t2 'simple-bit-vector) + (let ((size1 (car i1)) + (size2 (car i2))) + (if (and (eq t1 'simple-bit-vector) + (or (eq size2 '*) + (eql size1 size2))) + (values t t) + (values nil t)))) + ((classp t2) + (let ((class-name (%class-name t2))) + (cond ((eq class-name t1) + (values t t)) + ((and (eq class-name 'array) + (memq t1 '(array simple-array vector simple-vector string + simple-string simple-base-string bit-vector + simple-bit-vector))) + (values t t)) + ((eq class-name 'vector) + (cond ((memq t1 '(string simple-string)) + (values t t)) + ((eq t1 'array) + (let ((dim (cadr i1))) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (values t t) + (values nil t)))) + (t + (values nil t)))) + ((and (eq class-name 'simple-vector) + (eq t1 'simple-array)) + (let ((dim (cadr i1))) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (values t t) + (values nil t)))) + ((and (eq class-name 'bit-vector) + (eq t1 'simple-bit-vector)) + (values t t)) + ((and (eq class-name 'string) + (memq t1 '(string simple-string))) + (values t t)) + (t + (values nil nil))))) + (t + (values nil nil)))))) + +(defun csubtypep-function (ct1 ct2) + (let ((type1 (ctype-type ct1)) + (type2 (ctype-type ct2))) + (cond ((and (listp type1) (atom type2)) + (values t t)) + (t + (values nil nil))))) + +(defun csubtypep-complex (ct1 ct2) + (let ((type1 (cdr ct1)) + (type2 (cdr ct2))) + (cond ((or (null type2) (eq type2 '*)) + (values t t)) + ((eq type1 '*) + (values nil t)) + (t + (subtypep type1 type2))))) + +(defun csubtypep (ctype1 ctype2) + (cond ((null (and ctype1 ctype2)) + (values nil nil)) + ((neq (ctype-super ctype1) (ctype-super ctype2)) + (values nil t)) + ((eq (ctype-super ctype1) 'array) + (csubtypep-array ctype1 ctype2)) + ((eq (ctype-super ctype1) 'function) + (csubtypep-function ctype1 ctype2)) + ((eq (ctype-super ctype1) 'complex) + (csubtypep-complex ctype1 ctype2)) + (t + (values nil nil)))) + +(defun %subtypep (type1 type2) + (when (or (eq type1 type2) + (null type1) + (eq type2 t) + (and (classp type2) (eq (%class-name type2) t))) + (return-from %subtypep (values t t))) + (when (classp type1) + (setf type1 (%class-name type1))) + (when (classp type2) + (setf type2 (%class-name type2))) + (let ((ct1 (ctype type1)) + (ct2 (ctype type2))) + (multiple-value-bind (subtype-p valid-p) + (csubtypep ct1 ct2) + (when valid-p + (return-from %subtypep (values subtype-p valid-p))))) + (when (and (atom type1) (atom type2)) + (let* ((classp-1 (classp type1)) + (classp-2 (classp type2)) + class1 class2) + (when (and (setf class1 (if classp-1 + type1 + (and (symbolp type1) (find-class type1 nil)))) + (setf class2 (if classp-2 + type2 + (and (symbolp type2) (find-class type2 nil))))) + (return-from %subtypep (values (subclassp class1 class2) t))) + (when (or classp-1 classp-2) + (let ((t1 (if classp-1 (%class-name type1) type1)) + (t2 (if classp-2 (%class-name type2) type2))) + (return-from %subtypep (values (simple-subtypep t1 t2) t)))))) + (setf type1 (normalize-type type1) + type2 (normalize-type type2)) + (when (eq type1 type2) + (return-from %subtypep (values t t))) + (let (t1 t2 i1 i2) + (if (atom type1) + (setf t1 type1 i1 nil) + (setf t1 (%car type1) i1 (%cdr type1))) + (if (atom type2) + (setf t2 type2 i2 nil) + (setf t2 (%car type2) i2 (%cdr type2))) + (cond ((null t1) + (return-from %subtypep (values t t))) + ((eq t1 'atom) + (return-from %subtypep (values (eq t2 t) t))) + ((eq t2 'atom) + (return-from %subtypep (cond ((memq t1 '(cons list sequence)) + (values nil t)) + (t + (values t t))))) + ((eq t1 'member) + (dolist (e i1) + (unless (typep e type2) (return-from %subtypep (values nil t)))) + (return-from %subtypep (values t t))) + ((eq t1 'eql) + (case t2 + (EQL + (return-from %subtypep (values (eql (car i1) (car i2)) t))) + (SATISFIES + (return-from %subtypep (values (funcall (car i2) (car i1)) t))) + (t + (return-from %subtypep (values (typep (car i1) type2) t))))) + ((eq t1 'or) + (dolist (tt i1) + (multiple-value-bind (tv flag) (%subtypep tt type2) + (unless tv (return-from %subtypep (values tv flag))))) + (return-from %subtypep (values t t))) + ((eq t1 'and) + (dolist (tt i1) + (let ((tv (%subtypep tt type2))) + (when tv (return-from %subtypep (values t t))))) + (return-from %subtypep (values nil nil))) + ((eq t1 'cons) + (case t2 + ((LIST SEQUENCE) + (return-from %subtypep (values t t))) + (CONS + (when (and (%subtypep (car i1) (car i2)) + (%subtypep (cadr i1) (cadr i2))) + (return-from %subtypep (values t t))))) + (return-from %subtypep (values nil (known-type-p t2)))) + ((eq t2 'or) + (dolist (tt i2) + (let ((tv (%subtypep type1 tt))) + (when tv (return-from %subtypep (values t t))))) + (return-from %subtypep (values nil nil))) + ((eq t2 'and) + (dolist (tt i2) + (multiple-value-bind (tv flag) (%subtypep type1 tt) + (unless tv (return-from %subtypep (values tv flag))))) + (return-from %subtypep (values t t))) + ((null (or i1 i2)) + (return-from %subtypep (values (simple-subtypep t1 t2) t))) + ((eq t2 'SEQUENCE) + (cond ((memq t1 '(null cons list)) + (values t t)) + ((memq t1 '(simple-base-string base-string simple-string string nil-vector)) + (values t t)) + ((memq t1 '(bit-vector simple-bit-vector)) + (values t t)) + ((memq t1 '(array simple-array)) + (cond ((and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) + (values t t)) + ((and (cdr i1) (eql (cadr i1) 1)) + (values t t)) + (t + (values nil t)))) + (t (values nil (known-type-p t1))))) + ((eq t1 'integer) + (cond ((memq t2 '(integer rational real number)) + (values (sub-interval-p i1 i2) t)) + ((or (eq t2 'bignum) + (and (classp t2) (eq (%class-name t2) 'bignum))) + (values + (or (sub-interval-p i1 (list '* (list most-negative-fixnum))) + (sub-interval-p i1 (list (list most-positive-fixnum) '*))) + t)) + (t + (values nil (known-type-p t2))))) + ((eq t1 'rational) + (if (memq t2 '(rational real number)) + (values (sub-interval-p i1 i2) t) + (values nil (known-type-p t2)))) + ((eq t1 'float) + (if (memq t2 '(float real number)) + (values (sub-interval-p i1 i2) t) + (values nil (known-type-p t2)))) + ((memq t1 '(single-float short-float)) + (if (memq t2 '(single-float short-float float real number)) + (values (sub-interval-p i1 i2) t) + (values nil (known-type-p t2)))) + ((memq t1 '(double-float long-float)) + (if (memq t2 '(double-float long-float float real number)) + (values (sub-interval-p i1 i2) t) + (values nil (known-type-p t2)))) + ((eq t1 'real) + (if (memq t2 '(real number)) + (values (sub-interval-p i1 i2) t) + (values nil (known-type-p t2)))) + ((eq t1 'complex) + (cond ((eq t2 'number) + (values t t)) + ((eq t2 'complex) + (cond ((equal i2 '(*)) + (values t t)) + ((equal i1 '(*)) + (values nil t)) + (t + (values (subtypep (car i1) (car i2)) t)))))) + ((and (classp t1) + (eq (%class-name t1) 'array) + (eq t2 'array)) + (values (equal i2 '(* *)) t)) + ((and (memq t1 '(array simple-array)) (eq t2 'array)) + (let ((e1 (car i1)) + (e2 (car i2)) + (d1 (cadr i1)) + (d2 (cadr i2))) + (cond ((and (eq e2 '*) (eq d2 '*)) + (values t t)) + ((or (eq e2 '*) + (equal e1 e2) + (equal (upgraded-array-element-type e1) + (upgraded-array-element-type e2))) + (values (dimension-subtypep d1 d2) t)) + (t + (values nil t))))) + ((and (memq t1 '(array simple-array)) (eq t2 'string)) + (let ((element-type (car i1)) + (dim (cadr i1)) + (size (car i2))) + (unless (%subtypep element-type 'character) + (return-from %subtypep (values nil t))) + (when (integerp size) + (if (and (consp dim) (= (length dim) 1) (eql (%car dim) size)) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))))) + ((and (eq t1 'simple-array) (eq t2 'simple-string)) + (let ((element-type (car i1)) + (dim (cadr i1)) + (size (car i2))) + (unless (%subtypep element-type 'character) + (return-from %subtypep (values nil t))) + (when (integerp size) + (if (and (consp dim) (= (length dim) 1) (eql (%car dim) size)) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))))) + ((and (memq t1 '(string simple-string)) (eq t2 'array)) + (let ((element-type (car i2)) + (dim (cadr i2)) + (size (car i1))) + (unless (eq element-type '*) + (return-from %subtypep (values nil t))) + (when (integerp size) + (if (or (eq dim '*) + (and (consp dim) (= (length dim) 1) (eql (%car dim) size))) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))))) + ((eq t2 'simple-array) + (case t1 + (simple-array + (let ((e1 (car i1)) + (e2 (car i2)) + (d1 (cadr i1)) + (d2 (cadr i2))) + (cond ((and (eq e2 '*) (eq d2 '*)) + (values t t)) + ((or (eq e2 '*) + (equal e1 e2) + (equal (upgraded-array-element-type e1) + (upgraded-array-element-type e2))) + (values (dimension-subtypep d1 d2) t)) + (t + (values nil t))))) + ((simple-string simple-bit-vector) + (let ((element-type (car i2)) + (dim (cadr i2)) + (size (car i1))) + (unless (eq element-type '*) + (return-from %subtypep (values nil t))) + (when (integerp size) + (if (or (eq dim '*) + (and (consp dim) (= (length dim) 1) (eql (%car dim) size))) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))) + (when (or (null size) (eql size '*)) + (if (or (eq dim '*) + (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (return-from %subtypep (values t t)) + (return-from %subtypep (values nil t)))))) + (t + (values nil t)))) + ((eq t2 'bit-vector) + (let ((size1 (car i1)) + (size2 (car i2))) + (case t1 + ((bit-vector simple-bit-vector) + (values (if (or (eq size2 '*) (eql size1 size2)) + t + nil) t)) + (t + (values nil t))))) + ((classp t2) + (let ((class-name (%class-name t2))) + (cond ((eq class-name t1) + (values t t)) + ((and (eq class-name 'array) + (memq t1 '(array simple-array vector simple-vector string + simple-string simple-base-string bit-vector + simple-bit-vector))) + (values t t)) + ((eq class-name 'vector) + (cond ((memq t1 '(string simple-string)) + (values t t)) + ((memq t1 '(array simple-array)) + (let ((dim (cadr i1))) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (values t t) + (values nil t)))) + (t + (values nil t)))) + ((and (eq class-name 'simple-vector) + (eq t1 'simple-array)) + (let ((dim (cadr i1))) + (if (or (eql dim 1) + (and (consp dim) (= (length dim) 1))) + (values t t) + (values nil t)))) + ((and (eq class-name 'bit-vector) + (eq t1 'simple-bit-vector)) + (values t t)) + ((and (eq class-name 'string) + (memq t1 '(string simple-string))) + (values t t)) + (t + (values nil nil))))) + (t + (values nil nil))))) + +(defun subtypep (type1 type2 &optional environment) + (declare (ignore environment)) + (%subtypep type1 type2)) Added: branches/save-image/src/org/armedbear/lisp/tailp.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/tailp.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,38 @@ +;;; tailp.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: tailp.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "COMMON-LISP") + +(defun tailp (object list) + (do ((list list (cdr list))) + ((atom list) (eql list object)) + (if (eql object list) + (return t)))) Added: branches/save-image/src/org/armedbear/lisp/time.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/time.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,145 @@ +;;; time.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: time.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package #:system) + +(defconstant seconds-in-week (* 60 60 24 7)) +(defconstant weeks-offset 2145) +(defconstant seconds-offset 432000) +(defconstant minutes-per-day (* 24 60)) +(defconstant quarter-days-per-year (1+ (* 365 4))) +(defconstant quarter-days-per-century 146097) +(defconstant november-17-1858 678882) +(defconstant weekday-november-17-1858 2) + +;;; decode-universal-time universal-time &optional time-zone +;;; => second minute hour date month year day daylight-p zone +;;; If time-zone is not supplied, it defaults to the current time zone adjusted +;;; for daylight saving time. If time-zone is supplied, daylight saving time +;;; information is ignored. The daylight saving time flag is nil if time-zone +;;; is supplied. +(defun decode-universal-time (universal-time &optional time-zone) + (let (seconds-west daylight) + (if time-zone + (setf seconds-west (* time-zone 3600) + daylight nil) + (multiple-value-bind (time-zone daylight-p) (default-time-zone) + (setf seconds-west (* time-zone 3600) + daylight daylight-p))) + (multiple-value-bind (weeks secs) + (truncate (+ (- universal-time seconds-west) seconds-offset) + seconds-in-week) + (let ((weeks (+ weeks weeks-offset))) + (multiple-value-bind (t1 second) + (truncate secs 60) + (let ((tday (truncate t1 minutes-per-day))) + (multiple-value-bind (hour minute) + (truncate (- t1 (* tday minutes-per-day)) 60) + (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) + (tcent (truncate t2 quarter-days-per-century))) + (setq t2 (mod t2 quarter-days-per-century)) + (setq t2 (+ (- t2 (mod t2 4)) 3)) + (let* ((year (+ (* tcent 100) + (truncate t2 quarter-days-per-year))) + (days-since-mar0 + (1+ (truncate (mod t2 quarter-days-per-year) 4))) + (day (mod (+ tday weekday-november-17-1858) 7)) + (t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-bind (month t3) + (truncate t3 153) + (let ((date (1+ (truncate t3 5)))) + (values second minute hour date month year day + daylight + (if daylight + (1+ (/ seconds-west 3600)) + (/ seconds-west 3600)))))))))))))) + +(defun get-decoded-time () + (decode-universal-time (get-universal-time))) + +(defun pick-obvious-year (year) + (declare (type (mod 100) year)) + (let* ((current-year (nth-value 5 (get-decoded-time))) + (guess (+ year (* (truncate (- current-year 50) 100) 100)))) + (declare (type (integer 1900 9999) current-year guess)) + (if (> (- current-year guess) 50) + (+ guess 100) + guess))) + +(defun leap-years-before (year) + (let ((years (- year 1901))) + (+ (- (truncate years 4) + (truncate years 100)) + (truncate (+ years 300) 400)))) + +(defvar *days-before-month* + #.(let ((reversed-result nil) + (sum 0)) + (push nil reversed-result) + (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31)) + (push sum reversed-result) + (incf sum days-in-month)) + (coerce (nreverse reversed-result) 'simple-vector))) + +(defun encode-universal-time (second minute hour date month year + &optional time-zone) + (let* ((year (if (< year 100) + (pick-obvious-year year) + year)) + (days (+ (1- date) + (aref *days-before-month* month) + (if (> month 2) + (leap-years-before (1+ year)) + (leap-years-before year)) + (* (- year 1900) 365))) + (hours (+ hour (* days 24)))) + (cond (time-zone + (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))) + ((> year 2037) + (labels ((leap-year-p (year) + (cond ((zerop (mod year 400)) t) + ((zerop (mod year 100)) nil) + ((zerop (mod year 4)) t) + (t nil)))) + (let* ((fake-year (if (leap-year-p year) 2036 2037)) + (fake-time (encode-universal-time second minute hour + date month fake-year))) + (+ fake-time + (* 86400 (+ (* 365 (- year fake-year)) + (- (leap-years-before year) + (leap-years-before fake-year)))))))) + (t + (+ second (* (+ minute (* (+ hours (default-time-zone)) 60)) 60)))))) Added: branches/save-image/src/org/armedbear/lisp/top-level.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/top-level.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,426 @@ +;;; top-level.lisp +;;; +;;; Copyright (C) 2003-2006 Peter Graves +;;; $Id: top-level.lisp 11667 2009-02-18 21:41:34Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SB-ACLREPL (originally written by Kevin Rosenberg). + +(in-package #:system) + +(defvar *inspect-break* nil) + +(defvar *inspected-object-stack* nil) + +(defvar *inspected-object* nil) + +(in-package #:top-level) + +(import '(sys::%format sys::list-traced-functions sys::trace-1 sys::untrace-1 sys::untrace-all)) + +(defvar *null-cmd* (gensym)) + +(defvar *command-char* #\:) + +(defvar *cmd-number* 1 + "Number of the next command") + +(defun prompt-package-name () + (let ((result (package-name *package*))) + (dolist (nickname (package-nicknames *package*)) + (when (< (length nickname) (length result)) + (setf result nickname))) + result)) + +(defun repl-prompt-fun (stream) + (fresh-line stream) + (when (> *debug-level* 0) + (%format stream "[~D~A] " + *debug-level* + (if sys::*inspect-break* "i" ""))) + (%format stream "~A(~D): " (prompt-package-name) *cmd-number*)) + +(defparameter *repl-prompt-fun* #'repl-prompt-fun) + +(defun peek-char-non-whitespace (stream) + (loop + (let ((c (read-char stream nil))) + (when (null c) ; control d + (quit)) + (unless (eql c #\space) + (unread-char c stream) + (return c))))) + +(defun apropos-command (args) + (when args (apropos args))) + +(defun continue-command (args) + (when args + (let ((n (read-from-string args))) + (let ((restarts (compute-restarts))) + (when (< -1 n (length restarts)) + (invoke-restart-interactively (nth n restarts))))))) + +(defun describe-command (args) + (let ((obj (eval (read-from-string args)))) + (describe obj))) + +(defun error-command (ignored) + (declare (ignore ignored)) + (when *debug-condition* + (let* ((s (%format nil "~A" *debug-condition*)) + (len (length s))) + (when (plusp len) + (setf (schar s 0) (char-upcase (schar s 0))) + (unless (eql (schar s (1- len)) #\.) + (setf s (concatenate 'string s ".")))) + (%format *debug-io* "~A~%" s)) + (show-restarts (compute-restarts) *debug-io*))) + +(defun backtrace-command (args) + (let ((count (or (and args (ignore-errors (parse-integer args))) + 8)) + (n 0)) + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-readably* nil) + (*print-structure* nil) + (*print-array* nil)) + (dolist (frame *saved-backtrace*) + (fresh-line *debug-io*) + (let ((prefix (format nil "~3D: (" n))) + (pprint-logical-block (*debug-io* nil :prefix prefix :suffix ")") + (ignore-errors + (prin1 (car frame) *debug-io*) + (let ((args (cdr frame))) + (if (listp args) + (format *debug-io* "~{ ~_~S~}" args) + (format *debug-io* " ~S" args)))))) + (incf n) + (when (>= n count) + (return)))))) + (values)) + +(defun frame-command (args) + (let* ((n (or (and args (ignore-errors (parse-integer args))) + 0)) + (frame (nth n *saved-backtrace*))) + (when frame + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-readably* nil) + (*print-structure* nil)) + (fresh-line *debug-io*) + (pprint-logical-block (*debug-io* nil :prefix "(" :suffix ")") + (prin1 (car frame) *debug-io*) + (let ((args (cdr frame))) + (if (listp args) + (format *debug-io* "~{ ~_~S~}" args) + (format *debug-io* " ~S" args)))))) + (setf *** ** + ** * + * frame))) + (values)) + +(defun inspect-command (args) + (let ((obj (eval (read-from-string args)))) + (inspect obj))) + +(defun istep-command (args) + (sys::istep args)) + +(defun macroexpand-command (args) + (let ((s (with-output-to-string (stream) + (pprint (macroexpand (read-from-string args)) stream)))) + (write-string (string-left-trim '(#\return #\linefeed) s))) + (values)) + +(defvar *old-package* nil) + +(defun package-command (args) + (cond ((null args) + (%format *standard-output* "The ~A package is current.~%" + (package-name *package*))) + ((and *old-package* (string= args "-") (null (find-package "-"))) + (rotatef *old-package* *package*)) + (t + (when (and (plusp (length args)) (eql (char args 0) #\:)) + (setf args (subseq args 1))) + (setf args (nstring-upcase args)) + (let ((pkg (find-package args))) + (if pkg + (setf *old-package* *package* + *package* pkg) + (%format *standard-output* "Unknown package ~A.~%" args)))))) + +(defun reset-command (ignored) + (declare (ignore ignored)) + (invoke-restart 'top-level)) + +(defun exit-command (ignored) + (declare (ignore ignored)) + (exit)) + +(defvar *old-pwd* nil) + +(defun cd-command (args) + (cond ((null args) + (setf args (if (featurep :windows) + "C:\\" + (namestring (user-homedir-pathname))))) + ((string= args "-") + (if *old-pwd* + (setf args (namestring *old-pwd*)) + (progn + (%format t "No previous directory.") + (return-from cd-command)))) + ((and (> (length args) 1) (string= (subseq args 0 2) "~/") + (setf args (concatenate 'string + (namestring (user-homedir-pathname)) + (subseq args 2)))))) + (let ((dir (probe-directory args))) + (if dir + (progn + (unless (equal dir *default-pathname-defaults*) + (setf *old-pwd* *default-pathname-defaults* + *default-pathname-defaults* dir)) + (%format t "~A" (namestring *default-pathname-defaults*))) + (%format t "Error: no such directory (~S).~%" args)))) + +(defun ls-command (args) + (let ((args (if (stringp args) args "")) + (ls-program (if (featurep :windows) "dir" "ls"))) + (run-shell-command (concatenate 'string ls-program " " args) + :directory *default-pathname-defaults*)) + (values)) + +(defun tokenize (string) + (do* ((res nil) + (string (string-left-trim " " string) + (string-left-trim " " (subseq string end))) + (end (position #\space string) (position #\space string))) + ((zerop (length string)) (nreverse res)) + (unless end + (setf end (length string))) + (push (subseq string 0 end) res))) + +(defvar *last-files-loaded* nil) + +(defun ld-command (args) + (let ((files (if args (tokenize args) *last-files-loaded*))) + (setf *last-files-loaded* files) + (dolist (file files) + (load file)))) + +(defun cf-command (args) + (let ((files (tokenize args))) + (dolist (file files) + (compile-file file)))) + +(defvar *last-files-cloaded* nil) + +(defun cload-command (args) + (let ((files (if args (tokenize args) *last-files-cloaded*))) + (setf *last-files-cloaded* files) + (dolist (file files) + (load (compile-file file))))) + +(defun rq-command (args) + (let ((modules (tokenize (string-upcase args)))) + (dolist (module modules) + (require module)))) + +(defun pwd-command (ignored) + (declare (ignore ignored)) + (%format t "~A~%" (namestring *default-pathname-defaults*))) + +(defun trace-command (args) + (if (null args) + (%format t "~A~%" (list-traced-functions)) + (dolist (f (tokenize args)) + (trace-1 (read-from-string f))))) + +(defun untrace-command (args) + (if (null args) + (untrace-all) + (dolist (f (tokenize args)) + (untrace-1 (read-from-string f))))) + +(defconstant spaces (make-string 32 :initial-element #\space)) + +(defun pad (string width) + (if (< (length string) width) + (concatenate 'string string (subseq spaces 0 (- width (length string)))) + string)) + +(defun %help-command (prefix) + (let ((prefix-len (length prefix))) + (when (and (> prefix-len 0) + (eql (schar prefix 0) *command-char*)) + (setf prefix (subseq prefix 1)) + (decf prefix-len)) + (%format t "~% COMMAND ABBR DESCRIPTION~%") + (dolist (entry *command-table*) + (when (or (null prefix) + (and (<= prefix-len (length (entry-name entry))) + (string-equal prefix (subseq (entry-name entry) 0 prefix-len)))) + (%format t " ~A~A~A~%" + (pad (entry-name entry) 12) + (pad (entry-abbreviation entry) 5) + (entry-help entry)))) + (%format t "~%Commands must be prefixed by the command character, which is '~A'~A.~%~%" + *command-char* (if (eql *command-char* #\:) " by default" "")))) + +(defun help-command (&optional ignored) + (declare (ignore ignored)) + (%help-command nil)) + +(defparameter *command-table* + '(("apropos" "ap" apropos-command "apropos") + ("bt" nil backtrace-command "backtrace n stack frames (default 8)") + ("cd" nil cd-command "change default directory") + ("cf" nil cf-command "compile file(s)") + ("cload" "cl" cload-command "compile and load file(s)") + ("continue" "cont" continue-command "invoke restart n") + ("describe" "de" describe-command "describe an object") + ("error" "err" error-command "print the current error message") + ("exit" "ex" exit-command "exit lisp") + ("frame" "fr" frame-command "set the value of cl:* to be frame n (default 0)") + ("help" "he" help-command "print this help") + ("inspect" "in" inspect-command "inspect an object") + ("istep" "i" istep-command "navigate within inspection of an object") + ("ld" nil ld-command "load a file") + ("ls" nil ls-command "list directory") + ("macroexpand" "ma" macroexpand-command "macroexpand an expression") + ("package" "pa" package-command "change *PACKAGE*") + ("pwd" "pw" pwd-command "print current directory") + ("reset" "res" reset-command "return to top level") + ("rq" nil rq-command "require a module") + ("trace" "tr" trace-command "trace function(s)") + ("untrace" "untr" untrace-command "untrace function(s)"))) + +(defun entry-name (entry) + (first entry)) + +(defun entry-abbreviation (entry) + (second entry)) + +(defun entry-command (entry) + (third entry)) + +(defun entry-help (entry) + (fourth entry)) + +(defun find-command (string) + (let ((len (length string))) + (when (and (> len 0) + (eql (schar string 0) *command-char*)) + (setf string (subseq string 1) + len (1- len))) + (dolist (entry *command-table*) + (when (or (string= string (entry-abbreviation entry)) + (string= string (entry-name entry))) + (return (entry-command entry)))))) + +(defun process-cmd (form) + (when (eq form *null-cmd*) + (return-from process-cmd t)) + (when (and (stringp form) + (> (length form) 1) + (eql (char form 0) *command-char*)) + (let* ((pos (or (position #\space form) + (position #\return form))) + (command-string (subseq form 0 pos)) + (args (if pos (subseq form (1+ pos)) nil))) + (let ((command (find-command command-string))) + (cond ((null command) + (%format t "Unknown top-level command \"~A\".~%" command-string) + (%format t "Type \"~Ahelp\" for a list of available commands." *command-char*)) + (t + (when args + (setf args (string-trim (list #\space #\return) args)) + (when (zerop (length args)) + (setf args nil))) + (funcall command args))))) + t)) + +(defun read-cmd (stream) + (let ((c (peek-char-non-whitespace stream))) + (cond ((eql c *command-char*) + (read-line stream)) + ((eql c #\newline) + (read-line stream) + *null-cmd*) + (t + (read stream nil))))) + +(defun repl-read-form-fun (in out) + (loop + (funcall *repl-prompt-fun* out) + (finish-output out) + (let ((form (read-cmd in))) + (setf (charpos out) 0) + (unless (eq form *null-cmd*) + (incf *cmd-number*)) + (cond ((process-cmd form)) + ((and (> *debug-level* 0) + (fixnump form)) + (let ((n form) + (restarts (compute-restarts))) + (if (< -1 n (length restarts)) + (invoke-restart-interactively (nth n restarts)) + (return form)))) + (t + (return form)))))) + +(defparameter *repl-read-form-fun* #'repl-read-form-fun) + +(defun repl (&optional (in *standard-input*) (out *standard-output*)) + (let* ((*print-length* 10)) + (loop + (let* ((form (funcall *repl-read-form-fun* in out)) + (results (multiple-value-list (sys:interactive-eval form)))) + (dolist (result results) + (fresh-line out) + (prin1 result out)))))) + +(defun top-level-loop () + (fresh-line) + (unless sys:*noinform* + (%format t "Type \"~Ahelp\" for a list of available commands.~%" *command-char*)) + (loop + (setf *inspected-object* nil + *inspected-object-stack* nil + *inspect-break* nil) + (with-simple-restart (top-level + "Return to top level.") + (if (featurep :j) + (handler-case + (repl) + (stream-error (c) (declare (ignore c)) (return-from top-level-loop))) + (repl))))) Added: branches/save-image/src/org/armedbear/lisp/trace.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/trace.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,145 @@ +;;; trace.lisp +;;; +;;; Copyright (C) 2003-2007 Peter Graves +;;; $Id: trace.lisp 11668 2009-02-19 07:29:20Z ehuelsmann $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(export 'untraced-function) ;; For FIND-GENERIC-FUNCTION in clos.lisp. + +(require "FORMAT") + +(defvar *trace-info-hashtable* (make-hash-table :test #'equal)) + +(defstruct trace-info name untraced-function breakp) + +(defvar *trace-depth* 0 + "Current depth of stack push for use of TRACE facility.") + +(defun list-traced-functions () + (copy-list *traced-names*)) + +(defmacro trace (&rest args) + (if args + (expand-trace args) + `(list-traced-functions))) + +(defun expand-trace (args) + (let ((results ()) + (breakp nil)) + (let ((index (position :break args))) + (when index + (setf breakp (nth (1+ index) args)) + (setf args (append (subseq args 0 index) (subseq args (+ index 2)))))) + (dolist (arg args) + (push `(trace-1 ',arg (make-trace-info :name ',arg + :breakp ,breakp)) results)) + `(list ,@(nreverse results)))) + +(defun trace-1 (name info) + (unless (fboundp name) + (error "~S is not the name of a function." name)) + (if (member name *traced-names* :test #'equal) + (format t "~S is already being traced." name) + (let* ((untraced-function (fdefinition name)) + (traced-function + (traced-function name info untraced-function))) + (setf (trace-info-untraced-function info) untraced-function) + (let ((*warn-on-redefinition* nil)) + (setf (fdefinition name) traced-function)) + (setf (gethash name *trace-info-hashtable*) info) + (push name *traced-names*))) + name) + +(defun traced-function (name info untraced-function) + (let ((breakp (trace-info-breakp info)) + (*trace-depth* *trace-depth*)) + (lambda (&rest args) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-structure* nil)) + (%format *trace-output* (indent "~D: ~S~%") *trace-depth* + (cons name args)))) + (when breakp + (break)) + (incf *trace-depth*) + (let ((results (multiple-value-list + (unwind-protect + (apply untraced-function args) + (decf *trace-depth*))))) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-structure* nil)) + (%format *trace-output* (indent "~D: ~A returned") *trace-depth* name) + (if results + (dolist (result results) + (%format *trace-output* " ~S" result)) + (%format *trace-output* " no values")) + (terpri *trace-output*))) + (values-list results))))) + +(defun untraced-function (name) + (let ((info (gethash name *trace-info-hashtable*))) + (and info (trace-info-untraced-function info)))) + +(defun trace-redefined-update (name untraced-function) + (when (and *traced-names* (find name *traced-names* :test #'equal)) + (let* ((info (gethash name *trace-info-hashtable*)) + (traced-function (traced-function name info untraced-function))) + (setf (trace-info-untraced-function info) untraced-function) + (let ((*traced-names* '())) + (setf (fdefinition name) traced-function))))) + +(defun indent (string) + (concatenate 'string + (make-string (* (1+ *trace-depth*) 2) :initial-element #\space) + string)) + +(defmacro untrace (&rest args) + (cond ((null args) + `(untrace-all)) + (t + `(progn ,@(mapcar (lambda (arg) `(untrace-1 ',arg)) args) t)))) + +(defun untrace-all () + (dolist (arg *traced-names*) + (untrace-1 arg)) + t) + +(defun untrace-1 (name) + (cond ((member name *traced-names* :test #'equal) + (let* ((trace-info (gethash name *trace-info-hashtable*)) + (untraced-function (trace-info-untraced-function trace-info)) + (*warn-on-redefinition* nil)) + (remhash name *trace-info-hashtable*) + (setf *traced-names* (remove name *traced-names*)) + (setf (fdefinition name) untraced-function))) + (t + (format t "~S is not being traced.~%" name))) + nil) Added: branches/save-image/src/org/armedbear/lisp/tree-equal.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/tree-equal.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,59 @@ +;;; tree-equal.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: tree-equal.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +;;; From SBCL. + +(defun tree-equal-test-not (x y test-not) + (cond ((consp x) + (and (consp y) + (tree-equal-test-not (car x) (car y) test-not) + (tree-equal-test-not (cdr x) (cdr y) test-not))) + ((consp y) nil) + ((not (funcall test-not x y)) t) + (t ()))) + +(defun tree-equal-test (x y test) + (cond ((consp x) + (and (consp y) + (tree-equal-test (car x) (car y) test) + (tree-equal-test (cdr x) (cdr y) test))) + ((consp y) nil) + ((funcall test x y) t) + (t ()))) + +(defun tree-equal (x y &key (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error "test and test-not both supplied")) + (if test-not + (tree-equal-test-not x y test-not) + (tree-equal-test x y test))) Added: branches/save-image/src/org/armedbear/lisp/truncate.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/truncate.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,58 @@ +/* + * truncate.java + * + * Copyright (C) 2004 Peter Graves + * $Id: truncate.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### truncate number &optional divisor +public final class truncate extends Primitive +{ + private truncate() + { + super("truncate", "number &optional divisor"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return arg.truncate(Fixnum.ONE); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + return first.truncate(second); + } + + private static final Primitive TRUNCATE = new truncate(); +} Added: branches/save-image/src/org/armedbear/lisp/typep.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/typep.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,189 @@ +;;; typep.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: typep.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun simple-array-p (object) + (and (arrayp object) + (not (array-has-fill-pointer-p object)) + (multiple-value-bind (displaced-to offset) (array-displacement object) + (and (null displaced-to) (zerop offset))))) + +(defun in-interval-p (x interval) + (if (endp interval) + t + (let ((low (%car interval)) + (high (if (endp (%cdr interval)) '* (%cadr interval)))) + (cond ((eq low '*)) + ((consp low) + (when (<= x (%car low)) + (return-from in-interval-p nil))) + ((when (< x low) + (return-from in-interval-p nil)))) + (cond ((eq high '*)) + ((consp high) + (when (>= x (%car high)) + (return-from in-interval-p nil))) + ((when (> x high) + (return-from in-interval-p nil)))) + t))) + +(defun match-dimensions (dim pat) + (if (null dim) + (null pat) + (and (or (eq (car pat) '*) + (eql (car dim) (car pat))) + (match-dimensions (cdr dim) (cdr pat))))) + +(defun %typep (object type) + (when (atom type) + (when (eq type 'values) + (error 'simple-error + :format-control "The symbol ~S is not valid as a type specifier." + :format-arguments (list type))) + (unless (and (symbolp type) (get type 'deftype-definition)) + (return-from %typep (simple-typep object type)))) + (setf type (normalize-type type)) + (when (atom type) + (return-from %typep (simple-typep object type))) + (let ((tp (%car type)) + (i (%cdr type))) + (case tp + (INTEGER + (and (integerp object) (in-interval-p object i))) + (RATIONAL + (and (rationalp object) (in-interval-p object i))) + ((FLOAT SINGLE-FLOAT DOUBLE-FLOAT SHORT-FLOAT LONG-FLOAT) + (and (floatp object) (in-interval-p object i))) + (REAL + (and (realp object) (in-interval-p object i))) + (COMPLEX + (and (complexp object) + (or (null i) + (and (typep (realpart object) i) + (typep (imagpart object) i))))) + (CONS + (and (consp object) + (or (null (car i)) (eq (car i) '*) (%typep (%car object) (car i))) + (or (null (cadr i)) (eq (cadr i) '*) (%typep (%cdr object) (cadr i))))) + (SIMPLE-BIT-VECTOR + (and (simple-bit-vector-p object) + (or (endp i) + (eq (%car i) '*) + (eql (%car i) (array-dimension object 0))))) + (BIT-VECTOR + (and (bit-vector-p object) + (or (endp i) + (eq (%car i) '*) + (eql (%car i) (array-dimension object 0))))) + (SIMPLE-STRING + (and (simple-string-p object) + (or (endp i) + (eq (%car i) '*) + (eql (%car i) (array-dimension object 0))))) + (STRING + (and (stringp object) + (or (endp i) + (eq (%car i) '*) + (eql (%car i) (array-dimension object 0))))) + (SIMPLE-VECTOR + (and (simple-vector-p object) + (or (endp i) + (eq (%car i) '*) + (eql (%car i) (array-dimension object 0))))) + (VECTOR + (and (vectorp object) + (or (endp i) + (eq (%car i) '*) + (and (eq (%car i) t) (not (stringp object)) (not (bit-vector-p object))) + (and (stringp object) (%subtypep (%car i) 'character)) + (equal (array-element-type object) (%car i))) + (or (endp (cdr i)) + (eq (%cadr i) '*) + (eql (%cadr i) (array-dimension object 0))))) + (SIMPLE-ARRAY + (and (simple-array-p object) + (or (endp i) + (eq (%car i) '*) + (equal (array-element-type object) (upgraded-array-element-type (%car i)))) + (or (endp (cdr i)) + (eq (%cadr i) '*) + (if (listp (%cadr i)) + (match-dimensions (array-dimensions object) (%cadr i)) + (eql (array-rank object) (%cadr i)))))) + (ARRAY + (and (arrayp object) + (or (endp i) + (eq (%car i) '*) + (equal (array-element-type object) (upgraded-array-element-type (%car i)))) + (or (endp (cdr i)) + (eq (%cadr i) '*) + (if (listp (%cadr i)) + (match-dimensions (array-dimensions object) (%cadr i)) + (eql (array-rank object) (%cadr i)))))) + (AND + (dolist (type i) + (unless (%typep object type) + (return-from %typep nil))) + t) + (OR + (dolist (type i) + (when (%typep object type) + (return-from %typep t))) + nil) + (NOT + (not (%typep object (car i)))) + (MEMBER + (member object i)) + (EQL + (eql object (car i))) + (SATISFIES + (unless (symbolp (car i)) + (error 'simple-type-error + :datum (car i) + :expected-type 'symbol + :format-control "The SATISFIES predicate name is not a symbol: ~S" + :format-arguments (list (car i)))) + (funcall (car i) object)) + (NIL-VECTOR + (and (simple-typep object 'nil-vector) + (or (endp i) + (eql (%car i) (length object))))) + ((FUNCTION VALUES) + (error 'simple-error + :format-control "~S types are not a legal argument to TYPEP: ~S" + :format-arguments (list tp type))) + (t + nil)))) + +(defun typep (object type &optional environment) + (declare (ignore environment)) + (%typep object type)) Added: branches/save-image/src/org/armedbear/lisp/unbound_slot_instance.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/unbound_slot_instance.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,54 @@ +/* + * unbound_slot_instance.java + * + * Copyright (C) 2004 Peter Graves + * $Id: unbound_slot_instance.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +// ### unbound-slot-instance +public final class unbound_slot_instance extends Primitive +{ + private unbound_slot_instance() + { + super("unbound-slot-instance"); + } + + @Override + public LispObject execute(LispObject arg) throws ConditionThrowable + { + if (arg instanceof UnboundSlot) + return ((UnboundSlot)arg).getInstance(); + return error(new TypeError(arg, Symbol.UNBOUND_SLOT)); + } + + private static final unbound_slot_instance CELL_ERROR_NAME = + new unbound_slot_instance(); +} Added: branches/save-image/src/org/armedbear/lisp/upgraded-complex-part-type.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/upgraded-complex-part-type.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,38 @@ +;;; upgraded-complex-part-type.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: upgraded-complex-part-type.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(defun upgraded-complex-part-type (typespec &optional environment) + (declare (ignore environment)) + (if (subtypep typespec 'REAL) + typespec + (error 'simple-error + :format-control "The type ~S is not a subtype of ~S." + :format-arguments (list typespec 'REAL)))) Added: branches/save-image/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,554 @@ +/* + * RandomAccessCharacterFile.java + * + * Copyright (C) 2008 Hideo at Yokohama + * Copyright (C) 2008 Erik Huelsmann + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp.util; + +import java.io.IOException; +import java.io.PushbackInputStream; +import java.io.OutputStream; +import java.io.RandomAccessFile; +import java.io.PushbackReader; +import java.io.Reader; +import java.io.StringReader; +import java.io.Writer; +import java.nio.ByteBuffer; +import java.nio.CharBuffer; +import java.nio.channels.FileChannel; +import java.nio.charset.Charset; +import java.nio.charset.CharsetDecoder; +import java.nio.charset.CharsetEncoder; +import java.nio.charset.CoderResult; +import java.nio.charset.CodingErrorAction; + +public class RandomAccessCharacterFile { + + private class RandomAccessInputStream extends PushbackInputStream { + + public RandomAccessInputStream() { + super(null); + } + + private byte[] read_buf = new byte[1]; + + @Override + public int read() throws IOException { + int len = read(read_buf); + if (len == 1) { + // byte is signed, char is unsigned, int is signed. + // buf can hold 0xff, we want it as 0xff in int, not -1. + return 0xff & (int) read_buf[0]; + } else { + return -1; + } + } + + @Override + public int read(byte[] b, int off, int len) throws IOException { + return RandomAccessCharacterFile.this.read(b, off, len); + } + + @Override + public void unread(int b) throws IOException { + RandomAccessCharacterFile.this.unreadByte((byte)b); + } + + @Override + public void unread(byte[] b, int off, int len) throws IOException { + for (int i = 0; i < len; i++) + this.unread(b[off+i]); + } + + @Override + public void unread(byte[] b) throws IOException { + this.unread(b, 0, b.length); + } + + @Override + public int available() throws IOException { + return (int)(RandomAccessCharacterFile.this.length() + - RandomAccessCharacterFile.this.position()); + } + + @Override + public synchronized void mark(int readlimit) { + } + + @Override + public boolean markSupported() { + return false; + } + + @Override + public synchronized void reset() throws IOException { + throw new IOException("Operation not supported"); + } + + @Override + public long skip(long n) throws IOException { + RandomAccessCharacterFile.this.position(RandomAccessCharacterFile.this.position()+n); + return n; + } + + @Override + public int read(byte[] b) throws IOException { + return this.read(b, 0, b.length); + } + + @Override + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } + } + + private class RandomAccessOutputStream extends OutputStream { + + private RandomAccessOutputStream() { + } + + private byte[] buf = new byte[1]; + public void write(int b) throws IOException { + buf[0] = (byte)b; + write(buf); + } + + @Override + public void write(byte[] b, int off, int len) throws IOException { + RandomAccessCharacterFile.this.write(b, off, len); + } + + @Override + public void flush() throws IOException { + RandomAccessCharacterFile.this.flush(); + } + + @Override + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } + } + + // dummy reader which we need to call the Pushback constructor + // because a null value won't work + private static Reader staticReader = new StringReader(""); + + private class RandomAccessReader extends PushbackReader { + + private RandomAccessReader() { + // because we override all methods of Pushbackreader, + // staticReader will never be referenced + super(staticReader); + } + + @Override + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } + + private char[] read_buf = new char[1]; + + @Override + public int read() throws IOException { + int n = this.read(read_buf); + + if (n == 1) + return read_buf[0]; + else + return -1; + } + + @Override + public void unread(int c) throws IOException { + RandomAccessCharacterFile.this.unreadChar((char)c); + } + + @Override + public void unread(char[] cbuf, int off, int len) throws IOException { + for (int i = 0; i < len; i++) + this.unread(cbuf[off+i]); + } + + @Override + public void unread(char[] cbuf) throws IOException { + this.unread(cbuf, 0, cbuf.length); + } + + @Override + public int read(CharBuffer target) throws IOException { + //FIXME: to be implemented + throw new IOException("Not implemented"); + } + + @Override + public int read(char[] cbuf) throws IOException { + return RandomAccessCharacterFile.this.read(cbuf, 0, cbuf.length); + } + + + + @Override + public int read(char[] cb, int off, int len) throws IOException { + return RandomAccessCharacterFile.this.read(cb, off, len); + } + } + + private class RandomAccessWriter extends Writer { + + private RandomAccessWriter() { + } + + public void close() throws IOException { + RandomAccessCharacterFile.this.close(); + } + + public void flush() throws IOException { + RandomAccessCharacterFile.this.flush(); + } + + @Override + public void write(char[] cb, int off, int len) throws IOException { + RandomAccessCharacterFile.this.write(cb, off, len); + } + + } + + + final static int BUFSIZ = 4*1024; // setting this to a small value like 8 is helpful for testing. + + private RandomAccessWriter writer; + private RandomAccessReader reader; + private RandomAccessInputStream inputStream; + private RandomAccessOutputStream outputStream; + private FileChannel fcn; + private long fcnpos; /* where fcn is pointing now. */ + private long fcnsize; /* the file size */ + + private Charset cset; + private CharsetEncoder cenc; + private CharsetDecoder cdec; + + /** + * bbuf is treated as a cache of the file content. + * If it points to somewhere in the middle of the file, it holds the copy of the file content, + * even when you are writing a large chunk of data. If you write in the middle of a file, + * bbuf first gets filled with contents of the data, and only after that any new data is + * written on bbuf. + * The exception is when you are appending data at the end of the file. + */ + private ByteBuffer bbuf; + private boolean bbufIsDirty; /* whether bbuf holds data that must be written. */ + private long bbufpos; /* where the beginning of bbuf is pointing in the file now. */ + + public RandomAccessCharacterFile(RandomAccessFile raf, String encoding) throws IOException { + + fcn = raf.getChannel(); + fcnpos = fcn.position(); + fcnsize = fcn.size(); + + cset = (encoding == null) ? Charset.defaultCharset() : Charset.forName(encoding); + cdec = cset.newDecoder(); + cdec.onMalformedInput(CodingErrorAction.REPLACE); + cdec.onUnmappableCharacter(CodingErrorAction.REPLACE); + cenc = cset.newEncoder(); + + bbuf = ByteBuffer.allocate(BUFSIZ); + + // there is no readable data available in the buffers. + bbuf.flip(); + + // there is no write pending data in the buffers. + bbufIsDirty = false; + + bbufpos = fcn.position(); + + reader = new RandomAccessReader(); + writer = new RandomAccessWriter(); + inputStream = new RandomAccessInputStream(); + outputStream = new RandomAccessOutputStream(); + } + + public Writer getWriter() { + return writer; + } + + public PushbackReader getReader() { + return reader; + } + + public PushbackInputStream getInputStream() { + return inputStream; + } + + public OutputStream getOutputStream() { + return outputStream; + } + + public void close() throws IOException { + internalFlush(true); + fcn.close(); + } + + public void flush() throws IOException { + internalFlush(false); + } + + private int read(char[] cb, int off, int len) throws IOException { + CharBuffer cbuf = CharBuffer.wrap(cb, off, len); + boolean decodeWasUnderflow = false; + boolean atEof = false; + while ((cbuf.remaining() > 0) && dataIsAvailableForRead() + && ! atEof) { + if ((bbuf.remaining() == 0) || decodeWasUnderflow) { + // need to read from the file. + flushBbuf(); // in case bbuf is dirty. + // update bbufpos. + bbufpos += bbuf.position(); + int partialBytes = bbuf.remaining(); // partialBytes > 0 happens when decodeWasUnderflow + // if reads and writes are mixed, we may need to seek first. + if (bbufpos + partialBytes != fcnpos) { + fcn.position(bbufpos + partialBytes); + } + // need to read data from file. + bbuf.compact(); + //###FIXME: we're ignoring end-of-stream here!!! + atEof = (fcn.read(bbuf) == -1); + bbuf.flip(); + fcnpos = bbufpos + bbuf.remaining(); + } + CoderResult r = cdec.decode(bbuf, cbuf, pointingAtEOF() ); + decodeWasUnderflow = (CoderResult.UNDERFLOW == r); + } + if (cbuf.remaining() == len) { + return -1; + } else { + return len - cbuf.remaining(); + } + } + + private boolean dataIsAvailableForRead() throws IOException { + return ((bbuf.remaining() > 0) || (fcn.position() < fcn.size())); + } + + private boolean pointingAtEOF() { + return (bbuf.remaining() == 0) && (fcnpos == fcnsize); + } + + private void write(char[] cb, int off, int len) throws IOException { + CharBuffer cbuf = CharBuffer.wrap(cb, off, len); + encodeAndWrite(cbuf, false, false); + } + + private void internalFlush(boolean endOfFile) throws IOException { + if (endOfFile) { + CharBuffer cbuf = CharBuffer.allocate(0); + encodeAndWrite(cbuf, true, endOfFile); + } else { + flushBbuf(); + } + } + + private void encodeAndWrite(CharBuffer cbuf, boolean flush, boolean endOfFile) throws IOException { + if (bbufpos == fcnsize) { + bbuf.clear(); + } + while (cbuf.remaining() > 0) { + CoderResult r = cenc.encode(cbuf, bbuf, endOfFile); + bbufIsDirty = true; + long curpos = bbufpos + bbuf.position(); + if (curpos > fcnsize) { + // the file is extended. + fcnsize = curpos; + } + if (CoderResult.OVERFLOW == r || bbuf.remaining() == 0) { + flushBbuf(); + bbufpos += bbuf.limit(); + bbuf.clear(); + if (fcnpos < fcnsize) { + fcn.read(bbuf); + bbuf.flip(); + fcnpos += bbuf.remaining(); + } + // if we are at the end of file, bbuf is simply cleared. + // in that case, bbufpos + bbuf.position points to the EOF, not fcnpos. + } + } + if (bbuf.position() > 0 && bbufIsDirty && flush) { + flushBbuf(); + } + } + + public void position(long newPosition) throws IOException { + flushBbuf(); + long bbufend = bbufpos + bbuf.limit(); + if (newPosition >= bbufpos && newPosition < bbufend) { + // near seek. within existing data of bbuf. + bbuf.position((int)(newPosition - bbufpos)); + } else { + // far seek. discard the buffer. + flushBbuf(); + fcn.position(newPosition); + fcnpos = newPosition; + bbuf.clear(); + bbuf.flip(); // "there is no useful data on this buffer yet." + bbufpos = fcnpos; + } + } + + public long position() throws IOException { + flushBbuf(); + return bbufpos + bbuf.position(); // the logical position within the file. + } + + public long length() throws IOException { + flushBbuf(); + return fcn.size(); + } + + private void flushBbuf() throws IOException { + if (bbufIsDirty) { + if (fcnpos != bbufpos) { + fcn.position(bbufpos); + } + bbuf.position(0); + if (bbufpos + bbuf.limit() > fcnsize) { + // the buffer is at the end of the file. + // area beyond fcnsize does not have data. + bbuf.limit((int)(fcnsize - bbufpos)); + } + fcn.write(bbuf); + fcnpos = bbufpos + bbuf.limit(); + bbufIsDirty = false; + } + } + + public int read(byte[] b, int off, int len) throws IOException { + int pos = off; + boolean atEof = false; + while (pos - off < len && dataIsAvailableForRead() + && ! atEof) { + if (bbuf.remaining() == 0) { + // need to read from the file. + flushBbuf(); // in case bbuf is dirty. + // update bbufpos. + bbufpos += bbuf.limit(); + // if reads and writes are mixed, we may need to seek first. + if (bbufpos != fcnpos) { + fcn.position(bbufpos); + } + // need to read data from file. + bbuf.clear(); + atEof = (fcn.read(bbuf) == -1); + bbuf.flip(); + fcnpos = bbufpos + bbuf.remaining(); + } + int want = len - pos; + if (want > bbuf.remaining()) { + want = bbuf.remaining(); + } + bbuf.get(b, pos, want); + pos += want; + } + return pos - off; + } + + // a method corresponding to the good ol' ungetc in C. + // This function may fail when using (combined) character codes that use + // escape sequences to switch between sub-codes. + // ASCII, ISO-8859 series, any 8bit code are OK, all unicode variations are OK, + // but applications of the ISO-2022 encoding framework can have trouble. + // Example of such code is ISO-2022-JP which is used in Japanese e-mail. + private CharBuffer singleCharBuf; + private ByteBuffer shortByteBuf; + public void unreadChar(char c) throws IOException { + // algorithm : + // 1. encode c into bytes, to find out how many bytes it corresponds to + // 2. move the position backwards that many bytes. + // ** we stop here. Don't bother to write the bytes to the buffer, + // assuming that it is the same as the original data. + // If we allow to write back different characters, the buffer must get 'dirty' + // but that would require read/write permissions on files you use unreadChar, + // even if you are just reading for some tokenizer. + // + // So we don't do the following. + // 3. write the bytes. + // 4. move the position back again. + if (singleCharBuf == null) { + singleCharBuf = CharBuffer.allocate(1); + shortByteBuf = ByteBuffer.allocate((int)cenc.maxBytesPerChar()); + } + singleCharBuf.clear(); + singleCharBuf.append(c); + singleCharBuf.flip(); + shortByteBuf.clear(); + cenc.encode(singleCharBuf, shortByteBuf, false); + int n = shortByteBuf.position(); + long pos = position() - n; + position(pos); + } + + public void unreadByte(byte b) throws IOException { + long pos = position() - 1; + position(pos); + } + + private void write(byte[] b, int off, int len) throws IOException { + int pos = off; + while (pos < off + len) { + int want = len; + if (want > bbuf.remaining()) { + want = bbuf.remaining(); + } + bbuf.put(b, pos, want); + pos += want; + bbufIsDirty = true; + long curpos = bbufpos + bbuf.position(); + if (curpos > fcn.size()) { + // the file is extended. + fcnsize = curpos; + } + if (bbuf.remaining() == 0) { + flushBbuf(); + bbufpos += bbuf.limit(); + bbuf.clear(); + if (fcn.position() < fcn.size()) { + bbufpos = fcn.position(); + fcn.read(bbuf); + bbuf.flip(); + fcnpos += bbuf.remaining(); + } + // if we are at the end of file, bbuf is simply cleared. + // in that case, bbufpos + bbuf.position points to the EOF, not fcnpos. + } + } + } +} Added: branches/save-image/src/org/armedbear/lisp/with-accessors.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-accessors.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,44 @@ +;;; with-accessors.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: with-accessors.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From SBCL. + +(defmacro with-accessors (slots instance &body body) + (let ((in (gensym))) + `(let ((,in ,instance)) + (symbol-macrolet + ,(mapcar (lambda (slot-entry) + (let ((variable-name (car slot-entry)) + (accessor-name (cadr slot-entry))) + `(,variable-name + (,accessor-name ,in)))) + slots) + , at body)))) Added: branches/save-image/src/org/armedbear/lisp/with-hash-table-iterator.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-hash-table-iterator.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,46 @@ +;;; with-hash-table-iterator.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: with-hash-table-iterator.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun hash-table-iterator-function (hash-table) + (let ((entries (hash-table-entries hash-table))) + #'(lambda () (let ((entry (car entries))) + (setq entries (cdr entries)) + (if entry + (values t (car entry) (cdr entry)) + nil))))) + +(defmacro with-hash-table-iterator ((name hash-table) &body body) + (let ((iter (gensym))) + `(let ((,iter (hash-table-iterator-function ,hash-table))) + (macrolet ((,name () '(funcall ,iter))) + , at body)))) Added: branches/save-image/src/org/armedbear/lisp/with-input-from-string.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-input-from-string.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,58 @@ +;;; with-input-from-string.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: with-input-from-string.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from CMUCL. + +(in-package "SYSTEM") + +(defmacro with-input-from-string ((var string &key index start end) &body body) + (multiple-value-bind (forms decls) (parse-body body) + `(let ((,var + ,(cond ((null end) + `(make-string-input-stream ,string ,(or start 0))) + ((symbolp end) + `(if ,end + (make-string-input-stream ,string + ,(or start 0) + ,end) + (make-string-input-stream ,string + ,(or start 0)))) + (t + `(make-string-input-stream ,string + ,(or start 0) + ,end))))) + , at decls + (unwind-protect + (multiple-value-prog1 + (progn , at forms) + ,@(when index + `((setf ,index (string-input-stream-current ,var))))) + (close ,var))))) Added: branches/save-image/src/org/armedbear/lisp/with-mutex.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-mutex.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,41 @@ +;;; with-mutex.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: with-mutex.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:extensions) + +(defmacro with-mutex ((mutex) &body body) + (let ((m (gensym))) + `(let ((,m ,mutex)) + (when (get-mutex ,m) + (unwind-protect + (progn + , at body) + (release-mutex ,m)))))) Added: branches/save-image/src/org/armedbear/lisp/with-open-file.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-open-file.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,48 @@ +;;; with-open-file.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: with-open-file.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defmacro with-open-file (&rest args) + (let ((var (caar args)) + (open-args (cdar args)) + (body (cdr args)) + (abortp (gensym))) + (multiple-value-bind (forms decls) (parse-body body) + `(let ((,var (open , at open-args)) + (,abortp t)) + , at decls + (unwind-protect + (multiple-value-prog1 + (progn , at forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp))))))) Added: branches/save-image/src/org/armedbear/lisp/with-output-to-string.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-output-to-string.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,55 @@ +;;; with-output-to-string.lisp +;;; +;;; Copyright (C) 2003-2005 Peter Graves +;;; $Id: with-output-to-string.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +;;; From SBCL. +(defmacro with-output-to-string ((var &optional string &key (element-type ''character)) + &body body) + "If STRING is specified, it must be a string with a fill pointer; + the output is incrementally appended to the string (as if by use of + VECTOR-PUSH-EXTEND)." + (multiple-value-bind (forms decls) (parse-body body) + (if string + (let ((ignored (gensym))) + `(let ((,var (make-fill-pointer-output-stream ,string)) + (,ignored ,element-type)) + (declare (ignore ,ignored)) + , at decls + (unwind-protect + (progn , at forms) + (close ,var)))) + `(let ((,var (make-string-output-stream :element-type ,element-type))) + , at decls + (unwind-protect + (progn , at forms) + (close ,var)) + (get-output-stream-string ,var))))) Added: branches/save-image/src/org/armedbear/lisp/with-package-iterator.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-package-iterator.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,70 @@ +;;; with-package-iterator.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: with-package-iterator.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "SYSTEM") + +(defun package-iterator-function (package-list symbol-types) + (unless (consp package-list) + (setq package-list (list package-list))) + (let ((results ())) + (dolist (pkg package-list) + (unless (packagep pkg) + (setq pkg (find-package pkg)) + (unless pkg + (error 'package-error "not a package"))) + (when (memq :internal symbol-types) + (dolist (sym (package-internal-symbols pkg)) + (push (list sym :internal pkg) results))) + (when (memq :external symbol-types) + (dolist (sym (package-external-symbols pkg)) + (push (list sym :external pkg) results))) + (when (memq :inherited symbol-types) + (dolist (sym (package-inherited-symbols pkg)) + (push (list sym :inherited pkg) results)))) + #'(lambda () (let ((item (car results))) + (setq results (cdr results)) + (if item + (values t (first item) (second item) (third item)) + nil))))) + +(defmacro with-package-iterator ((name package-list &rest symbol-types) + &body body) + (unless symbol-types + (error 'program-error + "WITH-PACKAGE-ITERATOR: no symbol types specified")) + (dolist (symbol-type symbol-types) + (unless (memq symbol-type '(:internal :external :inherited)) + (error 'program-error + "WITH-PACKAGE-ITERATOR: invalid symbol type: %S" symbol-type))) + (let ((iter (gensym))) + `(let ((,iter (package-iterator-function ,package-list ',(remove-duplicates symbol-types)))) + (macrolet ((,name () '(funcall ,iter))) + , at body)))) Added: branches/save-image/src/org/armedbear/lisp/with-slots.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-slots.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,50 @@ +;;; with-slots.lisp +;;; +;;; Copyright (C) 2003 Peter Graves +;;; $Id: with-slots.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; From SBCL. + +(defmacro with-slots (slots instance &body body) + (let ((in (gensym))) + `(let ((,in ,instance)) + (symbol-macrolet + ,(mapcar (lambda (slot-entry) + (let ((var-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,var-name + (slot-value ,in ',slot-name)))) + slots) + , at body)))) Added: branches/save-image/src/org/armedbear/lisp/with-standard-io-syntax.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-standard-io-syntax.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,60 @@ +;;; with-standard-io-syntax.lisp +;;; +;;; Copyright (C) 2003-2004 Peter Graves +;;; $Id: with-standard-io-syntax.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +;;; Adapted from SBCL. + +(in-package "SYSTEM") + +(defun %with-standard-io-syntax (function) + (let ((*package* (find-package "CL-USER")) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable nil))) + (funcall function))) + +(defmacro with-standard-io-syntax (&body body) + `(%with-standard-io-syntax #'(lambda () , at body))) Added: branches/save-image/src/org/armedbear/lisp/with-thread-lock.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/with-thread-lock.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,41 @@ +;;; with-thread-lock.lisp +;;; +;;; Copyright (C) 2004 Peter Graves +;;; $Id: with-thread-lock.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package "EXTENSIONS") + +(defmacro with-thread-lock ((lock) &body body) + (let ((glock (gensym))) + `(let ((,glock ,lock)) + (unwind-protect + (progn + (thread-lock ,glock) + , at body) + (thread-unlock ,glock))))) \ No newline at end of file Added: branches/save-image/src/org/armedbear/lisp/write-sequence.lisp ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/write-sequence.lisp Fri Mar 6 00:01:48 2009 @@ -0,0 +1,69 @@ +;;; write-sequence.lisp +;;; +;;; Copyright (C) 2004-2005 Peter Graves +;;; $Id: write-sequence.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package #:system) + +(defun write-sequence (sequence stream &key (start 0) end) + (declare (type stream stream)) + (declare (type index start)) + (unless (>= start 0) + (error 'simple-type-error + :datum start + :expected-type '(integer 0))) + (if end + (unless (and (integerp end) (>= end 0)) + (error 'simple-type-error + :datum end + :expected-type '(integer 0))) + (setf end (length sequence))) + (let ((end (the fixnum end)) + (stream-element-type (stream-element-type stream))) + (cond ((eq stream-element-type 'character) + (if (stringp sequence) + (%write-string sequence stream start end) + (do* ((i start (1+ i))) + ((>= i end) sequence) + (declare (type index i)) + (write-char (elt sequence i) stream)))) + ((equal stream-element-type '(unsigned-byte 8)) + (if (and (vectorp sequence) + (equal (array-element-type sequence) '(unsigned-byte 8))) + (write-vector-unsigned-byte-8 sequence stream start end) + (do* ((i start (1+ i))) + ((>= i end) sequence) + (declare (type index i)) + (write-8-bits (elt sequence i) stream)))) + (t + (do* ((i start (1+ i))) + ((>= i end) sequence) + (declare (type index i)) + (write-byte (elt sequence i) stream))))) + sequence) Added: branches/save-image/src/org/armedbear/lisp/zip.java ============================================================================== --- (empty file) +++ branches/save-image/src/org/armedbear/lisp/zip.java Fri Mar 6 00:01:48 2009 @@ -0,0 +1,96 @@ +/* + * zip.java + * + * Copyright (C) 2005 Peter Graves + * $Id: zip.java 11488 2008-12-27 10:50:33Z ehuelsmann $ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.io.File; +import java.io.FileInputStream; +import java.io.FileOutputStream; +import java.io.IOException; +import java.util.zip.ZipEntry; +import java.util.zip.ZipOutputStream; + +// ### zip pathname pathnames +public final class zip extends Primitive +{ + private zip() + { + super("zip", PACKAGE_SYS, true, "pathname pathnames"); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + throws ConditionThrowable + { + Pathname zipfilePathname = coerceToPathname(first); + byte[] buffer = new byte[4096]; + try { + String zipfileNamestring = zipfilePathname.getNamestring(); + if (zipfileNamestring == null) + return error(new SimpleError("Pathname has no namestring: " + + zipfilePathname.writeToString())); + ZipOutputStream out = + new ZipOutputStream(new FileOutputStream(zipfileNamestring)); + LispObject list = second; + while (list != NIL) { + Pathname pathname = coerceToPathname(list.car()); + String namestring = pathname.getNamestring(); + if (namestring == null) { + // Clean up before signalling error. + out.close(); + File zipfile = new File(zipfileNamestring); + zipfile.delete(); + return error(new SimpleError("Pathname has no namestring: " + + pathname.writeToString())); + } + File file = new File(namestring); + FileInputStream in = new FileInputStream(file); + ZipEntry entry = new ZipEntry(file.getName()); + out.putNextEntry(entry); + int n; + while ((n = in.read(buffer)) > 0) + out.write(buffer, 0, n); + out.closeEntry(); + in.close(); + list = list.cdr(); + } + out.close(); + } + catch (IOException e) { + return error(new LispError(e.getMessage())); + } + return zipfilePathname; + } + + private static final Primitive zip = new zip(); +} Added: branches/save-image/web/abcl.html ============================================================================== --- (empty file) +++ branches/save-image/web/abcl.html Fri Mar 6 00:01:48 2009 @@ -0,0 +1,117 @@ + + + + + + +Armed Bear Common Lisp + + + + +
+

Armed Bear

+ The right of the people to keep and arm bears shall not be infringed! +
+ +
+

+ + + About ABCL + + +

+

+
+ Armed Bear Common Lisp (ABCL) is an implementation of ANSI Common Lisp + that runs in a Java virtual machine. It provides a runtime system, a + compiler that compiles Lisp source to JVM bytecode, and an interactive + REPL for program development. +

+ ABCL is distributed under the terms of the GNU General Public + License, with a special linking exception. If you link ABCL with your + own program, then you do not need to release the source code for that + program. However, any changes that you make to ABCL itself must be + released in accordance with the terms of the GPL. +

+ ABCL runs on platforms that support Java 1.4 (or later), including Linux, + Windows, and Mac OS X. +

+ ABCL is free software and comes with ABSOLUTELY NO WARRANTY. +

+ The latest version is 0.0.10, released March 6, 2007. +

+
+ +

+ + Download + +

+
+ abcl-0.0.10.tar.gz + (source, 632987 bytes) +

+ abcl-0.0.10.zip + (source, 1012345 bytes) +

+
+ +

+ + CVS + +

+
+ The project's SourceForge.net CVS repository can be checked out through + anonymous (pserver) CVS with the following command: + 
+      cvs -d:cvs -z3 -d:pserver:anonymous at armedbear-j.cvs.sourceforge.net:/cvsroot/armedbear-j co j
+
+
+
+ +

+ + Bugs + +

+
+ ABCL is a young implementation (particularly by Lisp standards). You + are certain to encounter bugs. +

+ ABCL 0.0.10 fails 67 out of 21696 tests in the GCL ANSI test suite. +

+ ABCL's CLOS is intolerably slow and does not handle on-the-fly + redefinition of classes correctly. There is no support for the long + form of DEFINE-METHOD-COMBINATION, and certain other required CLOS + features are also missing. Enough CLOS is there to run ASDF and + CL-PPCRE, if you're in no hurry. There's no MOP worth mentioning. +

+ Since this is an early public release, there might be build problems as + well as runtime bugs. +

+ Please report problems to the j development mailing list + (you must be subscribed to post). +

+
+ +

+ + Installation + +

+
+ The README file in the root directory of the source distribution contains + instructions for building ABCL. +

+ Java 1.4 or later is required. + Java 1.5 + is recommended. There are + + unresolved performance issues with Java 1.6. To build ABCL, you'll need + the full JDK; the JRE is not enough.

+
+

+ Added: branches/save-image/web/armedbear.css ============================================================================== --- (empty file) +++ branches/save-image/web/armedbear.css Fri Mar 6 00:01:48 2009 @@ -0,0 +1,37 @@ +BODY +{ + font-family: arial, helvetica, sans-serif; + color: #000000; + background-color: #ffffff; +} + +B, I, P, UL, LI, H1, H2, H3, H4 +{ + font-family: arial, helvetica, sans-serif; +} + + +A:link +{ + color: #cc6600; +} + +A:active +{ + color: #cc6600; +} + +A:visited +{ + color: #cc6600; +} + +A:hover +{ + color: #cc6600; +} + +CODE +{ + font-family: monospaced; +} Added: branches/save-image/web/index.html ============================================================================== --- (empty file) +++ branches/save-image/web/index.html Fri Mar 6 00:01:48 2009 @@ -0,0 +1,48 @@ + + + + + + +Armed Bear + + + + +

+

Armed Bear

+ The right of the people to keep and arm bears shall not be infringed! +
+ +
+

+ + + Armed Bear Common Lisp + + +

+

+
+ Armed Bear Common Lisp (ABCL) is an implementation of ANSI Common Lisp + that runs in a Java virtual machine. +

+ The latest version is 0.0.10, released March 6, 2007. +

+
+ + + J + + +

+

+
+ J is a text editor written in Java. +

+ The latest version is 0.21.0, released September 24, 2004. +

+
+ +

+ Added: branches/save-image/web/j.html ============================================================================== --- (empty file) +++ branches/save-image/web/j.html Fri Mar 6 00:01:48 2009 @@ -0,0 +1,288 @@ + + + + + + +J + + + + +

+

Armed Bear

+ The right of the people to keep and arm bears shall not be infringed! +
+ +
+ +

+ + About J + +

+
+ J is a text editor written in Java and distributed under the + GNU General Public + License. +

+ J runs on platforms that support Java 1.4, including Linux, + Windows, and Mac OS X. +

+ J is free software and comes with ABSOLUTELY NO WARRANTY. +

+ The latest version is 0.21.0, released September 24, 2004. +

+
+ +

+ + Screenshots + +

+
J 0.14.0 in Java mode, with line numbers and change marks turned on: +

+
+
j-0.14.0.png (91816 bytes)
+
+
+

+

J 0.16.4 reading mail: +

+
+
j-0.16.4.png (145493 bytes)
+
+
+

+

J 0.19.0 in the Java debugger: +

+
+
j-0.19.0.png (111165 bytes)
+
+
+
+ +

+ + Download + +

+
+ The latest release is available from the SourceForge + download page. +
+
+ +

+ + Documentation + +

+
+ Documentation is included in both source and binary distributions. +

+ You can also view the documentation for the current release + online. +

+
+ +

+ + Mailing Lists + +

+
J's mailing list page on SourceForge is here.
+
+ +

+ + Reporting Bugs + +

+
Report a bug.
+
+ +

+ + What's New + +

+
+ Sep 24 2004 4:45 PM - Version 0.21.0 +

+ Some minor problems that prevented j from working correctly with the Java 1.5 + betas are fixed in this release. +

+ It is now possible to use drag/drop in the sidebar buffer list to reorder the + buffers, so that navigating between buffers using + nextBuffer and + prevBuffer (mapped by default to + Alt Right and Alt Left, respectively) is more efficient. Thanks to Mike + Rutter for providing the code to do this. +

+ By request, the command + wrapParagraphsInRegion + has been added. It is mapped by default to Ctrl Shift F12 in plain text and + mail composition buffers. + wrapParagraphsInRegion + walks through the region (or the whole buffer if no region is selected) and, + in effect, calls wrapParagraph + on each paragraph. +

+ The wrap commands should now do a better job of handling lines that break on + the hyphen of a hyphenated word (like "wrap-paragraph"). If the paragraph is + subsequently reformatted in such a way that the line break no longer falls on + the hyphen in question, the parts of the hyphenated word are now put back + together properly. In previous versions of j, you were likely to end up with + "wrap- paragraph", with a bogus extra space after the hyphen. +

+ The commands + pageUpOtherWindow and + pageDownOtherWindow have + been added. They are mapped by default to Alt Page Down and Alt Page Up, + respectively, in all modes. These commands are helpful in a split-window + situation when you want to scroll the other window without switching to it. +

+ The commmand + findOccurrenceAtDotAndKillList + has been added. It is mapped by default to Ctrl Enter in List Occurrences + buffers. It works like + findOccurrenceAtDot, but + in addition it closes the List Occurrences buffer. +

+ The commands shellNextPrompt + and shellPreviousPrompt + have been added. They are mapped by default to Ctrl Alt N and Ctrl Alt P, + respectively, in shell buffers and their derivatives (including Lisp shells), + and they help you find the next or previous prompt, starting from the current + location of the caret. +

+ The command p4Log has been added. It + runs the Perforce command "filelog -l" on the file associated with the + current buffer. +

+ The command p4Diff now runs the + Perforce command "p4 diff -f -du", instead of "p4 diff -du". This change + means that p4Diff will display + potentially useful output even if the file associated with the current buffer + has not, in Perforce's opinion, been officially opened for editing. +

+ J's ssh-related code now recognizes "Response:" as a password prompt, in + addition the to other password prompts it recognized already. +

+ Compilation buffers are now supported on Windows NT 4. Thanks to Pete Kirkham + for pointing out that this was possible. +

+ In previous versions of j, there was an incorrect optimization in the display + code which malfunctioned on very rare occasions and caused lines to disappear + from the display, even though they were still present in the buffer (there + was never any loss of data). This bug has been fixed by removing the + optimization in question. +

+ There are a number of new features and minor improvements in Lisp mode and + in Lisp shells. Thanks to Sam Steingold for help with many of these. +

+ This release includes version 0.0.4 of Armed Bear Common Lisp. ABCL 0.0.4 + passes 17778 out of 17942 tests in the GCL ANSI Common Lisp test suite, for a + nominal compliance of 99.0859%. The test suite is still not complete, + however, so ABCL's actual percentage of ANSI compliance, whatever that may + mean, is undoubtedly lower. In any case, version 0.0.4 represents a + substantial improvement over version 0.0.3, back when it was still called + Armed Bear Lisp, which passed 12986 out of 14127 tests (91.92%). +

+ ABCL includes a compiler, written in Lisp, that generates JVM bytecode from + Lisp source. The compiler is not finished, and there are valid Lisp + constructs that it doesn't know how to compile. In most situations, when the + compiler encounters code that it can't compile correctly, it is smart enough + to leave the code alone so that it will continue to work correctly with the + interpreter. Compiled code and interpreted code can coexist happily in the + same running instance of ABCL. +

+ The 0.21.0 binary distribution contains a compiled version of the Lisp + library code (i.e. a full set of .abcl and .cls files), as well as the Lisp + source files for the library code that is implemented in Lisp. If you build j + from source, using either configure/make or Ant, the Lisp library code will + be compiled as part of the build. There is no longer any need to do + COMPILE-SYSTEM manually. +

+ ABCL 0.0.4 is better at some things than others. In particular, it's not very + good at CLOS. ABCL's CLOS correctness is reasonable, but its CLOS performance + is terrible (for one thing, the compiler doesn't even attempt to compile + generic functions). This deficiency is due more to simple neglect than to any + intrinsic limitation, and the CLOS implementation should improve in future + releases. +

+ You can start ABCL from within j by doing Alt X, "abcl", or by selecting "Run + Lisp as Separate Process" from the Lisp menu. Note that the "Run Embedded + Lisp" menu selection opens a Lisp shell using an instance of ABCL that runs + in the editor process; it only makes sense to do this if you're planning to + interact with the running instance of j, which is not normally the case. If + you just want to experiment with ABCL, "Run Lisp as Separate Process" (or Alt + X, "abcl") is your friend. +

+ If you're truly adventurous, you can also start ABCL from within j by doing + Alt X, "slime". J's version of slime is adapted from the "Superior Lisp + Interaction Mode for Emacs", originally written by Eric Marsden, Luke Gorrie + and Helmut Eller. Slime-for-j is less than a month old, so it is nowhere near + as robust or featureful as slime-for-emacs, but in principle it offers more + functionality than Alt X, "abcl". In particular, the tab key can be used for + symbol completion, function argument lists are displayed in the status bar + when you type a space, and Alt . should work to find function definitions (if + you've built ABCL from source). In addition, the evaluation of forms and + regions in Lisp source files makes an attempt to set *PACKAGE* to the right + thing first. I don't think any of these features works 100% correctly yet, + but even so, slime-for-j feels like an improvement over the basic Lisp shell + functionality available in previous versions of j. For more information, see + slime.lisp. +

+ More (and more timely) details about recent changes in j and ABCL are + available on the J Development Mailing List, the archives of which are + here + (or on + Gmane). +

+ The complete change log (back to the beginning of time) is available + here. +

+
+

+ + Installation + +

+
+ Java 1.4 or later is required. Java 1.5 is recommended. +

+ Sun Java 1.5 or + Blackdown Java 1.4.2-01 + is recommended for Linux. +

+ Sun Java 1.5 is recommended for + Windows. +

+ Simply untar or unzip the binary distribution, cd into the j-0.21.0 + directory, and run the jar file: + 

+        $ tar xvfz j-0.21.0-binary.tar.gz
+        $ cd j-0.21.0
+        $ java -jar j.jar
+

+ Or for Windows: + 

+        C:\> unzip j-0.21.0-binary.zip
+        C:\> cd j-0.21.0
+        C:\j-0.21.0> java -jar j.jar
+
+
+

+ + Building the Source + +

+
+ Instructions are provided in the file + building.html in the doc directory of the + distribution.
+
+ SourceForge Logo + From astalla at common-lisp.net Mon Mar 9 20:03:21 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 09 Mar 2009 20:03:21 +0000 Subject: [armedbear-cvs] r11702 - in branches/save-image: . dist Message-ID: Author: astalla Date: Mon Mar 9 20:02:58 2009 New Revision: 11702 Log: Added BRANCH-README, deleted dist directory that was incorrectly added Added: branches/save-image/BRANCH-README Removed: branches/save-image/dist/ Added: branches/save-image/BRANCH-README ============================================================================== --- (empty file) +++ branches/save-image/BRANCH-README Mon Mar 9 20:02:58 2009 @@ -0,0 +1,135 @@ +------- Table of Contents ------- + + - Summary + - Introduction + - The serialization algorithm + - Why serialization? + - Current status + - Known problems + +--------------------------------- + + +-- Summary -- + +The purpose of this branch is to store a set of changes to ABCL intended to provide a save-image functionality, found in all the most important Lisp implementations, using Java serialization as the underlying technology. + + +-- Introduction -- + +Serialization (http://java.sun.com/j2se/1.5.0/docs/api/java/io/Serializable.html) is the capability of a Java runtime environment to write Java objects in binary form on a stream. The objects can be read back later, even on a different instance of the JVM (provided certain conditions are met); this process is called deserialization. + +The objects responsible of these processes are instances of the classes java.io.ObjectOuputputStream and java.io.ObjectInputStream. Using a single instance of ObjectOutputStream to serialize an object graph will ensure that each object is only written once to the stream, while subsequent references to it are stored as references in the stream. This ensures, among other things, that circular structures are supported out-of-the-box, at the cost of some memory consuption due to the hash tables that are used by ObjectOutputStream to record known instances. + +Serializing an object will write to the stream a descriptor of its class, followed by a representation of the object itself according to an algorithm presented below. On deserialization, the class descriptor will be read and a corresponding class will be searched in the currently active ClassLoader. If found, an instance of this class will be created (using a native method that does not invoke any constructor). The state of the instance will then be restored according to the algorithm below. + + +-- The serialization algorithm -- + +Serialization is quite simple to use, yet very configurable. At the bare minimum, a Java class must implement the java.io.Serializable marker interface to be serializable. + +The default serialization algorithm will save all non-transient fields of an object: both fields that are declared in that object's class and in its superclasses that implement Serializable. Deserialization will simply copy state back in the deserialized instance. This unless an object already appeared in the stream, in which case an instance is read/written only once and subsequent references are resolved to it. + +Sometimes the basic algorithm is not enough. Serializable classes are allowed to hook into the mechanism by implementing some or all of these 4 methods: + +- void readObject(ObjectInputStream) +- Object readResolve() + +- void writeObject(ObjectOutputStream) +- Object writeReplace() + +readObject and writeObject can provide custom serialization/deserialization code. Inside these methods you can call defaultReadObject()/defaultWriteObject() on the stream passed as argument to read/write state according to the basic algorithm. + +readResolve and writeReplace can designate another object to be read/written to the stream instead of the current one. + + +-- Why serialization? -- + +Using serialization for ABCL save/restore state has the following benefits: + +- it's built-in and quite easy to implement, at least in the common case +- it handles circularity out of the box +- it plays well with the fact that most ABCL objects inherit from a single superclass (LispObject) +- potentially it allows for finer-grained save/restore functionality, e.g. to send single Lisp objects over the network. + +However, it has the following downsides: + +- It is purely Java side, so it can be hard to debug since it cannot leverage ABCL's interactivity +- It is tricky to integrate it with the dynamism of ABCL (e.g. ad-hoc code must be written to serialize/deserialize classes generated at runtime by the compiler). + + +-- Current status -- + +Currently the LispObject class, plus some support classes (in general inner classes) have been marked as Serializable. Here is a summary of the various Lisp object types and how they are handled: + + +- Java class -- Lisp type ------------- Serialization status -------------- + | | + | | + LispObject | T | Basic algorithm; special cases in subclasses + | | + | | + Symbol | symbol | Package is transient: only the name of the + | | package is written, and the package is searched + | | with find-package at deserialization. This allows + | | to save individual symbols should the need arise. + | | readResolve() finds the package and interns the + | | symbol into it, returning the interned instance + | | with state copied from the deserialized instance. + | | This makes the deserialized instance EQ with an + | | eventual preexististing symbol with the same name + | | in the same package. + | | + | | + Nil | null | readResolve() returns Lisp.NIL + | | + | | + Function | function | compiled functions are instances of runtime- + | | generated classes marked somehow (currently + | | prepending ABCL_GENERATED_ to their name). + | | Function recognizes such classes and in this + | | case designates as a replacement object an + | | instance of ExternalizedCompiledFunction + | | containing the compiler-generated class as + | | a byte[]. Such an instance is used at + | | deseriazation time to reload the class into + | | the classloader, thus reloading the compiled + | | function. Non-compiled functions are serialized + | | using the basic algorithm. + | | + | | + Cons | cons | The basic algorithm seems to suffice. + HashTable | hash-table | + and others | and others | + | | + | | + + +-- Known problems -- + +Object{In|Out}putStream have problems working with Lisp streams. Currently I have bypassed Lisp streams and only used Java streams to a hardcoded file for testing purposes, but the problem will need to be addressed. + +Some objects currently cannot be serialized or deserialized: + +- the symbol + cannot be serialized because its plist references a structure + describing the + method combination, structure which is not serializable + (why?) + +- Deserialization of compiled functions containing calls to jmethod fail, + since apparently when loaded (instantiated) the jmethod compiled function - + or maybe the function jvm::p2-java-jmethod - tries to load + compiler-pass2-704.cls as a file (not from abcl.jar), which obviously fails. + (it tries to load it using Lisp.loadCompiledFunction(String)). + It can be that jmethod is compiled using compile-function-call, which can + call loadCompiledFunction on the LispObject obtained instantiating the + runtime generated class. It is unclear to me where the file path comes from, + however. + +- Objects with volatile state (streams, threads) have not been addressed. + +- probably many others. Needs much more experimentation. In particular little + or no CLOS stuff has been tested. + + + +2009-03-07, Alessio Stalla \ No newline at end of file From ehuelsmann at common-lisp.net Tue Mar 10 22:22:55 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 10 Mar 2009 22:22:55 +0000 Subject: [armedbear-cvs] r11703 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Mar 10 22:22:52 2009 New Revision: 11703 Log: DOTIMES loop variable efficiency: if the derived type of the limit var is integer, make the loop var of integer type too (in order to compare them using jvm opcodes, instead of static calls). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp 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 Tue Mar 10 22:22:52 2009 @@ -4252,7 +4252,11 @@ (when limit-variable (derive-variable-representation limit-variable block) (setf (variable-representation variable) - (variable-representation limit-variable)))))))) + (variable-representation limit-variable)) + (let ((limit-type (variable-derived-type limit-variable))) + (when (integer-type-p limit-type) + (setf (variable-derived-type variable) + (%make-integer-type 0 (integer-type-high limit-type))))))))))) (defun allocate-variable-register (variable) (setf (variable-register variable) @@ -6517,6 +6521,8 @@ (variable-declared-type variable)) ((neq (variable-derived-type variable) :none) (variable-derived-type variable)) + ((= 0 (variable-writes variable)) + (derive-type (variable-initform variable))) (t t)))))) ((symbolp form) From ehuelsmann at common-lisp.net Fri Mar 13 22:21:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 13 Mar 2009 22:21:16 +0000 Subject: [armedbear-cvs] r11704 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Mar 13 22:21:13 2009 New Revision: 11704 Log: Restore lastSpecialBinding upon exception-driven LET/LET* block exit. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ======= From ehuelsmann at common-lisp.net Sun Mar 29 07:56:55 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 29 Mar 2009 03:56:55 -0400 Subject: [armedbear-cvs] r11719 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 29 03:56:52 2009 New Revision: 11719 Log: Fix COMPILE called inside COMPILE-FILE: COMPILE doesn't compile to a file, so use a separate indicator for what our compilation purpose is. Found by: Don Cohen Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp trunk/abcl/src/org/armedbear/lisp/precompiler.lisp 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 Sun Mar 29 03:56:52 2009 @@ -428,23 +428,24 @@ (*explain* *explain*) (jvm::*functions-defined-in-current-file* '()) (*fbound-names* '())) - (write "; -*- Mode: Lisp -*-" :escape nil :stream out) - (%stream-terpri out) - (let ((*package* (find-package '#:cl))) - (write (list 'init-fasl :version *fasl-version*) :stream out) + (jvm::with-file-compilation + (write "; -*- Mode: Lisp -*-" :escape nil :stream out) (%stream-terpri out) - (write (list 'setq '*source* *compile-file-truename*) :stream out) - (%stream-terpri out)) - (loop - (let* ((*source-position* (file-position in)) - (jvm::*source-line-number* (stream-line-number in)) - (form (read in nil in)) - (*compiler-error-context* form)) - (when (eq form in) - (return)) - (process-toplevel-form form out nil))) - (dolist (name *fbound-names*) - (fmakunbound name)))) + (let ((*package* (find-package '#:cl))) + (write (list 'init-fasl :version *fasl-version*) :stream out) + (%stream-terpri out) + (write (list 'setq '*source* *compile-file-truename*) :stream out) + (%stream-terpri out)) + (loop + (let* ((*source-position* (file-position in)) + (jvm::*source-line-number* (stream-line-number in)) + (form (read in nil in)) + (*compiler-error-context* form)) + (when (eq form in) + (return)) + (process-toplevel-form form out nil))) + (dolist (name *fbound-names*) + (fmakunbound name))))) (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*)) (setf warnings-p nil failure-p nil)) ((zerop (+ jvm::*errors* jvm::*warnings*)) 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 Sun Mar 29 03:56:52 2009 @@ -2068,7 +2068,7 @@ (declare-with-hashtable symbol *declared-symbols* ht g (cond ((null (symbol-package symbol)) - (setf g (if *compile-file-truename* + (setf g (if *file-compilation* (declare-object-as-string symbol +lisp-symbol+ +lisp-symbol-class+) (declare-object symbol +lisp-symbol+ @@ -2300,7 +2300,7 @@ (defknown declare-instance (t) t) (defun declare-instance (obj) - (aver (not (null *compile-file-truename*))) + (aver (not (null *file-compilation*))) (aver (or (structure-object-p obj) (standard-object-p obj) (java:java-object-p obj))) (let* ((g (symbol-name (gensym "INSTANCE"))) @@ -2469,13 +2469,13 @@ (emit 'getstatic *this-class* (declare-object-as-string form) +lisp-object+)) ((stringp form) - (if *compile-file-truename* + (if *file-compilation* (emit 'getstatic *this-class* (declare-string form) +lisp-simple-string+) (emit 'getstatic *this-class* (declare-object form) +lisp-object+))) ((vectorp form) - (if *compile-file-truename* + (if *file-compilation* (emit 'getstatic *this-class* (declare-object-as-string form) +lisp-object+) (emit 'getstatic *this-class* @@ -2487,24 +2487,24 @@ (emit 'getstatic *this-class* (declare-object form) +lisp-object+)) ((pathnamep form) - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-object-as-string form) (declare-object form)))) (emit 'getstatic *this-class* g +lisp-object+))) ((packagep form) - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-package form) (declare-object form)))) (emit 'getstatic *this-class* g +lisp-object+))) ((or (structure-object-p form) (standard-object-p form) (java:java-object-p form)) - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-instance form) (declare-object form)))) (emit 'getstatic *this-class* g +lisp-object+))) (t - (if *compile-file-truename* + (if *file-compilation* (error "COMPILE-CONSTANT unhandled case ~S" form) (emit 'getstatic *this-class* (declare-object form) +lisp-object+)))) @@ -3003,7 +3003,7 @@ (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+) (aload 0))) ((null (symbol-package op)) - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-object-as-string op) (declare-object op)))) (emit 'getstatic *this-class* g +lisp-object+))) @@ -3175,7 +3175,7 @@ (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)) (t (dformat t "compile-local-function-call default case~%") - (let* ((g (if *compile-file-truename* + (let* ((g (if *file-compilation* (declare-local-function local-function) (declare-object (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function @@ -4603,7 +4603,7 @@ (let ((NEXT (gensym))) (aload tag-register) (emit 'getstatic *this-class* - (if *compile-file-truename* + (if *file-compilation* (declare-object-as-string (tag-label tag)) (declare-object (tag-label tag))) +lisp-object+) @@ -4913,7 +4913,7 @@ (emit-move-from-stack target)))) (defun p2-load-time-value (form target representation) - (cond (*compile-file-truename* + (cond (*file-compilation* (emit 'getstatic *this-class* (declare-load-time-value (second form)) +lisp-object+) (fix-boxing representation nil) @@ -4986,13 +4986,13 @@ (emit 'getstatic *this-class* (declare-symbol obj) +lisp-symbol+)) (t ;; An uninterned symbol. - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-object-as-string obj) (declare-object obj)))) (emit 'getstatic *this-class* g +lisp-object+)))) (emit-move-from-stack target representation))) ((listp obj) - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-object-as-string obj) (declare-object obj)))) (emit 'getstatic *this-class* g +lisp-object+) @@ -5082,8 +5082,8 @@ (defun p2-flet-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function)) (lambda-list (cadr (compiland-lambda-expression compiland)))) - (cond (*compile-file-truename* - (let* ((pathname (sys::next-classfile-name)) + (cond (*file-compilation* + (let* ((pathname (funcall *pathnames-generator*)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) (set-compiland-and-write-class-file class-file compiland) @@ -5108,8 +5108,8 @@ (defun p2-labels-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function)) (lambda-list (cadr (compiland-lambda-expression compiland)))) - (cond (*compile-file-truename* - (let* ((pathname (sys::next-classfile-name)) + (cond (*file-compilation* + (let* ((pathname (funcall *pathnames-generator*)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) (set-compiland-and-write-class-file class-file compiland) @@ -5177,9 +5177,9 @@ (defun p2-lambda (compiland target) (let* ((lambda-list (cadr (compiland-lambda-expression compiland)))) (aver (null (compiland-class-file compiland))) - (cond (*compile-file-truename* + (cond (*file-compilation* (setf (compiland-class-file compiland) - (make-class-file :pathname (sys::next-classfile-name) + (make-class-file :pathname (funcall *pathnames-generator*) :lambda-list lambda-list)) (let ((class-file (compiland-class-file compiland))) (compile-and-write-to-file class-file compiland) @@ -5187,7 +5187,7 @@ (declare-local-function (make-local-function :class-file class-file)) +lisp-object+))) (t - (let ((pathname (make-temp-file))) + (let ((pathname (funcall *pathnames-generator*))) (setf (compiland-class-file compiland) (make-class-file :pathname pathname :lambda-list lambda-list)) @@ -5225,7 +5225,7 @@ (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil) ) (t - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-local-function local-function) (declare-object (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function @@ -5262,7 +5262,7 @@ (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil) ) (t - (let ((g (if *compile-file-truename* + (let ((g (if *file-compilation* (declare-local-function local-function) (declare-object (local-function-function local-function))))) (emit 'getstatic *this-class* @@ -5271,7 +5271,7 @@ (emit 'getstatic *this-class* (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) - ((and (null *compile-file-truename*) + ((and (null *file-compilation*) (fboundp name) (fdefinition name)) (emit 'getstatic *this-class* @@ -7532,7 +7532,7 @@ (defun compile-special-reference (name target representation) (when (constantp name) (let ((value (symbol-value name))) - (when (or (null *compile-file-truename*) + (when (or (null *file-compilation*) (stringp value) (numberp value) (packagep value)) @@ -8166,7 +8166,7 @@ (class-file-lambda-list class-file)))) (pool-name "Code") ; Must be in pool! - (when *compile-file-truename* + (when *file-compilation* (pool-name "SourceFile") ; Must be in pool! (pool-name (file-namestring *compile-file-truename*))) (when (and (boundp '*source-line-number*) @@ -8200,7 +8200,7 @@ (write-method method stream)) (write-method constructor stream) ;; attributes count - (cond (*compile-file-truename* + (cond (*file-compilation* ;; attributes count (write-u2 1 stream) ;; attributes table Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun Mar 29 03:56:52 2009 @@ -408,8 +408,18 @@ (t (setf (variable-ignorable-p variable) t)))))))) +(defvar *file-compilation* nil) +(defvar *pathnames-generator* #'make-temp-file) + (defun compile (name &optional definition) - (jvm-compile name definition)) + (let ((*file-compilation* nil) + (*pathnames-generator* #'make-temp-file)) + (jvm-compile name definition))) + +(defmacro with-file-compilation (&body body) + `(let ((*file-compilation* t) + (*pathnames-generator* #'sys::next-classfile-name)) + , at body)) (defun finalize-generic-functions () (dolist (sym '(make-instance 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 Sun Mar 29 03:56:52 2009 @@ -1124,7 +1124,7 @@ (let* ((block-name (fdefinition-block-name name)) (lambda-expression `(named-lambda ,name ,lambda-list , at decls ,@(when doc `(,doc)) (block ,block-name , at body)))) - (cond (*compile-file-truename* + (cond (*file-compilation* `(fset ',name ,lambda-expression)) (t (when (and env (empty-environment-p env)) From ehuelsmann at common-lisp.net Sun Mar 29 09:52:16 2009 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 29 Mar 2009 05:52:16 -0400 Subject: [armedbear-cvs] r11720 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Mar 29 05:52:14 2009 New Revision: 11720 Log: Fix unbound variable error. Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp 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 Sun Mar 29 05:52:14 2009 @@ -1124,7 +1124,12 @@ (let* ((block-name (fdefinition-block-name name)) (lambda-expression `(named-lambda ,name ,lambda-list , at decls ,@(when doc `(,doc)) (block ,block-name , at body)))) - (cond (*file-compilation* + (cond ((and (boundp 'jvm::*file-compilation*) + ;; when JVM.lisp isn't loaded yet, this variable isn't bound + ;; meaning that we're not trying to compile to a file: + ;; Both COMPILE and COMPILE-FILE bind this variable. + ;; This function is also triggered by MACROEXPAND, though + jvm::*file-compilation*) `(fset ',name ,lambda-expression)) (t (when (and env (empty-environment-p env)) From astalla at common-lisp.net Sun Mar 29 19:31:37 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 29 Mar 2009 15:31:37 -0400 Subject: [armedbear-cvs] r11721 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Mar 29 15:31:34 2009 New Revision: 11721 Log: Corrected comment about function signature Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java Modified: trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java Sun Mar 29 15:31:34 2009 @@ -109,7 +109,7 @@ }; // ### %get-output-stream-bytes - // %get-output-stream-string byte-array-output-stream => java-byte-array + // %get-output-stream-bytes byte-array-output-stream => java-byte-array private static final Primitive GET_OUTPUT_STREAM_STRING = new Primitive("%get-output-stream-bytes", PACKAGE_SYS, false, "byte-array-output-stream")