From ehuelsmann at common-lisp.net Fri Jan 1 10:30:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 05:30:21 -0500 Subject: [armedbear-cvs] r12316 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 05:30:16 2010 New Revision: 12316 Log: Return the actual external format, instead of a default value from STREAM-EXTERNAL-FORMAT. Modified: trunk/abcl/src/org/armedbear/lisp/stream_external_format.java Modified: trunk/abcl/src/org/armedbear/lisp/stream_external_format.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/stream_external_format.java (original) +++ trunk/abcl/src/org/armedbear/lisp/stream_external_format.java Fri Jan 1 05:30:16 2010 @@ -47,7 +47,7 @@ public LispObject execute(LispObject arg) { if (arg instanceof Stream) - return Keyword.DEFAULT; + return ((Stream)arg).getExternalFormat(); else return error(new TypeError(arg, Symbol.STREAM)); } From ehuelsmann at common-lisp.net Fri Jan 1 10:34:13 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 05:34:13 -0500 Subject: [armedbear-cvs] r12317 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Fri Jan 1 05:34:12 2010 New Revision: 12317 Log: Change the properties of RandomAccessCharacterFile to the standard ones. Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Fri Jan 1 05:34:12 2010 @@ -2,7 +2,7 @@ * RandomAccessCharacterFile.java * * Copyright (C) 2008 Hideo at Yokohama - * Copyright (C) 2008 Erik Huelsmann + * Copyright (C) 2008-2009 Erik Huelsmann * $Id$ * * This program is free software; you can redistribute it and/or From ehuelsmann at common-lisp.net Fri Jan 1 10:42:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 05:42:25 -0500 Subject: [armedbear-cvs] r12318 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Fri Jan 1 05:42:21 2010 New Revision: 12318 Log: Remove trailing spaces/tabs which light my editing buffers red. Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Fri Jan 1 05:42:21 2010 @@ -58,7 +58,7 @@ public RandomAccessInputStream() { super(null); } - + private byte[] read_buf = new byte[1]; @Override @@ -72,7 +72,7 @@ return -1; } } - + @Override public final int read(byte[] b, int off, int len) throws IOException { return RandomAccessCharacterFile.this.read(b, off, len); @@ -162,11 +162,11 @@ 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() { @@ -179,13 +179,13 @@ public final void close() throws IOException { RandomAccessCharacterFile.this.close(); } - + private char[] read_buf = new char[1]; @Override public final int read() throws IOException { int n = this.read(read_buf); - + if (n == 1) return read_buf[0]; else @@ -218,7 +218,7 @@ public final int read(char[] cbuf) throws IOException { return RandomAccessCharacterFile.this.read(cbuf, 0, cbuf.length); } - + @Override public final int read(char[] cb, int off, int len) throws IOException { return RandomAccessCharacterFile.this.read(cb, off, len); @@ -252,17 +252,17 @@ 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 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, @@ -303,28 +303,28 @@ 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 final void close() throws IOException { internalFlush(true); fcn.close(); } - + public final void flush() throws IOException { internalFlush(false); } @@ -416,7 +416,7 @@ bbufpos = newPosition; } } - + public final long position() throws IOException { return bbufpos + bbuf.position(); // the logical position within the file. } @@ -466,7 +466,7 @@ } 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. @@ -501,7 +501,7 @@ long pos = position() - n; position(pos); } - + public final void unreadByte(byte b) throws IOException { long pos = position() - 1; position(pos); From ehuelsmann at common-lisp.net Fri Jan 1 14:10:23 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 09:10:23 -0500 Subject: [armedbear-cvs] r12319 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 09:10:15 2010 New Revision: 12319 Log: Fix line numbers from COMPILE-FILE being off. Fixes ticket #71. Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FileStream.java Fri Jan 1 09:10:15 2010 @@ -185,17 +185,6 @@ } @Override - protected void _unreadChar(int n) - { - try { - racf.unreadChar((char)n); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - - @Override protected boolean _charReady() { return true; From ehuelsmann at common-lisp.net Fri Jan 1 15:38:40 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 10:38:40 -0500 Subject: [armedbear-cvs] r12320 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 10:38:33 2010 New Revision: 12320 Log: Print StreamErrors with a readable text, even when created based on a Throwable. Modified: trunk/abcl/src/org/armedbear/lisp/StreamError.java Modified: trunk/abcl/src/org/armedbear/lisp/StreamError.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StreamError.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StreamError.java Fri Jan 1 10:38:33 2010 @@ -105,6 +105,8 @@ { super(StandardClass.STREAM_ERROR); setStream(stream != null ? stream : NIL); + setFormatControl(cause.getMessage()); + setFormatArguments(NIL); this.cause = cause; } @@ -158,8 +160,8 @@ @Override public LispObject execute(LispObject arg) { - if (arg instanceof StreamError) - return ((StreamError)arg).getStream(); + if (arg instanceof StreamError) + return ((StreamError)arg).getStream(); return error(new TypeError(arg, Symbol.STREAM_ERROR)); } }; From ehuelsmann at common-lisp.net Fri Jan 1 18:26:31 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 13:26:31 -0500 Subject: [armedbear-cvs] r12321 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Fri Jan 1 13:26:24 2010 New Revision: 12321 Log: Fix ticket #75: infinite loop while writing unmappable characters to an output stream - while at it, fix the input side too. Added: trunk/abcl/src/org/armedbear/lisp/util/RACFMalformedInputException.java (contents, props changed) trunk/abcl/src/org/armedbear/lisp/util/RACFUnmappableCharacterException.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Added: trunk/abcl/src/org/armedbear/lisp/util/RACFMalformedInputException.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/util/RACFMalformedInputException.java Fri Jan 1 13:26:24 2010 @@ -0,0 +1,68 @@ +/* + * RACFMalformedInputException.java + * + * Copyright (C) 2009 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.nio.charset.MalformedInputException; + + +/** Class - derived from MalformedInputException - + * which holds information required to allow higher level + * systems to invoke a lisp restart function to set replacement characters. + */ +public class RACFMalformedInputException + extends MalformedInputException { + + final int position; + final char character; + final String charsetName; + + public RACFMalformedInputException(int position, char character, + String charsetName) { + super(1); // 1 == fake length + this.position = position; + this.character = character; + this.charsetName = charsetName; + } + + @Override + public String getMessage() { + return "Input value 0x" + Integer.toHexString(character) + + " is malformed while recoding with charset " + charsetName; + } + + public int getPosition() { + return position; + } + +} \ No newline at end of file Added: trunk/abcl/src/org/armedbear/lisp/util/RACFUnmappableCharacterException.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/util/RACFUnmappableCharacterException.java Fri Jan 1 13:26:24 2010 @@ -0,0 +1,68 @@ +/* + * RACFUnmappableCharacterException.java + * + * Copyright (C) 2009 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.nio.charset.UnmappableCharacterException; + + +/** Class - derived from UnmappableCharacterException - + * which holds information required to allow higher level + * systems to invoke a lisp restart function to set replacement characters. + */ +public class RACFUnmappableCharacterException + extends UnmappableCharacterException { + + final int position; + final char character; + final String charsetName; + + public RACFUnmappableCharacterException(int position, char character, + String charsetName) { + super(1); // 1 == fake length + this.position = position; + this.character = character; + this.charsetName = charsetName; + } + + @Override + public String getMessage() { + return "Character \\U" + Integer.toHexString(character) + + " can't be recoded using charset " + charsetName; + } + + public int getPosition() { + return position; + } + +} \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Fri Jan 1 13:26:24 2010 @@ -280,12 +280,7 @@ fcn = raf.getChannel(); - cset = (encoding == null) ? Charset.defaultCharset() : Charset.forName(encoding); - cdec = cset.newDecoder(); - cdec.onMalformedInput(CodingErrorAction.REPLACE); - cdec.onUnmappableCharacter(CodingErrorAction.REPLACE); - cenc = cset.newEncoder(); - + setEncoding(encoding); bbuf = ByteBuffer.allocate(BUFSIZ); // there is no readable data available in the buffers. @@ -304,6 +299,15 @@ outputStream = new RandomAccessOutputStream(); } + public void setEncoding(String encoding) { + cset = (encoding == null) + ? Charset.defaultCharset() : Charset.forName(encoding); + cdec = cset.newDecoder(); + cdec.onMalformedInput(CodingErrorAction.REPLACE); + cdec.onUnmappableCharacter(CodingErrorAction.REPLACE); + cenc = cset.newEncoder(); + } + public Writer getWriter() { return writer; } @@ -365,6 +369,18 @@ atEof = ! ensureReadBbuf(decodeWasUnderflow); CoderResult r = cdec.decode(bbuf, cbuf, atEof ); decodeWasUnderflow = (CoderResult.UNDERFLOW == r); + if (r.isMalformed()) + // When reading encoded Unicode, we'd expect to require + // catching MalformedInput + throw new RACFMalformedInputException(bbuf.position(), + bbuf.get(bbuf.position()), + cset.name()); + if (r.isUnmappable()) + // Since we're mapping TO unicode, we'd expect to be able + // to map all characters + Debug.assertTrue(false); + if (CoderResult.OVERFLOW == r) + Debug.assertTrue(false); } if (cbuf.remaining() == len) { return -1; @@ -387,7 +403,8 @@ } } - private final void encodeAndWrite(CharBuffer cbuf, boolean flush, boolean endOfFile) throws IOException { + private final void encodeAndWrite(CharBuffer cbuf, boolean flush, + boolean endOfFile) throws IOException { while (cbuf.remaining() > 0) { CoderResult r = cenc.encode(cbuf, bbuf, endOfFile); bbufIsDirty = true; @@ -395,6 +412,20 @@ flushBbuf(false); bbuf.clear(); } + if (r.isUnmappable()) { + throw new RACFUnmappableCharacterException(cbuf.position(), + cbuf.charAt(cbuf.position()), + cset.name()); + } + if (r.isMalformed()) { + // We don't really expect Malformed, but not handling it + // will cause an infinite loop if we don't... + throw new RACFMalformedInputException(cbuf.position(), + cbuf.charAt(cbuf.position()), + cset.name()); + } + if (CoderResult.UNDERFLOW == r) + Debug.assertTrue(false); } if (bbuf.position() > 0 && bbufIsDirty && flush) { flushBbuf(false); From ehuelsmann at common-lisp.net Fri Jan 1 19:34:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 14:34:35 -0500 Subject: [armedbear-cvs] r12322 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Fri Jan 1 14:34:30 2010 New Revision: 12322 Log: Follow up to r12321; changes resulting from more testing. Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Fri Jan 1 14:34:30 2010 @@ -50,6 +50,7 @@ import java.nio.charset.CharsetEncoder; import java.nio.charset.CoderResult; import java.nio.charset.CodingErrorAction; +import org.armedbear.lisp.Debug; public class RandomAccessCharacterFile { @@ -373,14 +374,15 @@ // When reading encoded Unicode, we'd expect to require // catching MalformedInput throw new RACFMalformedInputException(bbuf.position(), - bbuf.get(bbuf.position()), + (char)bbuf.get(bbuf.position()), cset.name()); if (r.isUnmappable()) // Since we're mapping TO unicode, we'd expect to be able // to map all characters Debug.assertTrue(false); - if (CoderResult.OVERFLOW == r) - Debug.assertTrue(false); + // OVERFLOW is a normal condition: + // it's equal to cbuf.remaining() == 0 + // ### EHU: really??? EXACTLY equal?? } if (cbuf.remaining() == len) { return -1; @@ -424,8 +426,8 @@ cbuf.charAt(cbuf.position()), cset.name()); } - if (CoderResult.UNDERFLOW == r) - Debug.assertTrue(false); + // UNDERFLOW is the normal condition where cbuf runs out + // before bbuf is filled. } if (bbuf.position() > 0 && bbufIsDirty && flush) { flushBbuf(false); From ehuelsmann at common-lisp.net Fri Jan 1 19:41:18 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 14:41:18 -0500 Subject: [armedbear-cvs] r12323 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 14:41:15 2010 New Revision: 12323 Log: Implement setting of external format on a stream; only supported on the Java side for now. Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FileStream.java Fri Jan 1 14:41:15 2010 @@ -151,6 +151,15 @@ return super.typep(typeSpecifier); } + @Override + public void setExternalFormat(LispObject format) { + super.setExternalFormat(format); + + if (racf != null) + // setExternalFormat also called before 'racf' is set up + racf.setEncoding(encoding); + } + public Pathname getPathname() { return pathname; 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 Fri Jan 1 14:41:15 2010 @@ -269,12 +269,15 @@ public LispObject getExternalFormat() { return externalFormat; } - + public String getEncoding() { return encoding; } - + public void setExternalFormat(LispObject format) { + // make sure we encode any remaining buffers with the current format + finishOutput(); + if (format == keywordDefault) { encoding = null; eolStyle = platformEolStyle; @@ -282,10 +285,10 @@ externalFormat = format; return; } - + LispObject enc; boolean encIsCp = false; - + if (format instanceof Cons) { // meaning a non-empty list enc = format.car(); @@ -294,7 +297,7 @@ enc = getf(format.cdr(), keywordID, null); } - + LispObject eol = getf(format.cdr(), keywordEolStyle, keywordRAW); if (eol == keywordCR) eolStyle = EolStyle.CR; @@ -304,10 +307,10 @@ 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) From ehuelsmann at common-lisp.net Fri Jan 1 19:42:34 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 14:42:34 -0500 Subject: [armedbear-cvs] r12324 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 14:42:33 2010 New Revision: 12324 Log: In case a redefinition warning shouldn't be issued if the function slot is tied to an Autoload object, neither should it in case of AutoloadedFunctionProxy. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Jan 1 14:42:33 2010 @@ -1624,7 +1624,9 @@ if (arg instanceof Symbol) { LispObject oldDefinition = arg.getSymbolFunction(); - if (oldDefinition != null && !(oldDefinition instanceof Autoload)) + if (oldDefinition != null + && !(oldDefinition instanceof Autoload) + && !(oldDefinition instanceof AutoloadedFunctionProxy)) { LispObject oldSource = Extensions.SOURCE_PATHNAME.execute(arg); From ehuelsmann at common-lisp.net Fri Jan 1 22:22:16 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 17:22:16 -0500 Subject: [armedbear-cvs] r12325 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 17:22:13 2010 New Revision: 12325 Log: Create API for (SETF (STREAM-EXTERNAL-FORMAT ...) ...) from the lisp world. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/setf.lisp trunk/abcl/src/org/armedbear/lisp/stream_external_format.java 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 Fri Jan 1 17:22:13 2010 @@ -472,6 +472,7 @@ autoload("stream-element-type", "stream_element_type"); autoload("stream-error-stream", "StreamError"); autoload("stream-external-format", "stream_external_format"); + autoload("%set-stream-external-format", "stream_external_format"); autoload("stringp", "StringFunctions"); autoload("sxhash", "HashTableFunctions"); autoload("sxhash", "HashTableFunctions"); Modified: trunk/abcl/src/org/armedbear/lisp/setf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/setf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/setf.lisp Fri Jan 1 17:22:13 2010 @@ -238,3 +238,5 @@ (defsetf readtable-case %set-readtable-case) (defsetf function-info %set-function-info) + +(defsetf stream-external-format %set-stream-external-format) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/stream_external_format.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/stream_external_format.java (original) +++ trunk/abcl/src/org/armedbear/lisp/stream_external_format.java Fri Jan 1 17:22:13 2010 @@ -54,4 +54,17 @@ private static final Primitive STREAM_EXTERNAL_FORMAT = new stream_external_format(); + + // DEFSETF-ed in 'setf.lisp' + private static final Primitive SET_STREAM_EXTERNAL_FORMAT = + new Primitive("%set-stream-external-format", + PACKAGE_SYS, false, "stream external-format") { + @Override + public LispObject execute(LispObject stream, LispObject format) { + Stream s = checkStream(stream); + s.setExternalFormat(format); + + return format; + } + }; } From ehuelsmann at common-lisp.net Fri Jan 1 22:52:09 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 01 Jan 2010 17:52:09 -0500 Subject: [armedbear-cvs] r12326 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 1 17:52:09 2010 New Revision: 12326 Log: Performance improvement for ticket #76: slow swank fuzzy completion. This commit pushes FORMAT back in the list of time-consumers, according to our profiler's output. 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 Fri Jan 1 17:52:09 2010 @@ -297,6 +297,11 @@ `(adjoin-eql ,(first args) ,(second args)) form)) +(define-source-transform format (&whole form &rest args) + (if (stringp (second args)) + `(format ,(pop args) (formatter ,(pop args)) , at args) + form)) + (define-compiler-macro catch (&whole form tag &rest args) (declare (ignore tag)) (if (and (null (cdr args)) From ehuelsmann at common-lisp.net Sat Jan 2 23:20:33 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Jan 2010 18:20:33 -0500 Subject: [armedbear-cvs] r12327 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sat Jan 2 18:20:28 2010 New Revision: 12327 Log: Note 2 bugs in RandomAccessCharacterFile so the fact doesn't get forgotten. Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Sat Jan 2 18:20:28 2010 @@ -72,6 +72,8 @@ } else { return -1; } + // ### BUG: 'int read()' is to return a *codepoint*, + // not the half of a surrogate pair! } @Override @@ -191,6 +193,8 @@ return read_buf[0]; else return -1; + // ### BUG: 'int read()' is to return a codepoint! + // not the half of a surrogate pair! } @Override From ehuelsmann at common-lisp.net Sat Jan 2 23:22:48 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Jan 2010 18:22:48 -0500 Subject: [armedbear-cvs] r12328 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 2 18:22:48 2010 New Revision: 12328 Log: Note a few codepoint to char conversions which are potential bugs. Modified: trunk/abcl/src/org/armedbear/lisp/LispReader.java Modified: trunk/abcl/src/org/armedbear/lisp/LispReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispReader.java Sat Jan 2 18:22:48 2010 @@ -84,7 +84,7 @@ // Not reached. return null; } - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { // Single escape. n = stream._readChar(); @@ -93,7 +93,7 @@ // Not reached. return null; } - sb.append((char)n); + sb.append((char)n); // ### BUG: Codepoint conversion continue; } if (Utilities.isPlatformWindows) { @@ -229,7 +229,7 @@ int ch = stream._readChar(); if (ch < 0) break; - char c = (char) ch; + char c = (char) ch; // ### BUG: Codepoint conversion if (c == '0' || c == '1') sb.append(c); else { From ehuelsmann at common-lisp.net Sat Jan 2 23:24:49 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 02 Jan 2010 18:24:49 -0500 Subject: [armedbear-cvs] r12329 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 2 18:24:49 2010 New Revision: 12329 Log: More notes about potential codepoint conversion bugs. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java 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 Sat Jan 2 18:24:49 2010 @@ -413,7 +413,7 @@ int n = _readChar(); if (n >= 0) { - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); if (!rt.isWhitespace(c)) _unreadChar(c); @@ -463,7 +463,7 @@ else return eofValue; } - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) continue; LispObject result = processChar(c, rt); @@ -501,7 +501,7 @@ int n = _readChar(); if (n >= 0) { - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion Readtable rt = FaslReadtable.getInstance(); if (!rt.isWhitespace(c)) _unreadChar(c); @@ -538,7 +538,7 @@ else return eofValue; } - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) continue; LispObject result = processChar(c, rt); @@ -729,7 +729,7 @@ int n = _readChar(); if (n < 0) return error(new EndOfFile(this)); - char nextChar = (char) n; + char nextChar = (char) n; // ### BUG: Codepoint conversion if (isTokenDelimiter(nextChar, rt)) { if (last == null) @@ -813,7 +813,7 @@ int n = _readChar(); if (n < 0) return error(new EndOfFile(this)); - c = (char) n; + c = (char) n; // ### BUG: Codepoint conversion if (c < '0' || c > '9') break; if (numArg < 0) @@ -859,14 +859,14 @@ int n = _readChar(); if (n < 0) return error(new EndOfFile(this)); - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion FastStringBuffer sb = new FastStringBuffer(c); while (true) { n = _readChar(); if (n < 0) break; - c = (char) n; + c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) break; if (c == '(' || c == ')') @@ -883,7 +883,7 @@ String token = sb.toString(); n = LispCharacter.nameToChar(token); if (n >= 0) - return LispCharacter.getInstance((char)n); + return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion return error(new LispError("Unrecognized character name: \"" + token + '"')); } catch (IOException e) @@ -1049,7 +1049,7 @@ // Not reached. return null; } - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion byte syntaxType = rt.getSyntaxType(c); if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { @@ -1060,7 +1060,7 @@ // Not reached. return null; } - sb.append((char)n); + sb.append((char)n); // ### BUG: Codepoint conversion continue; } if (syntaxType == Readtable.SYNTAX_TYPE_MULTIPLE_ESCAPE) @@ -1241,7 +1241,7 @@ // Not reached. return flags; } - sb.setCharAt(0, (char) n); + sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion flags = new BitSet(1); flags.set(0); } @@ -1272,7 +1272,7 @@ int n = _readChar(); if (n < 0) break; - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) { _unreadChar(n); @@ -1290,7 +1290,7 @@ n = _readChar(); if (n < 0) break; - sb.append((char)n); + sb.append((char)n); // ### BUG: Codepoint conversion if (flags == null) flags = new BitSet(sb.length()); flags.set(sb.length() - 1); @@ -1631,7 +1631,7 @@ // Not reached. return 0; } - char c = (char) n; + char c = (char) n; // ### BUG: Codepoint conversion if (!rt.isWhitespace(c)) return c; } @@ -1690,7 +1690,7 @@ if (n == '\n') return thread.setValues(new SimpleString(sb), NIL); else - sb.append((char)n); + sb.append((char)n); // ### BUG: Codepoint conversion } } catch (IOException e) @@ -1708,7 +1708,7 @@ int n = _readChar(); if (n < 0) return error(new EndOfFile(this)); - return LispCharacter.getInstance((char)n); + return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion } catch (IOException e) { @@ -1730,7 +1730,7 @@ else return eofValue; } - return LispCharacter.getInstance((char)n); + return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion } catch (IOException e) { From ehuelsmann at common-lisp.net Mon Jan 4 21:57:56 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 04 Jan 2010 16:57:56 -0500 Subject: [armedbear-cvs] r12330 - in trunk/abcl/src/org/armedbear/lisp: . util Message-ID: Author: ehuelsmann Date: Mon Jan 4 16:57:52 2010 New Revision: 12330 Log: Fix ticket #77: incorrect encoding used for FASLs, by always using UTF-8. Added: trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java (contents, props changed) Modified: trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp 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 Mon Jan 4 16:57:52 2010 @@ -445,7 +445,13 @@ // ### *fasl-version* // internal symbol private static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(34)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(35)); + + // ### *fasl-external-format* + // internal symbol + private static final Symbol _FASL_EXTERNAL_FORMAT_ = + internConstant("*FASL-EXTERNAL-FORMAT*", PACKAGE_SYS, + new SimpleString("UTF-8")); // ### *fasl-anonymous-package* // internal symbol @@ -609,6 +615,7 @@ thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package()); thread.bindSpecial(AUTOLOADING_CACHE, AutoloadedFunctionProxy.makePreloadingContext()); + in.setExternalFormat(_FASL_EXTERNAL_FORMAT_.symbolValue(thread)); while (true) { LispObject obj = in.faslRead(false, EOF, true, thread); if (obj == EOF) 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 Mon Jan 4 16:57:52 2010 @@ -52,6 +52,7 @@ import java.nio.charset.Charset; import java.util.BitSet; +import org.armedbear.lisp.util.DecodingReader; /** The stream class * @@ -143,12 +144,12 @@ 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)); + Reader reader = + new DecodingReader(inputStream, 4096, + (encoding == null) + ? Charset.defaultCharset() + : Charset.forName(encoding)); + initAsCharacterInputStream(reader); } else { @@ -331,6 +332,10 @@ eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; externalFormat = format; + + if (reader != null + && reader instanceof DecodingReader) + ((DecodingReader)reader).setCharset(Charset.forName(encoding)); } public boolean isOpen() 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 Mon Jan 4 16:57:52 2010 @@ -502,7 +502,8 @@ (format t "; Compiling ~A ...~%" namestring)) (with-compilation-unit () (with-open-file (out temp-file - :direction :output :if-exists :supersede) + :direction :output :if-exists :supersede + :external-format *fasl-external-format*) (let ((*readtable* *readtable*) (*read-default-float-format* *read-default-float-format*) (*read-base* *read-base*) Added: trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/util/DecodingReader.java Mon Jan 4 16:57:52 2010 @@ -0,0 +1,284 @@ +/* + * DecodingStreamReader.java + * + * Copyright (C) 2010 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.InputStream; +import java.io.PushbackInputStream; +import java.io.PushbackReader; +import java.io.Reader; +import java.io.StringReader; +import java.nio.ByteBuffer; +import java.nio.CharBuffer; +import java.nio.charset.Charset; +import java.nio.charset.CharsetDecoder; +import java.nio.charset.CharsetEncoder; +import java.nio.charset.CoderResult; + +import org.armedbear.lisp.Debug; + +/** Class to support mid-stream change of character encoding + * to support setExternalFormat operation in Stream.java + * + * Note: extends PushbackReader, but only for its interface; + * all methods are overridden. + */ +public class DecodingReader + extends PushbackReader { + + // dummy reader which we need to call the Pushback constructor + // because a null value won't work + private static Reader staticReader = new StringReader(""); + + // contains the currently buffered bytes read from the stream + private ByteBuffer bbuf; + + // stream to read from, wrapped in a PushbackInputStream + private PushbackInputStream stream; + + // Decoder, used for decoding characters on the input stream + private CharsetDecoder cd; + + // Encoder, used to put characters back on the input stream when unreading + private CharsetEncoder ce; + + public DecodingReader(InputStream stream, int size, Charset cs) { + super(staticReader); // pass a dummy stream value into the constructor + + // we need to be able to unread the byte buffer + this.stream = new PushbackInputStream(stream, size); + this.cd = cs.newDecoder(); + this.ce = cs.newEncoder(); + bbuf = ByteBuffer.allocate(size); + bbuf.flip(); // mark the buffer as 'needs refill' + } + + /** Change the Charset used to decode bytes from the input stream + * into characters. + */ + public void setCharset(Charset cs) { + this.cd = cs.newDecoder(); + this.ce = cs.newEncoder(); + } + + /** Get the Charset used to decode bytes from the input stream. */ + public Charset getCharset() { + return this.cd.charset(); + } + + @Override + public void close() throws IOException { + stream.close(); + } + + @Override + public void mark(int readAheadLimit) throws IOException { + throw new IOException("mark/reset not supported."); + } + + @Override + public boolean markSupported() { + return false; + } + + @Override + public boolean ready() throws IOException { + return stream.available() != 0 || bbuf.remaining() != 0; + } + + @Override + public void reset() throws IOException { + throw new IOException("reset/mark not supported."); + } + + /** Skips 'n' characters, or as many as can be read off the stream + * before its end. + * + * Returns the number of characters actually skipped + */ + @Override + public long skip(long n) throws IOException { + char[] cbuf = new char[(int)Math.min(4096, n)]; + long m = n; + + while (m > 0) { + int r = read(cbuf, 0, (int)Math.min(cbuf.length, m)); + + if (r < 0) + return (n - m); + + m += Math.min(cbuf.length, m); + } + + return n; + } + + /** Unread a single code point. + * + * Decomposes the code point into UTF-16 surrogate pairs + * and unreads them using the char[] unreader function. + * + */ + @Override + public void unread(int c) throws IOException { + char[] ch = Character.toChars(c); + unread(ch, 0, ch.length); + } + + /** Unread the character array into the reader. + * + * Decodes the characters in the array into bytes, + * allowing the encoding to be changed before reading from + * the stream again, using a different charset. + */ + @Override + public void unread(char[] cbuf, int off, int len) throws IOException { + + ByteBuffer tb = // temp buffer + ce.encode(CharBuffer.wrap(cbuf, off, len)); + + if (tb.limit() > bbuf.position()) { + // unread bbuf into the pushback input stream + // in order to free up space for the content of 'tb' + for (int i = bbuf.limit(); i-- > bbuf.position(); ) + stream.unread(bbuf.get(i)); + + bbuf.clear(); + ce.encode(CharBuffer.wrap(cbuf, off, len), bbuf, true); + bbuf.flip(); + } else { + // Don't unread bbuf, since tb will fit in front of the + // existing data + int j = bbuf.position() - 1; + for (int i = tb.limit(); i-- > 0; j--) // two-counter loop + bbuf.put(j, tb.get(i)); + + bbuf.position(j+1); + } + } + + @Override + public void unread(char[] cbuf) throws IOException { + unread(cbuf, 0, cbuf.length); + } + + // fill bbuf, either when empty or when forced + private boolean ensureBbuf(boolean force) throws IOException { + if (bbuf.remaining() == 0 || force) { + bbuf.compact(); + + int size = stream.available(); + if (size > bbuf.remaining() || size == 0) + // by reading more than the available bytes when + // none available, block only if we need to on + // interactive streams + size = bbuf.remaining(); + + byte[] by = new byte[size]; + int c = stream.read(by); + + if (c < 0) { + bbuf.flip(); // prepare bbuf for reading + return false; + } + + bbuf.put(by, 0, c); + bbuf.flip(); + } + return true; + } + + @Override + public int read() throws IOException { + // read the first UTF-16 character + char[] ch = new char[1]; + + int i = read(ch, 0, 1); + if (i < 0) + return i; + + // if this is not a high surrogate, + // it must be a character which doesn't need one + if (! Character.isHighSurrogate(ch[0])) + return ch[0]; + + // save the high surrogate and read the low surrogate + char high = ch[0]; + i = read(ch, 0, 1); + if (i < 0) + return i; + + // combine the two and return the resulting code point + return Character.toCodePoint(high, ch[0]); + } + + @Override + public int read(char[] cbuf, int off, int len) throws IOException { + CharBuffer cb = CharBuffer.wrap(cbuf, off, len); + return read(cb); + } + + @Override + public int read(CharBuffer cb) throws IOException { + int len = cb.remaining(); + boolean notEof = true; + boolean forceRead = false; + + + while (cb.remaining() > 0 && notEof) { + notEof = ensureBbuf(forceRead); + CoderResult r = cd.decode(bbuf, cb, ! notEof); + forceRead = (CoderResult.UNDERFLOW == r); + + if (r.isMalformed()) { + throw new RACFMalformedInputException(bbuf.position(), + (char)bbuf.get(bbuf.position()), + cd.charset().name()); + } else if (r.isUnmappable()) { + // a situation exactly like this is in DecodingReader too + Debug.assertTrue(false); + } + } + if (cb.remaining() == len) + return -1; + else + return len - cb.remaining(); + } + + @Override + public int read(char[] cbuf) throws IOException { + return read(cbuf, 0, cbuf.length); + } + +} \ No newline at end of file From astalla at common-lisp.net Tue Jan 5 00:03:32 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 04 Jan 2010 19:03:32 -0500 Subject: [armedbear-cvs] r12331 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jan 4 19:03:30 2010 New Revision: 12331 Log: Cleanup in readFunctionBytes (Lisp.java), possibility to load compiled functions from remote jars. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java 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 Mon Jan 4 19:03:30 2010 @@ -1237,89 +1237,47 @@ coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue(thread)); } } - if (device instanceof Pathname) - { - // Are we loading a fasl from j.jar? - // XXX this will collide with file names from other JAR files - URL url = Lisp.class.getResource(namestring); - if (url == null) { - // Maybe device-->namestring references another JAR file? - String jarFile = ((Pathname)device).getNamestring(); - if (jarFile.startsWith("jar:file:")) { + if (device instanceof Pathname) { //Loading from a jar + URL url = null; + String jar = ((Pathname)device).getNamestring(); + if(jar.startsWith("jar:")) { + try { + url = new URL(jar + "!/" + namestring); + } catch (MalformedURLException ex) { + Debug.trace(ex); + } + } else { + url = Lisp.class.getResource(namestring); + } + if (url != null) { try { - url = new URL(jarFile + "!/" + namestring); - } catch (MalformedURLException ex) { - Debug.trace(ex); - } - } - } - 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 = ZipCache.getZip(zipFileName); - try - { - ZipEntry entry = zipFile.getEntry(entryName); - if (entry != null) - { - long size = entry.getSize(); - InputStream in = zipFile.getInputStream(entry); - return readFunctionBytes(in, (int) size); - } - else - { - // ASSERT type = "abcl" - entryName - = defaultPathname.name.getStringValue() - + "." + "abcl";//defaultPathname.type.getStringValue(); - return Utilities - .getZippedZipEntryAsByteArray(zipFile, - entryName, - namestring); - } - } - finally - { - ZipCache.removeZip(zipFile.getName()); - } - } - } - } - catch (VerifyError e) - { - error(new LispError("Class verification failed: " + - e.getMessage())); - return null; // not reached - } - catch (IOException e) - { + InputStream input = null; + java.io.ByteArrayOutputStream baos = new java.io.ByteArrayOutputStream(); + try { + input = url.openStream(); + 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); + } + } + bytes = baos.toByteArray(); + return bytes; + } finally { + baos.close(); + if(input != null) { + input.close(); + } + } + } catch (IOException e) { Debug.trace(e); - } - } + } + } error(new LispError("Unable to load " + namestring)); return null; // not reached - } + } Pathname pathname = new Pathname(namestring); final File file = Utilities.getFile(pathname, defaultPathname); if (file != null && file.isFile()) 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 Mon Jan 4 19:03:30 2010 @@ -393,7 +393,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); } From astalla at common-lisp.net Tue Jan 5 14:24:08 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 05 Jan 2010 09:24:08 -0500 Subject: [armedbear-cvs] r12332 - trunk/abcl/src/org/armedbear/lisp/scripting Message-ID: Author: astalla Date: Tue Jan 5 09:24:05 2010 New Revision: 12332 Log: Small change in an exception message. Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Tue Jan 5 09:24:05 2010 @@ -293,7 +293,7 @@ Symbol s = findSymbol("jmake-proxy", "JAVA"); JavaObject iface = new JavaObject(clasz); return (T) ((JavaObject) s.execute(iface, (LispObject) thiz)).javaInstance(); - } + } @Override public Object invokeFunction(String name, Object... args) throws ScriptException, NoSuchMethodException { @@ -322,7 +322,7 @@ @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."); + throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense. Use invokeFunction instead."); } public class AbclCompiledScript extends CompiledScript { From astalla at common-lisp.net Tue Jan 5 14:25:38 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 05 Jan 2010 09:25:38 -0500 Subject: [armedbear-cvs] r12333 - trunk/abcl Message-ID: Author: astalla Date: Tue Jan 5 09:25:38 2010 New Revision: 12333 Log: Removed unused patternsets from build.xml Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Tue Jan 5 09:25:38 2010 @@ -58,15 +58,6 @@ - - - - - - - - - From astalla at common-lisp.net Tue Jan 5 14:31:51 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 05 Jan 2010 09:31:51 -0500 Subject: [armedbear-cvs] r12334 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jan 5 09:31:50 2010 New Revision: 12334 Log: Added convenience constructors to Stream. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java 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 Tue Jan 5 09:31:50 2010 @@ -122,10 +122,18 @@ { } + public Stream(InputStream stream) { + initAsBinaryInputStream(stream); + } + public Stream(Reader r) { initAsCharacterInputStream(r); } + public Stream(OutputStream stream) { + initAsBinaryOutputStream(stream); + } + public Stream(Writer w) { initAsCharacterOutputStream(w); } From mevenson at common-lisp.net Tue Jan 5 17:15:40 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 05 Jan 2010 12:15:40 -0500 Subject: [armedbear-cvs] r12335 - in trunk/abcl: . test/lisp/cl-bench Message-ID: Author: mevenson Date: Tue Jan 5 12:15:35 2010 New Revision: 12335 Log: Initial fix for support for running cl-bench test suite from Ant build via ASDF. This probably doesn't work on win32 without 'make' in your path. Running the cl-bench suite now works via the 'test.cl-bench' target if the test suite has been downloaded from "http://www.chez.com/emarsden/downloads/cl-bench.tar.gz" and placed in a sibling directory (#p../cl-bench/) to ABCL root. Move the cl-bench ASDF description into 'abcl.asd' now that I have finally understood (?) the correct CLOS method invocation. Added: trunk/abcl/test/lisp/cl-bench/wrapper.lisp Removed: trunk/abcl/test/lisp/cl-bench/cl-bench.asd Modified: trunk/abcl/abcl.asd trunk/abcl/build.xml Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Tue Jan 5 12:15:35 2010 @@ -23,11 +23,12 @@ :depends-on (:ansi-compiled #+nil :abcl-tests)) (defmethod perform :after ((o load-op) (c (eql (find-system :abcl)))) - #+nil (asdf:oos 'asdf:test-op :cl-bench :force t) + (operate 'load-op :cl-bench :force t) (operate 'load-op :abcl-test-lisp :force t) (operate 'load-op :ansi-compiled :force t) (operate 'load-op :ansi-interpreted :force t)) +#+nil (defmethod perform :before ((o load-op) (c t)) (warn "ASDF load-op class is ~A" c)) @@ -68,6 +69,16 @@ (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." (funcall (intern (symbol-name 'run) :abcl-test))) + +(defsystem :cl-bench :components + ((:module cl-bench-wrapper :pathname "test/lisp/cl-bench/" :components + ((:file "wrapper"))))) + +(defmethod perform :before ((o test-op) (c (eql (find-system :cl-bench)))) + (operate 'load-op :cl-bench :force t)) + +(defmethod perform ((o test-op) (c (eql (find-system :cl-bench)))) + (funcall (intern (symbol-name 'run) :abcl.test.cl-bench))) ;;; Build ABCL from a Lisp. ;;; aka the "Lisp-hosted build system" Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Tue Jan 5 12:15:35 2010 @@ -665,6 +665,22 @@ 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: trunk/abcl/test/lisp/cl-bench/wrapper.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/cl-bench/wrapper.lisp Tue Jan 5 12:15:35 2010 @@ -0,0 +1,29 @@ +(defpackage :abcl.test.cl-bench + (:use :cl :asdf) + (:nicknames "cl-bench") + (:export run)) + +(in-package :abcl.test.cl-bench) + +(defparameter *cl-bench-master-source-location* + "") + +(defparameter *cl-bench-directory* + (merge-pathnames #p"../cl-bench/" + (component-pathname (find-system :abcl)))) + +(defun run () + (unless (probe-file *cl-bench-directory*) + (format t "Failed to find the cl-bench test suite in '~A'. ~ +Please manually download and extract the cl-bench tool suite from ~A to run the tests." + *cl-bench-directory* + *cl-bench-master-source-location*)) + (let ((*default-pathname-defaults* *cl-bench-directory*)) + (if (find :unix *features*) + (run-shell-command + (format nil "cd ~A; make clean optimize-files" *cl-bench-directory*)) + (run-shell-command "cd ~A && make clean optimize-files" *cl-bench-directory*)) + (load "generate.lisp") + (load "do-compilation-script.lisp") + (load "do-execute-script.lisp"))) + From ehuelsmann at common-lisp.net Tue Jan 5 21:33:30 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 05 Jan 2010 16:33:30 -0500 Subject: [armedbear-cvs] r12336 - trunk/abcl Message-ID: Author: ehuelsmann Date: Tue Jan 5 16:33:26 2010 New Revision: 12336 Log: Update changes with 0.18 items. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Tue Jan 5 16:33:26 2010 @@ -1,3 +1,38 @@ +Version 0.18.0 +============== + + +Features: + + * Programmable handling of out-of-memory and stack-overflow conditions + * Faster initial startup (to support Google App Engine) + * Faster special variable lookup + * New interface for binding/unwinding special variables + * Implement (SETF (STREAM-EXTERNAL-FORMAT ) ) + * Implement (SETF (JAVA:JFIELD ) ) + * Programmatic handling of out-of-memory and stack-overflow + * Constant FORMAT strings get compiled for performance + + +Bugs fixed: + + * FASLs are system default encoding dependent (ticket 77) + * I/O of charset-unsupported characters causes infinite loop (ticket 76) + * Memory leak where on unused functions with documentation + * ANSI PRINT-LEVEL.* tests + * Continued execution after failing to handle Throwable exceptions + * Line numbers in generated java classes incorrect + * JCALL, JNEW doesn't select best match when multiple applicable methods + * STREAM-EXTERNAL-FORMAT always returns :DEFAULT, instead of actual format + + +Other changes + + * LispObject does not inherit from Lisp anymore + * Many functions declared 'final' for performance improvement + + + Version 0.17.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/0.17.0/abcl From mevenson at common-lisp.net Tue Jan 5 22:27:16 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 05 Jan 2010 17:27:16 -0500 Subject: [armedbear-cvs] r12337 - in trunk/abcl: . test/lisp/cl-bench Message-ID: Author: mevenson Date: Tue Jan 5 17:27:13 2010 New Revision: 12337 Log: cl-bench now runs correctly from UNIX systems. Increment the abcl.asd version to note the inclusion of cl-bench. The absence of the cl-build source is not as well reported, but we now load the cl-bench/defpackage code to define the cl-bench packages as part of the ASDF step. Modified: trunk/abcl/abcl.asd trunk/abcl/test/lisp/cl-bench/wrapper.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Tue Jan 5 17:27:13 2010 @@ -7,7 +7,7 @@ (in-package :abcl-asdf) ;;; Wrapper for all ABCL ASDF definitions. -(defsystem :abcl :version "0.3.1") +(defsystem :abcl :version "0.4.0") (defmethod perform :after ((o load-op) (c (eql (find-system :abcl)))) ;;; Additional test suite loads would go here. @@ -71,8 +71,11 @@ (funcall (intern (symbol-name 'run) :abcl-test))) (defsystem :cl-bench :components - ((:module cl-bench-wrapper :pathname "test/lisp/cl-bench/" :components - ((:file "wrapper"))))) + ((:module cl-bench-package :pathname "../cl-bench/" + :components ((:file "defpackage"))) + (:module cl-bench-wrapper :pathname "test/lisp/cl-bench/" + :depends-on (cl-bench-package) :components + ((:file "wrapper"))))) (defmethod perform :before ((o test-op) (c (eql (find-system :cl-bench)))) (operate 'load-op :cl-bench :force t)) Modified: trunk/abcl/test/lisp/cl-bench/wrapper.lisp ============================================================================== --- trunk/abcl/test/lisp/cl-bench/wrapper.lisp (original) +++ trunk/abcl/test/lisp/cl-bench/wrapper.lisp Tue Jan 5 17:27:13 2010 @@ -12,12 +12,19 @@ (merge-pathnames #p"../cl-bench/" (component-pathname (find-system :abcl)))) +;;; cl-bench defines BENCH-GC and WITH-SPAWNED-THREAD in +;;; '*cl-bench-directory*/sysdep/setup-ablisp.lisp'. +(defun cl-bench::bench-gc () (ext:gc)) +(defmacro cl-bench::with-spawned-thread (&body body) + `(progn , at body)) + (defun run () (unless (probe-file *cl-bench-directory*) - (format t "Failed to find the cl-bench test suite in '~A'. ~ -Please manually download and extract the cl-bench tool suite from ~A to run the tests." - *cl-bench-directory* - *cl-bench-master-source-location*)) + (error "Failed to find the cl-bench test suite in '~A'.~% +Please manually download and extract the cl-bench tool suite~% +from ~A to run the tests." + *cl-bench-directory* + *cl-bench-master-source-location*)) (let ((*default-pathname-defaults* *cl-bench-directory*)) (if (find :unix *features*) (run-shell-command From mevenson at common-lisp.net Wed Jan 6 15:52:20 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 06 Jan 2010 10:52:20 -0500 Subject: [armedbear-cvs] r12338 - in trunk/abcl: . test/lisp/ansi Message-ID: Author: mevenson Date: Wed Jan 6 10:52:13 2010 New Revision: 12338 Log: Reworked test infrastructure. Use ASDF to invoke all tests from Ant. Add working test for Ant version at least 1.7.1. Changed structure of 'build.xml' slightly to emphasize 'help' target by placing it first. Include cl-bench tests in 'abcl.test.lisp' Ant target. Added 'help.test' target for help invoking tests. abcl.asd now works for invoking tests. ASDF systems with empty component specifications must be invoked with the :force t option to execute correctly. Removed: trunk/abcl/test/lisp/ansi/ansi-tests-compiled.lisp trunk/abcl/test/lisp/ansi/ansi-tests-interpreted.lisp Modified: trunk/abcl/abcl.asd trunk/abcl/build.xml Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Wed Jan 6 10:52:13 2010 @@ -7,79 +7,84 @@ (in-package :abcl-asdf) ;;; Wrapper for all ABCL ASDF definitions. -(defsystem :abcl :version "0.4.0") +(defsystem :abcl :version "0.5.0") (defmethod perform :after ((o load-op) (c (eql (find-system :abcl)))) - ;;; Additional test suite loads would go here. - (operate 'load-op :test-abcl :force t)) - -(defmethod perform ((o test-op) (c (eql (find-system :abcl)))) - ;;; Additional test suite invocations would go here. - (operate 'test-op :ansi-compiled :force t)) - -;;; A collection of test suites for ABCL. -(defsystem :test-abcl - :version "0.3.1" - :depends-on (:ansi-compiled #+nil :abcl-tests)) - -(defmethod perform :after ((o load-op) (c (eql (find-system :abcl)))) - (operate 'load-op :cl-bench :force t) + (operate 'load-op :abcl-tests :force t) (operate 'load-op :abcl-test-lisp :force t) + (operate 'load-op :cl-bench :force t) (operate 'load-op :ansi-compiled :force t) (operate 'load-op :ansi-interpreted :force t)) -#+nil -(defmethod perform :before ((o load-op) (c t)) - (warn "ASDF load-op class is ~A" c)) - -(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)." - (funcall (intern (symbol-name 'run) :abcl.test.ansi) - :compile-tests nil)) -(defmethod perform :before ((o test-op) (c (eql (find-system - :ansi-interpreted)))) - (operate 'load-op :ansi-interpreted :force t)) +;;; Run via (asdf:operate 'asdf:test-op :abcl :force t) +(defmethod perform ((o test-op) (c (eql (find-system :abcl)))) + (operate 'test-op :abcl-tests :force t)) -(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)) -(defmethod perform :before ((o test-op) (c (eql (find-system - :ansi-compiled)))) - (operate 'load-op :ansi-compiled :force t)) +;;; A collection of test suites for ABCL. +(defsystem :abcl-tests + :version "2.0" + :depends-on (:abcl-test-lisp + :ansi-compiled :ansi-interpreted + :cl-bench)) + +(defmethod perfom :before ((o test-op (c (eql find-system :abcl-tests)))) + (operate 'load-op :abcl-test-lisp) + (operate 'load-op :ansi-compiled) + (operate 'load-op :cl-bench)) + +;;; Run via (asdf:operate 'asdf:test-op :abcl-tests :force t) +(defmethod perform ((o test-op) (c (eql (find-system :abcl-tests)))) + ;; Additional test suite invocations would go here. + (operate 'test-op :abcl-test-lisp) + (operate 'test-op :ansi-compiled) + (operate 'test-op :cl-bench)) +;;; Test ABCL with the Lisp unit tests collected in "test/lisp/abcl" (defsystem :abcl-test-lisp :version "1.1" :components ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components ((:file "rt-package") (:file "rt"))) (:module package :depends-on (abcl-rt) :pathname "test/lisp/abcl/" :components ((:file "package"))))) - (defmethod perform :before ((o test-op) (c (eql (find-system :abcl-test-lisp)))) (operate 'load-op :abcl-test-lisp :force t)) - (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." (funcall (intern (symbol-name 'run) :abcl-test))) +;;; Test ABCL with the interpreted ANSI tests +(defsystem :ansi-interpreted :version "1.0.1" + :components + ((:module ansi-tests :pathname "test/lisp/ansi/" :components + ((:file "package"))))) +(defmethod perform :before ((o test-op) (c (eql (find-system :ansi-interpreted)))) + (operate 'load-op :ansi-interpreted)) +(defmethod perform ((o test-op) (c (eql (find-system :ansi-interpreted)))) + (funcall (intern (symbol-name 'run) :abcl.test.ansi) + :compile-tests nil)) + +;;; Test ABCL with the compiled ANSI tests +(defsystem :ansi-compiled :version "1.0.1" + :components + ((:module ansi-tests :pathname "test/lisp/ansi/" :components + ((:file "package"))))) +(defmethod perform :before ((o test-op) (c (eql (find-system :ansi-compiled)))) + (operate 'load-op :ansi-compiled)) +(defmethod perform ((o test-op) (c (eql (find-system :ansi-compiled)))) + (funcall (intern (symbol-name 'run) :abcl.test.ansi) + :compile-tests t)) + + +;;; Test ABCL with CL-BENCH (defsystem :cl-bench :components ((:module cl-bench-package :pathname "../cl-bench/" :components ((:file "defpackage"))) (:module cl-bench-wrapper :pathname "test/lisp/cl-bench/" :depends-on (cl-bench-package) :components ((:file "wrapper"))))) - (defmethod perform :before ((o test-op) (c (eql (find-system :cl-bench)))) (operate 'load-op :cl-bench :force t)) - (defmethod perform ((o test-op) (c (eql (find-system :cl-bench)))) (funcall (intern (symbol-name 'run) :abcl.test.cl-bench))) Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Wed Jan 6 10:52:13 2010 @@ -4,7 +4,30 @@ Compiling, testing, and packaging Armed Bear Common Lisp + + + +Main Ant targets: + + abcl.wrapper + -- [default] create executable wrapper for ABCL. + abcl.compile + -- compile ABCL to ${build.classes.dir}. + abcl.jar + -- create packaged ${abcl.jar.path}. + abcl.source.zip abcl.source.tar + -- create source distributions in ${dist.dir}. + abcl.clean + -- remove ABCL intermediate files + + +For help on the automatic tests available, use the Ant target 'help.test'. + + + + - - - 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}. - abcl.test.java - -- Run junit tests under ${abcl.test.src.dir}. - abcl.clean - -- remove ABCL intermediate files - Corresponding targets for J have been removed. - + + + + + + + + - @@ -426,12 +438,11 @@ - - - + @@ -558,6 +569,35 @@ + + +The following Ant targets run various test suites: + + abcl.test + -- Run all available tests. + abcl.test.java + -- Run the ABCL junit Java tests under ${basedir}/test/src + abcl.test.lisp + -- Run the 'test.ansi.compiled', 'test.abcl', 'test.cl-bench' targets + test.ansi.compiled + -- Run the compiled version of the ANSI test suite + test.abcl + -- Run the Lisp RT tests collected in ${basedir}/test/lisp/abcl + test.cl-bench + -- Run the cl-bench test suite. + +The ANSI tests require that the [ansi-tests][1] be manually installed in +${basedir}/../ansi-tests. + +[1]: svn://common-lisp.net/project/ansi-test/svn/trunk/ansi-tests + +The CL-BENCH test require that [cl-bench][2] be maunally installed in +${basedir}/../cl-bench + +[2]: http://www.chez.com/emarsden/downloads/cl-bench.tar.gz + + + @@ -581,7 +621,8 @@ - + @@ -621,7 +662,7 @@ + depends="test.ansi.compiled,test.abcl,test.cl-bench"/> Recording test output in ${abcl.test.log.file}. @@ -630,8 +671,10 @@ classpathref="abcl.classpath.dist" classname="org.armedbear.lisp.Main"> - - + + + + Finished recording test output in ${abcl.test.log.file}. @@ -644,8 +687,10 @@ classpathref="abcl.classpath.dist" classname="org.armedbear.lisp.Main"> - - + + + + Finished recording test output in ${abcl.test.log.file}. @@ -658,8 +703,10 @@ classpathref="abcl.classpath.dist" classname="org.armedbear.lisp.Main"> - - + + + + Finished recording test output in ${abcl.test.log.file}. @@ -675,6 +722,7 @@ + Finished recording test output in ${abcl.test.log.file}. @@ -686,3 +734,6 @@ + + + From astalla at common-lisp.net Wed Jan 6 22:01:09 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 06 Jan 2010 17:01:09 -0500 Subject: [armedbear-cvs] r12339 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Jan 6 17:01:05 2010 New Revision: 12339 Log: Removed aggressive installation of preloaded functions that caused spurious redefinition warnings. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Wed Jan 6 17:01:05 2010 @@ -278,7 +278,6 @@ fun = new AutoloadedFunctionProxy(sym, name, cache, cachedSyms, fType); - installFunction(fType, sym, fun); } return fun; From ehuelsmann at common-lisp.net Wed Jan 6 22:10:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 06 Jan 2010 17:10:35 -0500 Subject: [armedbear-cvs] r12340 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 6 17:10:33 2010 New Revision: 12340 Log: Fix symbol-macrolet expanding variables declared in a lambda-list for LAMBDA and NAMED-LAMBDA forms. 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 Wed Jan 6 17:10:33 2010 @@ -569,12 +569,48 @@ (precompile1 (second arg))) (push new-arg new)))))) +(defun extract-lambda-vars (lambda-list) + (let ((state :required) + vars) + (dolist (var/key lambda-list vars) + (cond + ((eq '&aux var/key) (setf state :aux)) + ((eq '&key var/key) (setf state :key)) + ((eq '&optional var/key) (setf state :optional)) + ((eq '&rest var/key) (setf state :rest)) + ((symbolp var/key) (unless (eq var/key '&allow-other-keys) + (push var/key vars))) + ((and (consp var/key) + (member state '(:optional :key))) + (setf var/key (car var/key)) + (when (and (consp var/key) (eq state :key)) + (setf var/key (second var/key))) + (if (symbolp var/key) + (push var/key vars) + (error 'program-error + :format-control + "Unexpected ~A variable specifier ~A." + :format-arguments (list state var/key)))) + ((and (consp var/key) (eq state :aux)) + (if (symbolp (car var/key)) + (push (car var/key) vars) + (error 'program-error + :format-control "Unexpected &AUX format for ~A." + :format-arguments (list var/key)))) + (t + (error 'program-error + :format-control "Unexpected lambda-list format: ~A." + :format-arguments (list lambda-list))))))) + (defun precompile-lambda (form) (let ((body (cddr form)) (precompiled-lambda-list (precompile-lambda-list (cadr form))) - (*inline-declarations* *inline-declarations*)) + (*inline-declarations* *inline-declarations*) + (*precompile-env* (make-environment *precompile-env*))) (process-optimization-declarations body) + (dolist (var (extract-lambda-vars precompiled-lambda-list)) + (environment-add-symbol-binding *precompile-env* var nil)) (list* 'LAMBDA precompiled-lambda-list (mapcar #'precompile1 body)))) @@ -583,8 +619,11 @@ (let ((body (cddr lambda-form)) (precompiled-lambda-list (precompile-lambda-list (cadr lambda-form))) - (*inline-declarations* *inline-declarations*)) + (*inline-declarations* *inline-declarations*) + (*precompile-env* (make-environment *precompile-env*))) (process-optimization-declarations body) + (dolist (var (extract-lambda-vars precompiled-lambda-list)) + (environment-add-symbol-binding *precompile-env* var nil)) (list* 'NAMED-LAMBDA (cadr form) precompiled-lambda-list (mapcar #'precompile1 body))))) From ehuelsmann at common-lisp.net Wed Jan 6 22:24:24 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 06 Jan 2010 17:24:24 -0500 Subject: [armedbear-cvs] r12341 - trunk/abcl Message-ID: Author: ehuelsmann Date: Wed Jan 6 17:24:24 2010 New Revision: 12341 Log: Remove double entry; add recent fix to CHANGES. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Wed Jan 6 17:24:24 2010 @@ -10,7 +10,6 @@ * New interface for binding/unwinding special variables * Implement (SETF (STREAM-EXTERNAL-FORMAT ) ) * Implement (SETF (JAVA:JFIELD ) ) - * Programmatic handling of out-of-memory and stack-overflow * Constant FORMAT strings get compiled for performance @@ -24,6 +23,7 @@ * Line numbers in generated java classes incorrect * JCALL, JNEW doesn't select best match when multiple applicable methods * STREAM-EXTERNAL-FORMAT always returns :DEFAULT, instead of actual format + * Lambda-list variables replaced by surrounding SYMBOL-MACROLET Other changes From vvoutilainen at common-lisp.net Thu Jan 7 19:01:58 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 07 Jan 2010 14:01:58 -0500 Subject: [armedbear-cvs] r12342 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu Jan 7 14:01:55 2010 New Revision: 12342 Log: Convert LispErrors to ProgramErrors, convert a couple of asserts to ProgramErrors. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java 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 Jan 7 14:01:55 2010 @@ -99,7 +99,7 @@ final LispObject lambdaList = lambdaExpression.cadr(); setLambdaList(lambdaList); if (!(lambdaList == NIL || lambdaList instanceof Cons)) - error(new LispError("The lambda list " + lambdaList.writeToString() + + error(new ProgramError("The lambda list " + lambdaList.writeToString() + " is invalid.")); boolean _andKey = false; boolean _allowOtherKeys = false; @@ -136,10 +136,14 @@ remaining = remaining.cdr(); if (remaining == NIL) { - error(new LispError( + error(new ProgramError( "&REST/&BODY must be followed by a variable.")); } - Debug.assertTrue(restVar == null); + if (restVar != null) + { + error(new ProgramError( + "&REST/&BODY may occur only once.")); + } final LispObject remainingcar = remaining.car(); if (remainingcar instanceof Symbol) { @@ -147,7 +151,7 @@ } else { - error(new LispError( + error(new ProgramError( "&REST/&BODY must be followed by a variable.")); } } @@ -194,7 +198,11 @@ } else { - Debug.assertTrue(state == STATE_REQUIRED); + if (state != STATE_REQUIRED) + { + error(new ProgramError( + "required parameters cannot appear after &REST/&BODY.")); + } if (required == null) required = new ArrayList(); required.add(new Parameter((Symbol)obj)); @@ -342,7 +350,7 @@ private static final void invalidParameter(LispObject obj) { - error(new LispError(obj.writeToString() + + error(new ProgramError(obj.writeToString() + " may not be used as a variable in a lambda list.")); } From mevenson at common-lisp.net Fri Jan 8 08:22:58 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 08 Jan 2010 03:22:58 -0500 Subject: [armedbear-cvs] r12343 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Fri Jan 8 03:22:55 2010 New Revision: 12343 Log: Adjust tests for jar:file syntax should work with TRUENAME. Modified: trunk/abcl/test/lisp/abcl/jar-file.lisp Modified: trunk/abcl/test/lisp/abcl/jar-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-file.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-file.lisp Fri Jan 8 03:22:55 2010 @@ -16,7 +16,6 @@ (defvar *jar-file-init* nil) - (defmacro with-jar-file-init (&rest body) `(let ((*default-pathname-defaults* *this-directory*)) (progn @@ -69,7 +68,8 @@ (deftest jar-file-probe-file.1 (with-jar-file-init (probe-file "jar:file:baz.jar!/eek.lisp")) - #p"jar:file:baz.jar!/eek.lisp") + #p"jar:file:baz.jar!/eek.lisp") ; WRONG: PROBE-FILE should return + ; TRUENAME on existence. (deftest jar-file-merge-pathnames.1 @@ -77,7 +77,11 @@ "!/foo" #p"jar:file:baz.jar") #p"jar:file:baz.jar!/foo") - +(deftest jar-file-truename.1 + (truename "jar:file:baz.jar!/foo") + (format nil "jar:file:~S/baz.jar!/foo" + *this-directory*)) + From astalla at common-lisp.net Fri Jan 8 19:02:45 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 08 Jan 2010 14:02:45 -0500 Subject: [armedbear-cvs] r12344 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 8 14:02:42 2010 New Revision: 12344 Log: Fixed loading of compressed FASLs (.abcl) from jar files when the FASL is in a subdirectory. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java 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 Fri Jan 8 14:02:42 2010 @@ -227,7 +227,11 @@ // have to decompress it first, and seek for the '._' // init FASL. int i = zipEntryName.lastIndexOf('.'); - String subZipEntryName = zipEntryName.substring(0, i).concat("._"); + int j = zipEntryName.lastIndexOf('/'); + if(j >= i) { + return error(new LispError("Invalid zip entry name: " + zipEntryName)); + } + String subZipEntryName = zipEntryName.substring(j + 1, i).concat("._"); in = Utilities.getZippedZipEntryAsInputStream(zipfile, zipEntryName, subZipEntryName); From astalla at common-lisp.net Fri Jan 8 19:55:08 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 08 Jan 2010 14:55:08 -0500 Subject: [armedbear-cvs] r12345 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 8 14:55:05 2010 New Revision: 12345 Log: Use of the "intended class" of an object before the actual class to access it via reflection. 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 Fri Jan 8 14:55:05 2010 @@ -45,8 +45,7 @@ import java.lang.reflect.InvocationTargetException; import java.lang.reflect.Method; import java.lang.reflect.Modifier; -import java.util.HashMap; -import java.util.Map; +import java.util.*; public final class Java { @@ -201,7 +200,7 @@ f.set(instance,args[3].javaInstance(fieldType)); return args[3]; } - return JavaObject.getInstance(f.get(instance), translate); + return JavaObject.getInstance(f.get(instance), translate, f.getType()); } catch (NoSuchFieldException e) { error(new LispError("no such field")); @@ -365,17 +364,16 @@ if (c != null) { String methodName = methodRef.getStringValue(); Method[] methods = c.getMethods(); + List staticMethods = new ArrayList(); 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; - } - } + for(Method m1 : methods) { + if(Modifier.isStatic(m1.getModifiers())) { + staticMethods.add(m1); + } + } + if(staticMethods.size() > 0) { + m = findMethod(staticMethods.toArray(new Method[staticMethods.size()]), methodName, args); + } if (m == null) error(new LispError("no such method")); } @@ -391,7 +389,7 @@ methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); } Object result = m.invoke(null, methodArgs); - return JavaObject.getInstance(result, translate); + return JavaObject.getInstance(result, translate, m.getReturnType()); } catch (ControlTransfer c) { throw c; @@ -630,26 +628,55 @@ { if (args.length < 2) error(new WrongNumberOfArgumentsException(fun)); - 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 { - instance = instanceArg.javaInstance(); - } try { - final Method method; + final LispObject methodArg = args[0]; + final LispObject instanceArg = args[1]; + final Object instance; + Class intendedClass = null; + if (instanceArg instanceof AbstractString) { + instance = instanceArg.getStringValue(); + } else if (instanceArg instanceof JavaObject) { + JavaObject jobj = ((JavaObject)instanceArg); + instance = jobj.getObject(); + intendedClass = jobj.getIntendedClass(); + } else { + instance = instanceArg.javaInstance(); + } + if(instance == null) { + throw new NullPointerException(); //Handled below + } + Method method; + Object[] methodArgs; if (methodArg instanceof AbstractString) { + methodArgs = translateMethodArguments(args, 2); String methodName = methodArg.getStringValue(); - Class c = instance.getClass(); - method = findMethod(c, methodName, args); + if(intendedClass == null) { + intendedClass = instance.getClass(); + } + method = findMethod(intendedClass, methodName, methodArgs); + Class actualClass = null; + if(method == null) { + actualClass = instance.getClass(); + if(intendedClass != actualClass && + Modifier.isPublic(actualClass.getModifiers())) { + method = findMethod(actualClass, methodName, methodArgs); + } + } + if (method == null) { + String classes = intendedClass.getName(); + if(actualClass != null && actualClass != intendedClass) { + classes += " or " + actualClass.getName(); + } + throw new NoSuchMethodException("No applicable method named " + methodName + " found in " + classes); + } + } else method = (Method) JavaObject.getObject(methodArg); Class[] argTypes = (Class[])method.getParameterTypes(); - Object[] methodArgs = new Object[args.length - 2]; + if(argTypes.length != args.length - 2) { + return error(new WrongNumberOfArgumentsException("Wrong number of arguments for " + method + ": expected " + argTypes.length + ", got " + (args.length - 2))); + } + methodArgs = new Object[argTypes.length]; for (int i = 2; i < args.length; i++) { LispObject arg = args[i]; if (arg == NIL) @@ -658,7 +685,8 @@ methodArgs[i-2] = arg.javaInstance(argTypes[i-2]); } return JavaObject.getInstance(method.invoke(instance, methodArgs), - translate); + translate, + method.getReturnType()); } catch (ControlTransfer t) { throw t; @@ -699,10 +727,8 @@ return javaArgs; } - private static Method findMethod(Class c, String methodName, LispObject[] args) throws NoSuchMethodException { - int argCount = args.length - 2; - Object[] javaArgs = translateMethodArguments(args, 2); - Method[] methods = c.getMethods(); + private static Method findMethod(Method[] methods, String methodName, Object[] javaArgs) { + int argCount = javaArgs.length; Method result = null; for (int i = methods.length; i-- > 0;) { Method method = methods[i]; @@ -720,12 +746,24 @@ result = method; } } - if (result == null) { - throw new NoSuchMethodException(methodName); - } return result; } + private static Method findMethod(Class c, String methodName, Object[] javaArgs) { + Method[] methods = c.getMethods(); + return findMethod(methods, methodName, javaArgs); + } + + private static Method findMethod(Class c, String methodName, LispObject[] args) { + Object[] javaArgs = translateMethodArguments(args, 2); + return findMethod(c, methodName, javaArgs); + } + + private static Method findMethod(Method[] methods, String methodName, LispObject[] args) { + Object[] javaArgs = translateMethodArguments(args, 2); + return findMethod(methods, methodName, javaArgs); + } + private static Constructor findConstructor(Class c, LispObject[] args) throws NoSuchMethodException { int argCount = args.length - 1; Object[] javaArgs = translateMethodArguments(args, 1); @@ -877,6 +915,23 @@ return JavaObject.getInstance(arg.javaInstance(), true); } }; + + // ### jcoerce java-object intended-class + private static final Primitive JCOERCE = + new Primitive("jcoerce", PACKAGE_JAVA, true, "java-object intended-class") + { + @Override + public LispObject execute(LispObject javaObject, LispObject intendedClass) + { + Object o = javaObject.javaInstance(); + Class c = javaClass(intendedClass); + try { + return JavaObject.getInstance(o, c); + } catch(ClassCastException e) { + return error(new TypeError(javaObject, new SimpleString(c.getName()))); + } + } + }; private static final Primitive JGET_PROPERTY_VALUE = new Primitive("%jget-property-value", PACKAGE_JAVA, true, 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 Fri Jan 8 14:55:05 2010 @@ -41,13 +41,30 @@ import java.util.*; -public final class JavaObject extends LispObject -{ +public final class JavaObject extends LispObject { private final Object obj; + private final Class intendedClass; - public JavaObject(Object obj) - { + public JavaObject(Object obj) { this.obj = obj; + this.intendedClass = obj != null ? obj.getClass() : null; + } + + /** + * Constructs a Java Object with the given intended class, used to access + * the object reflectively. + * @throws ClassCastException if the object is not an instance of the + * intended class. + */ + public JavaObject(Object obj, Class intendedClass) { + if(obj != null && intendedClass == null) { + intendedClass = obj.getClass(); + } + if(intendedClass != null && !intendedClass.isInstance(obj)) { + throw new ClassCastException(obj + " can not be cast to " + intendedClass); + } + this.obj = obj; + this.intendedClass = intendedClass; } @Override @@ -102,6 +119,24 @@ /** Encapsulates obj, if required. * If obj is a {@link LispObject}, it's returned as-is. + * If not, a java object with the specified intended class is returned. + * + * @param obj Any java object + * @param intendedClass the class that shall be used to access obj + * @return obj or a new JavaObject encapsulating obj + */ + public final static LispObject getInstance(Object obj, Class intendedClass) { + if (obj == null) + return new JavaObject(null); + + if (obj instanceof LispObject) + return (LispObject)obj; + + return new JavaObject(obj, intendedClass); + } + + /** 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. * @@ -109,11 +144,29 @@ * @param translated * @return a LispObject representing or encapsulating obj */ - public final static LispObject getInstance(Object obj, boolean translated) + public final static LispObject getInstance(Object obj, boolean translated) { + return getInstance(obj, translated, obj != null ? obj.getClass() : null); + } - { + + + /** 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 + * @param intendedClass the class that shall be used to reflectively + * access obj; it is an error for obj not to be + * an instance of this class. This parameter is ignored + * if translated == true and the object can be + * converted to a Lisp object. + * @return a LispObject representing or encapsulating obj + */ + public final static LispObject getInstance(Object obj, boolean translated, Class intendedClass) { if (! translated) - return getInstance(obj); + return getInstance(obj, intendedClass); if (obj == null) return NIL; @@ -167,18 +220,23 @@ // We might want to handle: // - streams // - others? - return new JavaObject(obj); + return new JavaObject(obj, intendedClass); } @Override - public Object javaInstance() - { + public Object javaInstance() { return obj; } @Override public Object javaInstance(Class c) { - return javaInstance(); + if(obj == null) { + return obj; + } else if(c.isAssignableFrom(intendedClass)) { + return obj; + } else { + return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); + } } /** Returns the encapsulated Java object for @@ -191,6 +249,10 @@ return obj; } + public Class getIntendedClass() { + return intendedClass; + } + public static final Object getObject(LispObject o) { From ehuelsmann at common-lisp.net Fri Jan 8 20:39:53 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Jan 2010 15:39:53 -0500 Subject: [armedbear-cvs] r12346 - branches/0.18.x Message-ID: Author: ehuelsmann Date: Fri Jan 8 15:39:49 2010 New Revision: 12346 Log: Branch 0.18.x for release stabilization. Added: branches/0.18.x/ - copied from r12345, /trunk/ From ehuelsmann at common-lisp.net Fri Jan 8 20:42:11 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Jan 2010 15:42:11 -0500 Subject: [armedbear-cvs] r12347 - public_html Message-ID: Author: ehuelsmann Date: Fri Jan 8 15:42:09 2010 New Revision: 12347 Log: Create preliminary 0.18 release notes. Added: public_html/release-notes-0.18.shtml (contents, props changed) Added: public_html/release-notes-0.18.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.18.shtml Fri Jan 8 15:42:09 2010 @@ -0,0 +1,70 @@ + + + + + ABCL - Release notes v0.17 + + + + + +
+

ABCL - Release notes for version 0.18

+
+ + + +
+ +

Most notable changes in ABCL 0.18

+ + +

Release notes for older releases.

+ + + +
+
Faster initial startup
+
To achieve faster startup times - required for example by + Google App Engine which restarts the servlet regularly - + ABCL now delays reflection calls associated function-class + resolution by resolving functions upon their first call.
+
Portable FASLs
+
As part of a fixed bug, ABCL now has portable fasls: all + fasls use UTF-8 as their encoding, instead of the system dependent + default encoding. This should help easy deployment and deployment + to Google App Engine. Because of this change, the FASL version + number has increased to 35.
+
Faster special variable lookup
+
As part of the continued search for performance improvements + has the lookup mechanism for special variable value lookup been + changed. Part of this change is the introduction of an API to + record unbinding marks for unwinding later on.
+
Improved reliability with exceptions
+
Out-of-memory or Stack-overflow conditions can be handled + programatically by binding handlers for them in handler-bind. + In addition, program execution used to continue on caught but + unhandled generic (Throwable) exceptions. This is no longer + the case: only specific exceptions get caught, or the generic + exception is handled, preventing execution from 'just' continuing.
+
Fixed memory leak with functions-with-documentation
+
Functions with documentation going out of scope because of + being unused were incorrectly not GC-ed. This has now been resolved.
+
+ + + + + +
+
+

Back to Common-lisp.net.

+ + +
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
+ + From ehuelsmann at common-lisp.net Fri Jan 8 20:47:39 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Jan 2010 15:47:39 -0500 Subject: [armedbear-cvs] r12348 - branches/scripting Message-ID: Author: ehuelsmann Date: Fri Jan 8 15:47:38 2010 New Revision: 12348 Log: Remove branch merged to trunk long ago. Removed: branches/scripting/ From ehuelsmann at common-lisp.net Fri Jan 8 20:52:55 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 08 Jan 2010 15:52:55 -0500 Subject: [armedbear-cvs] r12349 - branches/jnlp Message-ID: Author: ehuelsmann Date: Fri Jan 8 15:52:54 2010 New Revision: 12349 Log: Delete branch which is long out-dated and not pursued at the moment. Removed: branches/jnlp/ From astalla at common-lisp.net Fri Jan 8 20:59:25 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 08 Jan 2010 15:59:25 -0500 Subject: [armedbear-cvs] r12350 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 8 15:59:24 2010 New Revision: 12350 Log: Added constructor. Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Modified: trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java (original) +++ trunk/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Fri Jan 8 15:59:24 2010 @@ -37,15 +37,30 @@ public final class WrongNumberOfArgumentsException extends ProgramError { - private final Operator operator; + private Operator operator; + private int expectedArgs; + private String message; - public WrongNumberOfArgumentsException(Operator operator) + public WrongNumberOfArgumentsException(Operator operator) { + this(operator, -1); + } - { + public WrongNumberOfArgumentsException(Operator operator, int expectedArgs) { // 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; + this.expectedArgs = expectedArgs; + setFormatControl(getMessage()); + setFormatArguments(NIL); + } + + public WrongNumberOfArgumentsException(String message) { + super(StandardClass.PROGRAM_ERROR); + if(message == null) { + throw new NullPointerException("message can not be null"); + } + this.message = message; setFormatControl(getMessage()); setFormatArguments(NIL); } @@ -53,6 +68,9 @@ @Override public String getMessage() { + if(message != null) { + return message; + } FastStringBuffer sb = new FastStringBuffer("Wrong number of arguments"); LispObject lambdaName = operator.getLambdaName(); @@ -60,7 +78,12 @@ sb.append(" for "); sb.append(operator.getLambdaName().writeToString()); } + if(expectedArgs >= 0) { + sb.append("; "); + sb.append(expectedArgs); + sb.append(" expected"); + } sb.append('.'); - return sb.toString(); + return message = sb.toString(); } } From astalla at common-lisp.net Fri Jan 8 21:29:44 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 08 Jan 2010 16:29:44 -0500 Subject: [armedbear-cvs] r12351 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 8 16:29:41 2010 New Revision: 12351 Log: Fixed regression with JavaObject.javaInstance(Class) and primitive types. 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 Fri Jan 8 16:29:41 2010 @@ -841,6 +841,14 @@ return false; } + public static Class maybeBoxClass(Class clazz) { + if(clazz.isPrimitive()) { + return getBoxedClass(clazz); + } else { + return clazz; + } + } + private static Class getBoxedClass(Class clazz) { if (clazz.equals(int.class)) { return Integer.class; 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 Fri Jan 8 16:29:41 2010 @@ -47,12 +47,14 @@ public JavaObject(Object obj) { this.obj = obj; - this.intendedClass = obj != null ? obj.getClass() : null; + this.intendedClass = + obj != null ? Java.maybeBoxClass(obj.getClass()) : null; } /** * Constructs a Java Object with the given intended class, used to access - * the object reflectively. + * the object reflectively. If the class represents a primitive type, + * the corresponding wrapper type is used instead. * @throws ClassCastException if the object is not an instance of the * intended class. */ @@ -60,8 +62,11 @@ if(obj != null && intendedClass == null) { intendedClass = obj.getClass(); } - if(intendedClass != null && !intendedClass.isInstance(obj)) { - throw new ClassCastException(obj + " can not be cast to " + intendedClass); + if(intendedClass != null) { + intendedClass = Java.maybeBoxClass(intendedClass); + if(!intendedClass.isInstance(obj)) { + throw new ClassCastException(obj + " can not be cast to " + intendedClass); + } } this.obj = obj; this.intendedClass = intendedClass; @@ -232,10 +237,13 @@ public Object javaInstance(Class c) { if(obj == null) { return obj; - } else if(c.isAssignableFrom(intendedClass)) { - return obj; } else { - return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); + c = Java.maybeBoxClass(c); + if(c.isAssignableFrom(intendedClass)) { + return obj; + } else { + return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); + } } } From astalla at common-lisp.net Fri Jan 8 21:32:02 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 08 Jan 2010 16:32:02 -0500 Subject: [armedbear-cvs] r12352 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 8 16:32:02 2010 New Revision: 12352 Log: Have JavaObject.javaInstance(c) complain if the wrapped object is null and c is a primitive type. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java 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 Fri Jan 8 16:32:02 2010 @@ -236,6 +236,9 @@ @Override public Object javaInstance(Class c) { if(obj == null) { + if(c.isPrimitive()) { + throw new NullPointerException("Cannot assign null to " + c); + } return obj; } else { c = Java.maybeBoxClass(c); From astalla at common-lisp.net Fri Jan 8 22:17:00 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 08 Jan 2010 17:17:00 -0500 Subject: [armedbear-cvs] r12353 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 8 17:16:57 2010 New Revision: 12353 Log: Removed unchecked warning. Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java 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 Fri Jan 8 17:16:57 2010 @@ -234,7 +234,7 @@ } @Override - public Object javaInstance(Class c) { + public Object javaInstance(Class c) { if(obj == null) { if(c.isPrimitive()) { throw new NullPointerException("Cannot assign null to " + c); From mevenson at common-lisp.net Sat Jan 9 20:26:55 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 09 Jan 2010 15:26:55 -0500 Subject: [armedbear-cvs] r12354 - in trunk/abcl: . nbproject Message-ID: Author: mevenson Date: Sat Jan 9 15:26:51 2010 New Revision: 12354 Log: Align Netbeans build with pure Ant-based build. Netbeans no longer copies the lisp-based source to the build directory, meaning the final FASLs refer to the original source location like in the Ant-based build. Modified: trunk/abcl/nbproject/project.properties trunk/abcl/netbeans-build.xml Modified: trunk/abcl/nbproject/project.properties ============================================================================== --- trunk/abcl/nbproject/project.properties (original) +++ trunk/abcl/nbproject/project.properties Sat Jan 9 15:26:51 2010 @@ -1,10 +1,11 @@ application.title=abcl application.vendor= build.classes.dir=${build.dir}/classes -build.classes.excludes=**/*.java,**/*.form +build.classes.excludes=**/*.java,**/*.form,**/*.lisp # This directory is removed when the project is cleaned: build.dir=build build.generated.dir=${build.dir}/generated +build.generated.sources.dir=${build.dir}/generated-sources # Only compile against the classpath explicitly listed here: build.sysclasspath=ignore build.test.classes.dir=${build.dir}/test/classes @@ -43,6 +44,7 @@ javadoc.use=true javadoc.version=false javadoc.windowtitle= +jaxbwiz.endorsed.dirs="${netbeans.home}/../ide12/modules/ext/jaxb/api" jnlp.codebase.type=local jnlp.codebase.url=file:/Users/evenson/work/abcl/dist/ jnlp.enabled=false Modified: trunk/abcl/netbeans-build.xml ============================================================================== --- trunk/abcl/netbeans-build.xml (original) +++ trunk/abcl/netbeans-build.xml Sat Jan 9 15:26:51 2010 @@ -7,20 +7,7 @@ - build.classes.dir: ${build.classes.dir} - - - - - - - - - - - + From mevenson at common-lisp.net Sat Jan 9 20:28:15 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 09 Jan 2010 15:28:15 -0500 Subject: [armedbear-cvs] r12355 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat Jan 9 15:28:15 2010 New Revision: 12355 Log: Add missing documentation annotations ("// ###") for Primitives. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sat Jan 9 15:28:15 2010 @@ -34,11 +34,8 @@ package org.armedbear.lisp; import static org.armedbear.lisp.Lisp.*; - import java.util.Hashtable; - - public class AutoloadedFunctionProxy extends Function { public enum FunctionType @@ -240,6 +237,7 @@ return new JavaObject(new Hashtable()); } + // ### proxy-preloaded-function final private static Primitive PROXY_PRELOADED_FUNCTION = new Primitive("proxy-preloaded-function", PACKAGE_SYS, false, "symbol name") @@ -284,7 +282,7 @@ } }; - + // ### function-preload final private static Primitive FUNCTION_PRELOAD = new Primitive("function-preload", PACKAGE_SYS, false, "name") { From ehuelsmann at common-lisp.net Sun Jan 10 14:57:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 Jan 2010 09:57:43 -0500 Subject: [armedbear-cvs] r12356 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 10 09:57:39 2010 New Revision: 12356 Log: Make LispClass.addClass return the added class, for convenience. Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java Modified: trunk/abcl/src/org/armedbear/lisp/LispClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispClass.java Sun Jan 10 09:57:39 2010 @@ -39,12 +39,13 @@ { private static final EqHashTable map = new EqHashTable(256, NIL, NIL); - public static void addClass(Symbol symbol, LispClass c) + public static LispClass addClass(Symbol symbol, LispClass c) { synchronized (map) { map.put(symbol, c); } + return c; } public static void removeClass(Symbol symbol) From ehuelsmann at common-lisp.net Sun Jan 10 14:58:52 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 Jan 2010 09:58:52 -0500 Subject: [armedbear-cvs] r12357 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 10 09:58:51 2010 New Revision: 12357 Log: Change STREAM and its decendants to a structure class, from built-in, in an attempt to prepare support for Gray streams. Note: Many more commits coming this way. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sun Jan 10 09:58:51 2010 @@ -92,16 +92,11 @@ 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); @@ -131,18 +126,9 @@ 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 BuiltInClass STACK_FRAME = addClass(Symbol.STACK_FRAME); public static final BuiltInClass LISP_STACK_FRAME = addClass(Symbol.LISP_STACK_FRAME); @@ -150,11 +136,60 @@ public static final StructureClass STRUCTURE_OBJECT = - new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T)); - static - { - addClass(Symbol.STRUCTURE_OBJECT, STRUCTURE_OBJECT); - } + (StructureClass)addClass(Symbol.STRUCTURE_OBJECT, + new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T))); + + public static final LispClass STREAM = + addClass(Symbol.STREAM, + new StructureClass(Symbol.STREAM, list(STRUCTURE_OBJECT))); + public static final LispClass SYSTEM_STREAM = + addClass(Symbol.SYSTEM_STREAM, + new StructureClass(Symbol.SYSTEM_STREAM, list(STREAM))); + public static final LispClass TWO_WAY_STREAM = + addClass(Symbol.TWO_WAY_STREAM, + new StructureClass(Symbol.TWO_WAY_STREAM, list(SYSTEM_STREAM))); + public static final LispClass BROADCAST_STREAM = + addClass(Symbol.BROADCAST_STREAM, + new StructureClass(Symbol.BROADCAST_STREAM, list(SYSTEM_STREAM))); + public static final LispClass ECHO_STREAM = + addClass(Symbol.ECHO_STREAM, + new StructureClass(Symbol.ECHO_STREAM, list(SYSTEM_STREAM))); + public static final LispClass CASE_FROB_STREAM = + addClass(Symbol.CASE_FROB_STREAM, + new StructureClass(Symbol.CASE_FROB_STREAM, list(SYSTEM_STREAM))); + public static final LispClass STRING_STREAM = + addClass(Symbol.STRING_STREAM, + new StructureClass(Symbol.STRING_STREAM, list(SYSTEM_STREAM))); + public static final LispClass STRING_INPUT_STREAM = + addClass(Symbol.STRING_INPUT_STREAM, + new StructureClass(Symbol.STRING_INPUT_STREAM, list(STRING_STREAM))); + public static final LispClass STRING_OUTPUT_STREAM = + addClass(Symbol.STRING_OUTPUT_STREAM, + new StructureClass(Symbol.STRING_OUTPUT_STREAM, list(STRING_STREAM))); + public static final LispClass SYNONYM_STREAM = + addClass(Symbol.SYNONYM_STREAM, + new StructureClass(Symbol.SYNONYM_STREAM, list(SYSTEM_STREAM))); + public static final LispClass FILE_STREAM = + addClass(Symbol.FILE_STREAM, + new StructureClass(Symbol.FILE_STREAM, list(SYSTEM_STREAM))); + public static final LispClass CONCATENATED_STREAM = + addClass(Symbol.CONCATENATED_STREAM, + new StructureClass(Symbol.CONCATENATED_STREAM, list(SYSTEM_STREAM))); + + + + // Implementation defined streams + public static final LispClass SOCKET_STREAM = + addClass(Symbol.SOCKET_STREAM, + new StructureClass(Symbol.SOCKET_STREAM, list(TWO_WAY_STREAM))); + public static final LispClass SLIME_INPUT_STREAM = + addClass(Symbol.SLIME_INPUT_STREAM, + new StructureClass(Symbol.SLIME_INPUT_STREAM, list(STRING_STREAM))); + public static final LispClass SLIME_OUTPUT_STREAM = + addClass(Symbol.SLIME_OUTPUT_STREAM, + new StructureClass(Symbol.SLIME_OUTPUT_STREAM, list(STRING_STREAM))); + + static { @@ -166,7 +201,6 @@ 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); @@ -175,19 +209,16 @@ 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); @@ -250,34 +281,25 @@ 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(list(ARRAY, SEQUENCE)); VECTOR.setCPL(VECTOR, ARRAY, SEQUENCE, CLASS_T); 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 Sun Jan 10 09:58:51 2010 @@ -3040,6 +3040,8 @@ PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM"); public static final Symbol STRING_OUTPUT_STREAM = PACKAGE_SYS.addInternalSymbol("STRING-OUTPUT-STREAM"); + public static final Symbol SYSTEM_STREAM = + PACKAGE_SYS.addInternalSymbol("SYSTEM-STREAM"); public static final Symbol STACK_FRAME = PACKAGE_SYS.addInternalSymbol("STACK-FRAME"); public static final Symbol LISP_STACK_FRAME = From ehuelsmann at common-lisp.net Sun Jan 10 20:43:48 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 10 Jan 2010 15:43:48 -0500 Subject: [armedbear-cvs] r12358 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 10 15:43:45 2010 New Revision: 12358 Log: Fix the stream Class Precedence Lists (CPLs) to include STRUCTURE_OBJECT and SYSTEM_STREAM. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sun Jan 10 15:43:45 2010 @@ -201,25 +201,29 @@ 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.setCPL(BROADCAST_STREAM, STREAM, CLASS_T); - CASE_FROB_STREAM.setDirectSuperclass(STREAM); - CASE_FROB_STREAM.setCPL(CASE_FROB_STREAM, STREAM, CLASS_T); + BROADCAST_STREAM.setCPL(BROADCAST_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, CLASS_T); + CASE_FROB_STREAM.setCPL(CASE_FROB_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, 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.setCPL(CONCATENATED_STREAM, STREAM, CLASS_T); + CONCATENATED_STREAM.setCPL(CONCATENATED_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, 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.setCPL(ECHO_STREAM, STREAM, CLASS_T); + ECHO_STREAM.setCPL(ECHO_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, 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.setCPL(FILE_STREAM, STREAM, CLASS_T); + FILE_STREAM.setCPL(FILE_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, CLASS_T); FLOAT.setDirectSuperclass(REAL); FLOAT.setCPL(FLOAT, REAL, NUMBER, CLASS_T); FUNCTION.setDirectSuperclass(CLASS_T); @@ -281,26 +285,30 @@ CLASS_T); SINGLE_FLOAT.setDirectSuperclass(FLOAT); SINGLE_FLOAT.setCPL(SINGLE_FLOAT, FLOAT, REAL, NUMBER, CLASS_T); - SLIME_INPUT_STREAM.setCPL(SLIME_INPUT_STREAM, STRING_STREAM, STREAM, - CLASS_T); - SLIME_OUTPUT_STREAM.setCPL(SLIME_OUTPUT_STREAM, STRING_STREAM, STREAM, - CLASS_T); - SOCKET_STREAM.setCPL(SOCKET_STREAM, TWO_WAY_STREAM, STREAM, CLASS_T); - STREAM.setCPL(STREAM, CLASS_T); + SLIME_INPUT_STREAM.setCPL(SLIME_INPUT_STREAM, STRING_STREAM, SYSTEM_STREAM, + STREAM, STRUCTURE_OBJECT, CLASS_T); + SLIME_OUTPUT_STREAM.setCPL(SLIME_OUTPUT_STREAM, STRING_STREAM, SYSTEM_STREAM, + STREAM, STRUCTURE_OBJECT, CLASS_T); + SOCKET_STREAM.setCPL(SOCKET_STREAM, TWO_WAY_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, CLASS_T); + STREAM.setCPL(STREAM, STRUCTURE_OBJECT, CLASS_T); STRING.setDirectSuperclass(VECTOR); STRING.setCPL(STRING, VECTOR, ARRAY, SEQUENCE, CLASS_T); - STRING_INPUT_STREAM.setCPL(STRING_INPUT_STREAM, STRING_STREAM, STREAM, - CLASS_T); - STRING_OUTPUT_STREAM.setCPL(STRING_OUTPUT_STREAM, STRING_STREAM, STREAM, - CLASS_T); - STRING_STREAM.setCPL(STRING_STREAM, STREAM, CLASS_T); + STRING_INPUT_STREAM.setCPL(STRING_INPUT_STREAM, STRING_STREAM, + SYSTEM_STREAM, STREAM, STRUCTURE_OBJECT, CLASS_T); + STRING_OUTPUT_STREAM.setCPL(STRING_OUTPUT_STREAM, STRING_STREAM, + SYSTEM_STREAM, STREAM, STRUCTURE_OBJECT, CLASS_T); + STRING_STREAM.setCPL(STRING_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, CLASS_T); STRUCTURE_OBJECT.setCPL(STRUCTURE_OBJECT, CLASS_T); SYMBOL.setDirectSuperclass(CLASS_T); SYMBOL.setCPL(SYMBOL, CLASS_T); - SYNONYM_STREAM.setCPL(SYNONYM_STREAM, STREAM, CLASS_T); + SYNONYM_STREAM.setCPL(SYNONYM_STREAM, SYSTEM_STREAM, + STREAM, STRUCTURE_OBJECT, CLASS_T); THREAD.setDirectSuperclass(CLASS_T); THREAD.setCPL(THREAD, CLASS_T); - TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, STREAM, CLASS_T); + TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, SYSTEM_STREAM, STREAM, + STRUCTURE_OBJECT, CLASS_T); VECTOR.setDirectSuperclasses(list(ARRAY, SEQUENCE)); VECTOR.setCPL(VECTOR, ARRAY, SEQUENCE, CLASS_T); STACK_FRAME.setDirectSuperclasses(CLASS_T); From mevenson at common-lisp.net Mon Jan 11 07:18:44 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 11 Jan 2010 02:18:44 -0500 Subject: [armedbear-cvs] r12359 - trunk/abcl Message-ID: Author: mevenson Date: Mon Jan 11 02:18:41 2010 New Revision: 12359 Log: Note Netbeans and FASL location improvements. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Mon Jan 11 02:18:41 2010 @@ -23,6 +23,7 @@ * Line numbers in generated java classes incorrect * JCALL, JNEW doesn't select best match when multiple applicable methods * STREAM-EXTERNAL-FORMAT always returns :DEFAULT, instead of actual format + * REPL no longer hangs in Netbeans 6.[578] output window * Lambda-list variables replaced by surrounding SYMBOL-MACROLET @@ -30,7 +31,7 @@ * LispObject does not inherit from Lisp anymore * Many functions declared 'final' for performance improvement - + * SYSTEM:*SOURCE* FASLs for system files no longer refer to intermediate build location Version 0.17.0 From ehuelsmann at common-lisp.net Mon Jan 11 19:23:48 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 Jan 2010 14:23:48 -0500 Subject: [armedbear-cvs] r12360 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 11 14:23:45 2010 New Revision: 12360 Log: Set initial ByteArrayOutputStream buffer to 2048; the default 32 way to small. 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 Mon Jan 11 14:23:45 2010 @@ -47,7 +47,13 @@ private ByteArrayOutputStream(LispObject elementType) { this.elementType = elementType; - initAsBinaryOutputStream(byteArrayOutputStream = new java.io.ByteArrayOutputStream()); + initAsBinaryOutputStream(byteArrayOutputStream = new java.io.ByteArrayOutputStream(2048)); + // based on statistics of ABCL's own .cls files + // as per 20100111, 2048 is the 70th percentile, + // meaning that only 30% of all .cls files is bigger + + // However, *every* .cls file is bigger than 32 bytes; + // we want to prevent buffer resizing } @Override From ehuelsmann at common-lisp.net Mon Jan 11 19:40:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 Jan 2010 14:40:41 -0500 Subject: [armedbear-cvs] r12361 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 11 14:40:37 2010 New Revision: 12361 Log: Add setting the CPL of SYSTEM_STREAM. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Mon Jan 11 14:40:37 2010 @@ -305,6 +305,7 @@ SYMBOL.setCPL(SYMBOL, CLASS_T); SYNONYM_STREAM.setCPL(SYNONYM_STREAM, SYSTEM_STREAM, STREAM, STRUCTURE_OBJECT, CLASS_T); + SYSTEM_STREAM.setCPL(SYSTEM_STREAM, STREAM, STRUCTURE_OBJECT, CLASS_T); THREAD.setDirectSuperclass(CLASS_T); THREAD.setCPL(THREAD, CLASS_T); TWO_WAY_STREAM.setCPL(TWO_WAY_STREAM, SYSTEM_STREAM, STREAM, From vvoutilainen at common-lisp.net Mon Jan 11 20:03:30 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 11 Jan 2010 15:03:30 -0500 Subject: [armedbear-cvs] r12362 - in trunk/abcl/src/org/armedbear/lisp: . java scripting Message-ID: Author: vvoutilainen Date: Mon Jan 11 15:03:29 2010 New Revision: 12362 Log: Make Stream extend StructureObject, modify Stream derivatives to set a StructureClass symbol when invoking the superclass constructor. Fix clinit order in Lisp.java to cope. Some structure-classes need refining, at least TwoWayStream needs to allow (but not force) its derivatives to set a structure class other than TWO-WAY-STREAM (SOCKET-STREAM being one specific example). Thanks to Alessio Stalla and Erik Huelsmann for helping with getting this patch into a state where ansi tests run again. Modified: trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java trunk/abcl/src/org/armedbear/lisp/ByteArrayOutputStream.java trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java trunk/abcl/src/org/armedbear/lisp/ConcatenatedStream.java trunk/abcl/src/org/armedbear/lisp/EchoStream.java trunk/abcl/src/org/armedbear/lisp/FileStream.java trunk/abcl/src/org/armedbear/lisp/FillPointerOutputStream.java trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java trunk/abcl/src/org/armedbear/lisp/Stream.java trunk/abcl/src/org/armedbear/lisp/StringInputStream.java trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java trunk/abcl/src/org/armedbear/lisp/StructureObject.java trunk/abcl/src/org/armedbear/lisp/SynonymStream.java trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java trunk/abcl/src/org/armedbear/lisp/socket_stream.java Modified: trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BroadcastStream.java Mon Jan 11 15:03:29 2010 @@ -41,6 +41,7 @@ private BroadcastStream(Stream[] streams) { + super(Symbol.BROADCAST_STREAM); this.streams = streams; isOutputStream = true; if (streams.length == 0) { 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 Mon Jan 11 15:03:29 2010 @@ -46,6 +46,7 @@ private ByteArrayOutputStream(LispObject elementType) { + super(Symbol.SYSTEM_STREAM); this.elementType = elementType; initAsBinaryOutputStream(byteArrayOutputStream = new java.io.ByteArrayOutputStream(2048)); // based on statistics of ABCL's own .cls files Modified: trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CaseFrobStream.java Mon Jan 11 15:03:29 2010 @@ -42,6 +42,7 @@ protected CaseFrobStream(Stream target) { + super(Symbol.CASE_FROB_STREAM); Debug.assertTrue(target.isCharacterOutputStream()); this.target = target; } Modified: trunk/abcl/src/org/armedbear/lisp/ConcatenatedStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ConcatenatedStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ConcatenatedStream.java Mon Jan 11 15:03:29 2010 @@ -41,6 +41,7 @@ private ConcatenatedStream(LispObject streams) { + super(Symbol.CONCATENATED_STREAM); this.streams = streams; isInputStream = true; } Modified: trunk/abcl/src/org/armedbear/lisp/EchoStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/EchoStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/EchoStream.java Mon Jan 11 15:03:29 2010 @@ -44,12 +44,14 @@ public EchoStream(Stream in, Stream out) { + super(Symbol.ECHO_STREAM); this.in = in; this.out = out; } public EchoStream(Stream in, Stream out, boolean interactive) { + super(Symbol.ECHO_STREAM); this.in = in; this.out = out; setInteractive(interactive); Modified: trunk/abcl/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FileStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FileStream.java Mon Jan 11 15:03:29 2010 @@ -70,6 +70,7 @@ * These definitions have been taken from FLEXI-STREAMS: * http://www.weitz.de/flexi-streams/#make-external-format */ + super(Symbol.FILE_STREAM); final File file = new File(namestring); String mode = null; if (direction == Keyword.INPUT) { Modified: trunk/abcl/src/org/armedbear/lisp/FillPointerOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FillPointerOutputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FillPointerOutputStream.java Mon Jan 11 15:03:29 2010 @@ -41,6 +41,7 @@ private FillPointerOutputStream(ComplexString string) { + super(Symbol.SYSTEM_STREAM); elementType = Symbol.CHARACTER; isOutputStream = true; isInputStream = false; 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 Mon Jan 11 15:03:29 2010 @@ -138,8 +138,8 @@ jlisp = true; this.inputStream = inputStream; this.outputStream = outputStream; - resetIO(new Stream(inputStream, Symbol.CHARACTER), - new Stream(outputStream, Symbol.CHARACTER)); + resetIO(new Stream(Symbol.SYSTEM_STREAM, inputStream, Symbol.CHARACTER), + new Stream(Symbol.SYSTEM_STREAM, outputStream, Symbol.CHARACTER)); if (!initialDirectory.endsWith(File.separator)) initialDirectory = initialDirectory.concat(File.separator); Symbol.DEFAULT_PATHNAME_DEFAULTS.setSymbolValue(new Pathname(initialDirectory)); 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 Mon Jan 11 15:03:29 2010 @@ -2183,20 +2183,7 @@ 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) { @@ -2214,8 +2201,8 @@ // 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)); + resetIO(new Stream(Symbol.SYSTEM_STREAM, System.in, Symbol.CHARACTER, true), + new Stream(Symbol.SYSTEM_STREAM, System.out, Symbol.CHARACTER, true)); } public static final TwoWayStream getTerminalIO() @@ -2767,4 +2754,20 @@ loadClass("org.armedbear.lisp.PackageFunctions"); cold = false; } + + private static Stream stdin = new Stream(Symbol.SYSTEM_STREAM, System.in, Symbol.CHARACTER, true); + + private static Stream stdout = new Stream(Symbol.SYSTEM_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)); + } + } 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 Mon Jan 11 15:03:29 2010 @@ -262,7 +262,7 @@ try { return loadFileFromStream(null, truename, - new Stream(in, Symbol.CHARACTER), + new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER), verbose, print, false, returnLastResult); } catch (FaslVersionMismatch e) { @@ -413,7 +413,7 @@ thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); try { return loadFileFromStream(pathname, truename, - new Stream(in, Symbol.CHARACTER), + new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER), verbose, print, auto); } catch (FaslVersionMismatch e) { Modified: trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlimeInputStream.java Mon Jan 11 15:03:29 2010 @@ -44,6 +44,7 @@ public SlimeInputStream(Function f, Stream ostream) { + super(Symbol.SLIME_INPUT_STREAM); elementType = Symbol.CHARACTER; isInputStream = true; isOutputStream = false; Modified: trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SlimeOutputStream.java Mon Jan 11 15:03:29 2010 @@ -44,6 +44,7 @@ private SlimeOutputStream(Function f) { + super(Symbol.SLIME_OUTPUT_STREAM); this.elementType = Symbol.CHARACTER; isInputStream = false; isOutputStream = true; 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 Mon Jan 11 15:03:29 2010 @@ -55,2880 +55,2505 @@ import org.armedbear.lisp.util.DecodingReader; /** 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 PushbackReader reader; - protected int offset; - protected int lineNumber; - - // Character output. - private 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 = internKeyword("DEFAULT"); - - static final private Symbol keywordCodePage = internKeyword("CODE-PAGE"); - static final private Symbol keywordID = internKeyword("ID"); - - static final private Symbol keywordEolStyle = internKeyword("EOL-STYLE"); - static final private Symbol keywordCR = internKeyword("CR"); - static final private Symbol keywordLF = internKeyword("LF"); - static final private Symbol keywordCRLF = internKeyword("CRLF"); - static final private Symbol keywordRAW = 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 = NIL; - protected String encoding = null; - protected char lastChar = 0; - - // Binary input. - private InputStream in; +public class Stream extends StructureObject { + 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 PushbackReader reader; + protected int offset; + protected int lineNumber; + + // Character output. + private 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 = internKeyword("DEFAULT"); + + static final private Symbol keywordCodePage = internKeyword("CODE-PAGE"); + static final private Symbol keywordID = internKeyword("ID"); + + static final private Symbol keywordEolStyle = internKeyword("EOL-STYLE"); + static final private Symbol keywordCR = internKeyword("CR"); + static final private Symbol keywordLF = internKeyword("LF"); + static final private Symbol keywordCRLF = internKeyword("CRLF"); + static final private Symbol keywordRAW = 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 = NIL; + protected String encoding = null; + protected char lastChar = 0; - // Binary output. - private OutputStream out; + // Binary input. + private InputStream in; - protected Stream() - { - } + // Binary output. + private OutputStream out; - public Stream(InputStream stream) { - initAsBinaryInputStream(stream); + protected Stream(Symbol structureClass) { + super(structureClass); } - public Stream(Reader r) { - initAsCharacterInputStream(r); + public Stream(Symbol structureClass, InputStream stream) { + super(structureClass); + initAsBinaryInputStream(stream); } - public Stream(OutputStream stream) { - initAsBinaryOutputStream(stream); + public Stream(Symbol structureClass, Reader r) { + super(structureClass); + initAsCharacterInputStream(r); } - public Stream(Writer w) { - initAsCharacterOutputStream(w); + public Stream(Symbol structureClass, OutputStream stream) { + super(structureClass); + initAsBinaryOutputStream(stream); } - public Stream(InputStream inputStream, LispObject elementType) - { - this(inputStream, elementType, keywordDefault); + public Stream(Symbol structureClass, Writer w) { + super(structureClass); + initAsCharacterOutputStream(w); } + public Stream(Symbol structureClass, InputStream inputStream, LispObject elementType) { + this(structureClass, 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) - { - Reader reader = - new DecodingReader(inputStream, 4096, - (encoding == null) - ? Charset.defaultCharset() - : Charset.forName(encoding)); - initAsCharacterInputStream(reader); - } - else - { - isBinaryStream = true; - InputStream stream = new BufferedInputStream(inputStream); - initAsBinaryInputStream(stream); - } - } - public Stream(InputStream inputStream, LispObject elementType, boolean interactive) - { - this(inputStream, elementType); - setInteractive(interactive); - } + // Input stream constructors. + public Stream(Symbol structureClass, InputStream inputStream, + LispObject elementType, LispObject format) { + super(structureClass); + this.elementType = elementType; + setExternalFormat(format); + + if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { + Reader reader = + new DecodingReader(inputStream, 4096, + (encoding == null) + ? Charset.defaultCharset() + : Charset.forName(encoding)); + initAsCharacterInputStream(reader); + } else { + isBinaryStream = true; + InputStream stream = new BufferedInputStream(inputStream); + initAsBinaryInputStream(stream); + } + } - public Stream(OutputStream outputStream, LispObject elementType) - { - this(outputStream, elementType, keywordDefault); + public Stream(Symbol structureClass, InputStream inputStream, LispObject elementType, boolean interactive) { + this(structureClass, inputStream, elementType); + setInteractive(interactive); } - - // 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() - { - return isInputStream; - } - - public boolean isOutputStream() - { - return isOutputStream; - } - - public boolean isCharacterInputStream() - { - return isCharacterStream && isInputStream; - } - - public boolean isBinaryInputStream() - { - return isBinaryStream && isInputStream; - } - - public boolean isCharacterOutputStream() - { - return isCharacterStream && isOutputStream; - } - - public boolean isBinaryOutputStream() - { - 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) { - // make sure we encode any remaining buffers with the current format - finishOutput(); - - if (format == keywordDefault) { - encoding = null; - eolStyle = platformEolStyle; - eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; - externalFormat = format; - return; - } - - LispObject enc; - boolean encIsCp = false; - - if (format instanceof Cons) { - // meaning a non-empty list - enc = format.car(); - if (enc == keywordCodePage) { - encIsCp = true; - - enc = getf(format.cdr(), keywordID, null); - } - - LispObject eol = 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; - - eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; - externalFormat = format; + public Stream(Symbol structureClass, OutputStream outputStream, LispObject elementType) { + this(structureClass, outputStream, elementType, keywordDefault); + } - if (reader != null - && reader instanceof DecodingReader) - ((DecodingReader)reader).setCharset(Charset.forName(encoding)); - } - - 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) - { - if (typeSpecifier == Symbol.STREAM) - return T; - if (typeSpecifier == BuiltInClass.STREAM) - return T; - return super.typep(typeSpecifier); - } - - public LispObject getElementType() - { - 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) - - { - LispObject result = readPreservingWhitespace(eofError, eofValue, - recursive, thread); - if (result != eofValue && !recursive) - { - try { - if (_charReady()) - { - int n = _readChar(); - if (n >= 0) - { - char c = (char) n; // ### BUG: Codepoint conversion - Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); - if (!rt.isWhitespace(c)) - _unreadChar(c); - } - } + // Output stream constructors. + public Stream(Symbol structureClass, OutputStream outputStream, LispObject elementType, LispObject format) { + super(structureClass); + 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); } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - 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) - - { - if (recursive) - { - final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); - while (true) - { - int n = -1; - try - { - n = _readChar(); - } - catch (IOException e) - { - error(new StreamError(this, e)); - } - if (n < 0) - { - if (eofError) - return error(new EndOfFile(this)); - else - return eofValue; - } - char c = (char) n; // ### BUG: Codepoint conversion - if (rt.isWhitespace(c)) - continue; - LispObject result = processChar(c, rt); - if (result != null) - return result; - } - } - else - { - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); - try - { - return readPreservingWhitespace(eofError, eofValue, true, thread); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - } - - public LispObject faslRead(boolean eofError, LispObject eofValue, - boolean recursive, LispThread thread) - - { - try - { - LispObject result = faslReadPreservingWhitespace(eofError, eofValue, - recursive, thread); - if (result != eofValue && !recursive) - { - if (_charReady()) - { - int n = _readChar(); - if (n >= 0) - { - char c = (char) n; // ### BUG: Codepoint conversion - Readtable rt = FaslReadtable.getInstance(); - if (!rt.isWhitespace(c)) - _unreadChar(c); - } - } - } - if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) - return NIL; + } + + public Stream(Symbol structureClass, OutputStream outputStream, + LispObject elementType, + boolean interactive) { + this(structureClass, outputStream, elementType); + setInteractive(interactive); + } + + protected void initAsCharacterInputStream(Reader reader) { + if (! (reader instanceof PushbackReader)) + this.reader = new PushbackReader(reader, 5); else - return result; - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - private final LispObject faslReadPreservingWhitespace(boolean eofError, - LispObject eofValue, - boolean recursive, - LispThread thread) - throws IOException - { - 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; // ### BUG: Codepoint conversion - if (rt.isWhitespace(c)) - continue; - LispObject result = processChar(c, rt); - if (result != null) - return result; - } - } - else - { - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); - try - { - return faslReadPreservingWhitespace(eofError, eofValue, true, thread); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - } - - private final LispObject processChar(char c, Readtable rt) - - { - final LispObject handler = rt.getReaderMacroFunction(c); - if (handler instanceof ReaderMacroFunction) - return ((ReaderMacroFunction)handler).execute(this, c); - if (handler != null && handler != NIL) - return handler.execute(this, LispCharacter.getInstance(c)); - return readToken(c, rt); - } - - public LispObject readPathname() - { - 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() - { - 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() - { - 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) - { - FastStringBuffer sb = new FastStringBuffer(); - _readToken(sb, rt); - return new Symbol(sb.toString()); - } - - public LispObject readStructure() - { - 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() - { - 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) - - { - final LispThread thread = LispThread.currentThread(); - Cons first = null; - Cons last = null; - Readtable rt = null; - if (useFaslReadtable) - rt = FaslReadtable.getInstance(); - try - { - 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; // ### BUG: Codepoint conversion - 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; - } - } - } - catch (IOException e) - { - error(new StreamError(this, e)); - return null; - } - } + this.reader = (PushbackReader)reader; - private static final boolean isTokenDelimiter(char c, Readtable rt) + isInputStream = true; + isCharacterStream = true; + } - { - switch (c) - { - case '"': - case '\'': - case '(': - case ')': - case ',': - case ';': - case '`': - return true; - default: - return rt.isWhitespace(c); - } - } - - public LispObject readDispatchChar(char dispChar, boolean useFaslReadtable) - - { - int numArg = -1; - char c = 0; - try - { - while (true) - { - int n = _readChar(); - if (n < 0) - return error(new EndOfFile(this)); - c = (char) n; // ### BUG: Codepoint conversion - if (c < '0' || c > '9') - break; - if (numArg < 0) - numArg = 0; - numArg = numArg * 10 + c - '0'; - } - } - catch (IOException e) - { - error(new StreamError(this, e)); - } - 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 : Fixnum.getInstance(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) - - { - try - { - int n = _readChar(); - if (n < 0) - return error(new EndOfFile(this)); - char c = (char) n; // ### BUG: Codepoint conversion - FastStringBuffer sb = new FastStringBuffer(c); - while (true) - { - n = _readChar(); - if (n < 0) - break; - c = (char) n; // ### BUG: Codepoint conversion - 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); // ### BUG: Codepoint conversion - return error(new LispError("Unrecognized character name: \"" + token + '"')); - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - public void skipBalancedComment() - { - try - { - 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); - } - } - } - catch (IOException e) - { - error(new StreamError(this, e)); - } - } - - public LispObject readArray(int rank) - { - 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) - { - 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() - { - 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() - { - 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) - { - FastStringBuffer sb = new FastStringBuffer(); - try - { - while (true) - { - int n = _readChar(); - if (n < 0) - { - error(new EndOfFile(this)); - // Not reached. - return null; - } - char c = (char) n; // ### BUG: Codepoint conversion - byte syntaxType = rt.getSyntaxType(c); - if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) - { - n = _readChar(); - if (n < 0) - { - error(new EndOfFile(this)); - // Not reached. - return null; - } - sb.append((char)n); // ### BUG: Codepoint conversion - continue; - } - if (syntaxType == Readtable.SYNTAX_TYPE_MULTIPLE_ESCAPE) - break; - sb.append(c); - } - } - catch (IOException e) - { - error(new StreamError(this, e)); - } - 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) - - { - 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) - - { - 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 = -1; - try - { - n = _readChar(); - } - catch (IOException e) - { - error(new StreamError(this, e)); - return flags; - } - if (n < 0) - { - error(new EndOfFile(this)); - // Not reached. - return flags; - } - sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion - 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)); - } - } - try { - while (true) - { - int n = _readChar(); - if (n < 0) - break; - char c = (char) n; // ### BUG: Codepoint conversion - 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); // ### BUG: Codepoint conversion - 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); - } - } - catch (IOException e) - { - error(new StreamError(this, e)); - return flags; - } + protected void initAsBinaryInputStream(InputStream in) { + this.in = in; + isInputStream = true; + isBinaryStream = true; + } - return flags; - } + protected void initAsCharacterOutputStream(Writer writer) { + this.writer = writer; + isOutputStream = true; + isCharacterStream = true; + } - 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) - - { - final int readBase; - final LispObject readBaseObject = Symbol.READ_BASE.symbolValue(thread); - if (readBaseObject instanceof Fixnum) { - readBase = ((Fixnum)readBaseObject).value; - } else { - // The value of *READ-BASE* is not a Fixnum. - error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); - // Not reached. - return 10; - } - if (readBase < 2 || readBase > 36) - { - error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); - // Not reached. - return 10; - } - return readBase; - } - - private final LispObject makeNumber(String token, int length, int radix) - - { - 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] : Fixnum.getInstance(n); - } - catch (NumberFormatException e) {} - // parseInt() failed. - try - { - return Bignum.getInstance(token, radix); - } - catch (NumberFormatException e) {} - // Not a number. - return null; - } - - private final LispObject makeRatio(String token, int radix) - - { - 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; - } - } + protected void initAsBinaryOutputStream(OutputStream out) { + this.out = out; + isOutputStream = true; + isBinaryStream = true; + } - private static final LispObject makeFloat(final String token, - final int length) + public boolean isInputStream() { + return isInputStream; + } - { - 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 boolean isOutputStream() { + return isOutputStream; + } - public LispObject readRadix(int radix) - { - 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] : Fixnum.getInstance(n); - } - catch (NumberFormatException e) {} - // parseInt() failed. - try - { - return Bignum.getInstance(s, radix); - } - catch (NumberFormatException e) {} - // Not a number. - return error(new LispError()); - } - - public LispObject faslReadRadix(int radix) - { - 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] : Fixnum.getInstance(n); - } - catch (NumberFormatException e) {} - // parseInt() failed. - try - { - return Bignum.getInstance(s, radix); - } - catch (NumberFormatException e) {} - // Not a number. - return error(new LispError()); - } - - private char flushWhitespace(Readtable rt) - { - try - { - while (true) - { - int n = _readChar(); - if (n < 0) - { - error(new EndOfFile(this)); - // Not reached. - return 0; - } - char c = (char) n; // ### BUG: Codepoint conversion - if (!rt.isWhitespace(c)) - return c; - } - } - catch (IOException e) - { - error(new StreamError(this, e)); - return 0; - } - } - - public LispObject readDelimitedList(char delimiter) - - { - 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) - - { - final LispThread thread = LispThread.currentThread(); - FastStringBuffer sb = new FastStringBuffer(); - try - { - 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); // ### BUG: Codepoint conversion - } - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - // read-char &optional stream eof-error-p eof-value recursive-p => char - // recursive-p is ignored - public LispObject readChar() - { - try - { - int n = _readChar(); - if (n < 0) - return error(new EndOfFile(this)); - return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - - } - - public LispObject readChar(boolean eofError, LispObject eofValue) - - { - try - { - int n = _readChar(); - if (n < 0) - { - if (eofError) - return error(new EndOfFile(this)); - else - return eofValue; - } - return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - // 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) - - { - try - { - return _charReady() ? readChar(eofError, eofValue) : NIL; - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - - // unread-char character &optional input-stream => nil - public LispObject unreadChar(LispCharacter c) - { - try - { - _unreadChar(c.value); - return NIL; - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - public LispObject finishOutput() - { - _finishOutput(); - return NIL; - } - - // clear-input &optional input-stream => nil - public LispObject clearInput() - { - _clearInput(); - return NIL; - } - - public LispObject getFilePosition() - { - long pos = _getFilePosition(); - return pos >= 0 ? number(pos) : NIL; - } - - public LispObject setFilePosition(LispObject arg) - { - 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) - { - _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) - - { - int n = _readByte(); - if (n < 0) - { - if (eofError) - return error(new EndOfFile(this)); - else - return eofValue; - } - return Fixnum.constants[n]; - } - - public LispObject terpri() - { - _writeChar('\n'); - return NIL; - } - - public LispObject freshLine() - { - if (charPos == 0) - return NIL; - _writeChar('\n'); - return T; - } - - public void print(char c) - { - _writeChar(c); - } - - // PRIN1 produces output suitable for input to READ. - // Binds *PRINT-ESCAPE* to true. - public void prin1(LispObject obj) - { - LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - thread.bindSpecial(Symbol.PRINT_ESCAPE, T); - try - { - _writeString(obj.writeToString()); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - - public LispObject listen() - { - if (pastEnd) - return NIL; - try - { - if (! _charReady()) - return NIL; - - int n = _readChar(); - if (n < 0) - return NIL; - - _unreadChar(n); - - return T; - } - catch (IOException e) - { - return error(new StreamError(this, e)); - } - } - - public LispObject fileLength() - { - return type_error(this, Symbol.FILE_STREAM); - } - - public LispObject fileStringLength(LispObject arg) - { - 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 - */ - protected int _readChar() throws IOException - { - if (reader == null) - streamNotCharacterInputStream(); + public boolean isCharacterInputStream() { + return isCharacterStream && isInputStream; + } - int n = reader.read(); - - if (n < 0) { - pastEnd = true; - return -1; + public boolean isBinaryInputStream() { + return isBinaryStream && isInputStream; } - - ++offset; - if (n == '\r' && eolStyle == EolStyle.CRLF) { - n = _readChar(); - if (n != '\n') { - _unreadChar(n); - return '\r'; - } - else - return '\n'; + + public boolean isCharacterOutputStream() { + return isCharacterStream && isOutputStream; } - if (n == eolChar) { - ++lineNumber; - return '\n'; - } - - return n; - } - - /** Puts a character back into the (underlying) stream - * - * @param n - */ - protected void _unreadChar(int n) throws IOException - { - if (reader == null) - streamNotCharacterInputStream(); - - --offset; - if (n == '\n') { - n = eolChar; - --lineNumber; - } - - reader.unread(n); - pastEnd = false; - } - - - /** Returns a boolean indicating input readily available - * - * @return true if a character is available - */ - protected boolean _charReady() throws IOException - { - if (reader == null) - streamNotCharacterInputStream(); - return reader.ready(); - } - - /** Writes a character into the underlying stream, - * updating charPos while doing so - * - * @param c - */ - public void _writeChar(char c) - { - 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 - */ - public void _writeChars(char[] chars, int start, int end) - - { - 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; - } + public boolean isBinaryOutputStream() { + 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) { + // make sure we encode any remaining buffers with the current format + finishOutput(); + + if (format == keywordDefault) { + encoding = null; + eolStyle = platformEolStyle; + eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + externalFormat = format; + return; } - 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 - */ - public void _writeString(String s) - { - 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 - */ - public void _writeLine(String s) - { - 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 - */ - public int _readByte() - { - 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 - */ - public void _writeByte(int n) - { - 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 - * - */ - public void _finishOutput() - { - 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 - * - */ - public void _clearInput() - { - if (reader != null) - { - int c = 0; - try - { - while (_charReady() && (c >= 0)) - c = _readChar(); - } - catch (IOException e) - { - error(new StreamError(this, e)); - } - } - 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' - */ - protected long _getFilePosition() - { - 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 - */ - protected boolean _setFilePosition(LispObject arg) - { - return false; - } - - /** Closes the stream and underlying streams - * - */ - public void _close() - { - 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) - { - 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() - { - return error(new StreamError(this, writeToString() + " is not an input stream.")); - } - - protected LispObject streamNotCharacterInputStream() - { - return error(new StreamError(this, writeToString() + " is not a character input stream.")); - } - - protected LispObject streamNotOutputStream() - { - return error(new StreamError(this, writeToString() + " is not an output stream.")); - } - - protected LispObject streamNotBinaryOutputStream() - { - return error(new StreamError(this, writeToString() + " is not a binary output stream.")); - } - - protected LispObject streamNotCharacterOutputStream() - { - 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) - - { - checkStream(second)._writeChar(LispCharacter.getValue(first)); - 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) - - { - final char c = LispCharacter.getValue(first); - if (second == T) - second = Symbol.TERMINAL_IO.symbolValue(); - else if (second == NIL) - second = Symbol.STANDARD_OUTPUT.symbolValue(); - final Stream stream = checkStream(second); - 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) - - { - final AbstractString s = checkString(first); - char[] chars = s.chars(); - final Stream out = outSynonymOf(second); - final int start = Fixnum.getValue(third); - final int end; - if (fourth == NIL) - end = chars.length; + LispObject enc; + boolean encIsCp = false; + + if (format instanceof Cons) { + // meaning a non-empty list + enc = format.car(); + if (enc == keywordCodePage) { + encIsCp = true; + + enc = getf(format.cdr(), keywordID, null); + } + + LispObject eol = 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 - { - end = Fixnum.getValue(fourth); - } - checkBounds(start, end, chars.length); - out._writeChars(chars, start, end); - return first; - } - }; + ; //###FIXME: raise an error! - // ### %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) - { - return finishOutput(arg); - } - }; + if (encIsCp) + encoding = "Cp" + encoding; - // ### %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) - { - return finishOutput(arg); - } - }; + eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + externalFormat = format; - private static final LispObject finishOutput(LispObject arg) + if (reader != null + && reader instanceof DecodingReader) + ((DecodingReader)reader).setCharset(Charset.forName(encoding)); + } - { - final LispObject out; - if (arg == T) - out = Symbol.TERMINAL_IO.symbolValue(); - else if (arg == NIL) - out = Symbol.STANDARD_OUTPUT.symbolValue(); - else - out = arg; - return checkStream(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) - { - 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; - } - }; + public boolean isOpen() { + return open; + } - // ### %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) - { - 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) - { - return checkStream(arg).close(NIL); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - final Stream stream = checkStream(first); - 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) - { - 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) - - { - int n = Fixnum.getValue(first); - if (n < 0 || n > 255) - return type_error(first, UNSIGNED_BYTE_8); - checkStream(second)._writeByte(n); - return NIL; - } - }; + public void setOpen(boolean b) { + open = b; + } + + @Override + public LispObject typeOf() { + return Symbol.SYSTEM_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) - - { - return checkBinaryInputStream(first).readByte((second != NIL), - third); - } - - @Override - public LispObject execute (LispObject[] args) - { - 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() - { - final LispObject obj = Symbol.STANDARD_INPUT.symbolValue(); - final Stream stream = checkStream(obj); - return stream.readLine(true, NIL); - } - @Override - public LispObject execute(LispObject arg) - { - if (arg == T) - arg = Symbol.TERMINAL_IO.symbolValue(); - else if (arg == NIL) - arg = Symbol.STANDARD_INPUT.symbolValue(); - final Stream stream = checkStream(arg); - return stream.readLine(true, NIL); - } - @Override - public LispObject execute(LispObject first, LispObject second) - - { - if (first == T) - first = Symbol.TERMINAL_IO.symbolValue(); - else if (first == NIL) - first = Symbol.STANDARD_INPUT.symbolValue(); - final Stream stream = checkStream(first); - return stream.readLine(second != NIL, NIL); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - if (first == T) - first = Symbol.TERMINAL_IO.symbolValue(); - else if (first == NIL) - first = Symbol.STANDARD_INPUT.symbolValue(); - final Stream stream = checkStream(first); - return stream.readLine(second != NIL, third); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - - { - // recursive-p is ignored - if (first == T) - first = Symbol.TERMINAL_IO.symbolValue(); - else if (first == NIL) - first = Symbol.STANDARD_INPUT.symbolValue(); - final Stream stream = checkStream(first); - 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) - - { - 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, Fixnum.getInstance(in.getOffset())); - } - }; + @Override + public LispObject classOf() { + return BuiltInClass.SYSTEM_STREAM; + } - // ### 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() - { - final LispThread thread = LispThread.currentThread(); - final LispObject obj = Symbol.STANDARD_INPUT.symbolValue(thread); - final Stream stream = checkStream(obj); - return stream.read(true, NIL, false, thread); - } - @Override - public LispObject execute(LispObject arg) - { - 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 = checkStream(arg); - return stream.read(true, NIL, false, thread); - } - @Override - public LispObject execute(LispObject first, LispObject second) + @Override + public LispObject typep(LispObject typeSpecifier) { + if (typeSpecifier == Symbol.SYSTEM_STREAM) + return T; + if (typeSpecifier == Symbol.STREAM) + return T; + if (typeSpecifier == BuiltInClass.STREAM) + return T; + return super.typep(typeSpecifier); + } + + public LispObject getElementType() { + return elementType; + } - { - 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 = checkStream(first); - return stream.read(second != NIL, NIL, false, thread); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) + // Character input. + public int getOffset() { + return offset; + } - { - 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 = checkStream(first); - return stream.read(second != NIL, third, false, thread); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) + // Character input. + public final int getLineNumber() { + return lineNumber; + } - { - 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 = checkStream(first); - 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) - { - 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() - { - return checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()).readChar(); - } - @Override - public LispObject execute(LispObject arg) - { - return inSynonymOf(arg).readChar(); - } - @Override - public LispObject execute(LispObject first, LispObject second) - - { - return inSynonymOf(first).readChar(second != NIL, NIL); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - return inSynonymOf(first).readChar(second != NIL, third); - } - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - - { - 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") { + protected void setWriter(Writer writer) { + this.writer = writer; + } - @Override - public LispObject execute(LispObject[] args) - { - 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); - } - }; + // Character output. + public int getCharPos() { + return charPos; + } - // ### 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") { + // Character output. + public void setCharPos(int n) { + charPos = n; + } - @Override - public LispObject execute(LispObject[] args) - { - 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) - { - return getStandardInput().unreadChar(checkCharacter(arg)); - } - @Override - public LispObject execute(LispObject first, LispObject second) - - { - 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) - - { - final AbstractVector v = checkVector(first); - final Stream stream = checkStream(second); - 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) - - { - 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, list(Symbol.VECTOR, - UNSIGNED_BYTE_8)); - for (int i = start; i < end; i++) - { - int n = stream._readByte(); - if (n < 0) - { - // End of file. - return Fixnum.getInstance(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) - { - return checkStream(arg).getFilePosition(); - } - @Override - public LispObject execute(LispObject first, LispObject second) - - { - return checkStream(first).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) - { - return Fixnum.getInstance(checkStream(arg).getLineNumber() + 1); - } - }; - - // ### stream-offset - private static final Primitive STREAM_OFFSET = - new Primitive("stream-offset", PACKAGE_SYS, false, "stream") - { - @Override - public LispObject execute(LispObject arg) - { - return number(checkStream(arg).getOffset()); - } - }; - - // ### stream-charpos stream => position - private static final Primitive STREAM_CHARPOS = - new Primitive("stream-charpos", PACKAGE_SYS, false) - { - @Override - public LispObject execute(LispObject arg) - { - Stream stream = checkCharacterOutputStream(arg); - return Fixnum.getInstance(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) - - { - Stream stream = checkCharacterOutputStream(first); - stream.setCharPos(Fixnum.getValue(second)); - return second; - } + public LispObject read(boolean eofError, LispObject eofValue, + boolean recursive, LispThread thread) + + { + LispObject result = readPreservingWhitespace(eofError, eofValue, + recursive, thread); + if (result != eofValue && !recursive) { + try { + if (_charReady()) { + int n = _readChar(); + if (n >= 0) { + char c = (char) n; // ### BUG: Codepoint conversion + Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + if (!rt.isWhitespace(c)) + _unreadChar(c); + } + } + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + 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) + + { + if (recursive) { + final Readtable rt = (Readtable) Symbol.CURRENT_READTABLE.symbolValue(thread); + while (true) { + int n = -1; + try { + n = _readChar(); + } catch (IOException e) { + error(new StreamError(this, e)); + } + if (n < 0) { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + char c = (char) n; // ### BUG: Codepoint conversion + if (rt.isWhitespace(c)) + continue; + LispObject result = processChar(c, rt); + if (result != null) + return result; + } + } else { + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); + try { + return readPreservingWhitespace(eofError, eofValue, true, thread); + } finally { + thread.resetSpecialBindings(mark); + } + } + } + + public LispObject faslRead(boolean eofError, LispObject eofValue, + boolean recursive, LispThread thread) + + { + try { + LispObject result = faslReadPreservingWhitespace(eofError, eofValue, + recursive, thread); + if (result != eofValue && !recursive) { + if (_charReady()) { + int n = _readChar(); + if (n >= 0) { + char c = (char) n; // ### BUG: Codepoint conversion + Readtable rt = FaslReadtable.getInstance(); + if (!rt.isWhitespace(c)) + _unreadChar(c); + } + } + } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) + return NIL; + else + return result; + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + private final LispObject faslReadPreservingWhitespace(boolean eofError, + LispObject eofValue, + boolean recursive, + LispThread thread) + throws IOException { + 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; // ### BUG: Codepoint conversion + if (rt.isWhitespace(c)) + continue; + LispObject result = processChar(c, rt); + if (result != null) + return result; + } + } else { + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(_SHARP_EQUAL_ALIST_, NIL); + try { + return faslReadPreservingWhitespace(eofError, eofValue, true, thread); + } finally { + thread.resetSpecialBindings(mark); + } + } + } + + private final LispObject processChar(char c, Readtable rt) + + { + final LispObject handler = rt.getReaderMacroFunction(c); + if (handler instanceof ReaderMacroFunction) + return ((ReaderMacroFunction)handler).execute(this, c); + if (handler != null && handler != NIL) + return handler.execute(this, LispCharacter.getInstance(c)); + return readToken(c, rt); + } + + public LispObject readPathname() { + 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() { + 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() { + 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) { + FastStringBuffer sb = new FastStringBuffer(); + _readToken(sb, rt); + return new Symbol(sb.toString()); + } + + public LispObject readStructure() { + 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() { + 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) + + { + final LispThread thread = LispThread.currentThread(); + Cons first = null; + Cons last = null; + Readtable rt = null; + if (useFaslReadtable) + rt = FaslReadtable.getInstance(); + try { + 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; // ### BUG: Codepoint conversion + 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; + } + } + } catch (IOException e) { + error(new StreamError(this, e)); + return null; + } + } + + private static final boolean isTokenDelimiter(char c, Readtable rt) + + { + switch (c) { + case '"': + case '\'': + case '(': + case ')': + case ',': + case ';': + case '`': + return true; + default: + return rt.isWhitespace(c); + } + } + + public LispObject readDispatchChar(char dispChar, boolean useFaslReadtable) + + { + int numArg = -1; + char c = 0; + try { + while (true) { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + c = (char) n; // ### BUG: Codepoint conversion + if (c < '0' || c > '9') + break; + if (numArg < 0) + numArg = 0; + numArg = numArg * 10 + c - '0'; + } + } catch (IOException e) { + error(new StreamError(this, e)); + } + 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 : Fixnum.getInstance(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) + + { + try { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion + FastStringBuffer sb = new FastStringBuffer(c); + while (true) { + n = _readChar(); + if (n < 0) + break; + c = (char) n; // ### BUG: Codepoint conversion + 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); // ### BUG: Codepoint conversion + return error(new LispError("Unrecognized character name: \"" + token + '"')); + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + public void skipBalancedComment() { + try { + 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); + } + } + } catch (IOException e) { + error(new StreamError(this, e)); + } + } + + public LispObject readArray(int rank) { + 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) { + 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() { + 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() { + 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) { + FastStringBuffer sb = new FastStringBuffer(); + try { + while (true) { + int n = _readChar(); + if (n < 0) { + error(new EndOfFile(this)); + // Not reached. + return null; + } + char c = (char) n; // ### BUG: Codepoint conversion + byte syntaxType = rt.getSyntaxType(c); + if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { + n = _readChar(); + if (n < 0) { + error(new EndOfFile(this)); + // Not reached. + return null; + } + sb.append((char)n); // ### BUG: Codepoint conversion + continue; + } + if (syntaxType == Readtable.SYNTAX_TYPE_MULTIPLE_ESCAPE) + break; + sb.append(c); + } + } catch (IOException e) { + error(new StreamError(this, e)); + } + 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) + + { + 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) + + { + 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 = -1; + try { + n = _readChar(); + } catch (IOException e) { + error(new StreamError(this, e)); + return flags; + } + if (n < 0) { + error(new EndOfFile(this)); + // Not reached. + return flags; + } + sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion + 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)); + } + } + try { + while (true) { + int n = _readChar(); + if (n < 0) + break; + char c = (char) n; // ### BUG: Codepoint conversion + 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); // ### BUG: Codepoint conversion + 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); + } + } catch (IOException e) { + error(new StreamError(this, e)); + return flags; + } + + 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) + + { + final int readBase; + final LispObject readBaseObject = Symbol.READ_BASE.symbolValue(thread); + if (readBaseObject instanceof Fixnum) { + readBase = ((Fixnum)readBaseObject).value; + } else { + // The value of *READ-BASE* is not a Fixnum. + error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); + // Not reached. + return 10; + } + if (readBase < 2 || readBase > 36) { + error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); + // Not reached. + return 10; + } + return readBase; + } + + private final LispObject makeNumber(String token, int length, int radix) + + { + 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] : Fixnum.getInstance(n); + } catch (NumberFormatException e) {} + // parseInt() failed. + try { + return Bignum.getInstance(token, radix); + } catch (NumberFormatException e) {} + // Not a number. + return null; + } + + private final LispObject makeRatio(String token, int radix) + + { + 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) + + { + 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) { + 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] : Fixnum.getInstance(n); + } catch (NumberFormatException e) {} + // parseInt() failed. + try { + return Bignum.getInstance(s, radix); + } catch (NumberFormatException e) {} + // Not a number. + return error(new LispError()); + } + + public LispObject faslReadRadix(int radix) { + 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] : Fixnum.getInstance(n); + } catch (NumberFormatException e) {} + // parseInt() failed. + try { + return Bignum.getInstance(s, radix); + } catch (NumberFormatException e) {} + // Not a number. + return error(new LispError()); + } + + private char flushWhitespace(Readtable rt) { + try { + while (true) { + int n = _readChar(); + if (n < 0) { + error(new EndOfFile(this)); + // Not reached. + return 0; + } + char c = (char) n; // ### BUG: Codepoint conversion + if (!rt.isWhitespace(c)) + return c; + } + } catch (IOException e) { + error(new StreamError(this, e)); + return 0; + } + } + + public LispObject readDelimitedList(char delimiter) + + { + 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) + + { + final LispThread thread = LispThread.currentThread(); + FastStringBuffer sb = new FastStringBuffer(); + try { + 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); // ### BUG: Codepoint conversion + } + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + // read-char &optional stream eof-error-p eof-value recursive-p => char + // recursive-p is ignored + public LispObject readChar() { + try { + int n = _readChar(); + if (n < 0) + return error(new EndOfFile(this)); + return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion + } catch (IOException e) { + return error(new StreamError(this, e)); + } + + } + + public LispObject readChar(boolean eofError, LispObject eofValue) + + { + try { + int n = _readChar(); + if (n < 0) { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + return LispCharacter.getInstance((char)n); // ### BUG: Codepoint conversion + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + // 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) + + { + try { + return _charReady() ? readChar(eofError, eofValue) : NIL; + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + + // unread-char character &optional input-stream => nil + public LispObject unreadChar(LispCharacter c) { + try { + _unreadChar(c.value); + return NIL; + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + public LispObject finishOutput() { + _finishOutput(); + return NIL; + } + + // clear-input &optional input-stream => nil + public LispObject clearInput() { + _clearInput(); + return NIL; + } + + public LispObject getFilePosition() { + long pos = _getFilePosition(); + return pos >= 0 ? number(pos) : NIL; + } + + public LispObject setFilePosition(LispObject arg) { + 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) { + _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) + + { + int n = _readByte(); + if (n < 0) { + if (eofError) + return error(new EndOfFile(this)); + else + return eofValue; + } + return Fixnum.constants[n]; + } + + public LispObject terpri() { + _writeChar('\n'); + return NIL; + } + + public LispObject freshLine() { + if (charPos == 0) + return NIL; + _writeChar('\n'); + return T; + } + + public void print(char c) { + _writeChar(c); + } + + // PRIN1 produces output suitable for input to READ. + // Binds *PRINT-ESCAPE* to true. + public void prin1(LispObject obj) { + LispThread thread = LispThread.currentThread(); + final SpecialBindingsMark mark = thread.markSpecialBindings(); + thread.bindSpecial(Symbol.PRINT_ESCAPE, T); + try { + _writeString(obj.writeToString()); + } finally { + thread.resetSpecialBindings(mark); + } + } + + public LispObject listen() { + if (pastEnd) + return NIL; + try { + if (! _charReady()) + return NIL; + + int n = _readChar(); + if (n < 0) + return NIL; + + _unreadChar(n); + + return T; + } catch (IOException e) { + return error(new StreamError(this, e)); + } + } + + public LispObject fileLength() { + return type_error(this, Symbol.FILE_STREAM); + } + + public LispObject fileStringLength(LispObject arg) { + 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 + */ + protected int _readChar() throws IOException { + if (reader == null) + streamNotCharacterInputStream(); + + int n = reader.read(); + + if (n < 0) { + pastEnd = true; + return -1; + } + + ++offset; + if (n == '\r' && eolStyle == EolStyle.CRLF) { + n = _readChar(); + if (n != '\n') { + _unreadChar(n); + return '\r'; + } else + return '\n'; + } + + if (n == eolChar) { + ++lineNumber; + return '\n'; + } + + return n; + } + + /** Puts a character back into the (underlying) stream + * + * @param n + */ + protected void _unreadChar(int n) throws IOException { + if (reader == null) + streamNotCharacterInputStream(); + + --offset; + if (n == '\n') { + n = eolChar; + --lineNumber; + } + + reader.unread(n); + pastEnd = false; + } + + + /** Returns a boolean indicating input readily available + * + * @return true if a character is available + */ + protected boolean _charReady() throws IOException { + if (reader == null) + streamNotCharacterInputStream(); + return reader.ready(); + } + + /** Writes a character into the underlying stream, + * updating charPos while doing so + * + * @param c + */ + public void _writeChar(char c) { + 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 + */ + public void _writeChars(char[] chars, int start, int end) + + { + 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 + */ + public void _writeString(String s) { + 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 + */ + public void _writeLine(String s) { + 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 + */ + public int _readByte() { + 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 + */ + public void _writeByte(int n) { + 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 + * + */ + public void _finishOutput() { + 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 + * + */ + public void _clearInput() { + if (reader != null) { + int c = 0; + try { + while (_charReady() && (c >= 0)) + c = _readChar(); + } catch (IOException e) { + error(new StreamError(this, e)); + } + } 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' + */ + protected long _getFilePosition() { + 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 + */ + protected boolean _setFilePosition(LispObject arg) { + return false; + } + + /** Closes the stream and underlying streams + * + */ + public void _close() { + 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) { + 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() { + return error(new StreamError(this, writeToString() + " is not an input stream.")); + } + + protected LispObject streamNotCharacterInputStream() { + return error(new StreamError(this, writeToString() + " is not a character input stream.")); + } + + protected LispObject streamNotOutputStream() { + return error(new StreamError(this, writeToString() + " is not an output stream.")); + } + + protected LispObject streamNotBinaryOutputStream() { + return error(new StreamError(this, writeToString() + " is not a binary output stream.")); + } + + protected LispObject streamNotCharacterOutputStream() { + 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) + + { + checkStream(second)._writeChar(LispCharacter.getValue(first)); + 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) + + { + final char c = LispCharacter.getValue(first); + if (second == T) + second = Symbol.TERMINAL_IO.symbolValue(); + else if (second == NIL) + second = Symbol.STANDARD_OUTPUT.symbolValue(); + final Stream stream = checkStream(second); + 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) + + { + final AbstractString s = checkString(first); + char[] chars = s.chars(); + final Stream out = outSynonymOf(second); + final int start = Fixnum.getValue(third); + final int end; + if (fourth == NIL) + end = chars.length; + else { + end = Fixnum.getValue(fourth); + } + 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) { + 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) { + return finishOutput(arg); + } + }; + + private static final LispObject finishOutput(LispObject arg) + + { + final LispObject out; + if (arg == T) + out = Symbol.TERMINAL_IO.symbolValue(); + else if (arg == NIL) + out = Symbol.STANDARD_OUTPUT.symbolValue(); + else + out = arg; + return checkStream(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) { + 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) { + 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) { + return checkStream(arg).close(NIL); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + + { + final Stream stream = checkStream(first); + 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) { + 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) + + { + int n = Fixnum.getValue(first); + if (n < 0 || n > 255) + return type_error(first, UNSIGNED_BYTE_8); + checkStream(second)._writeByte(n); + return NIL; + } + }; + + // ### 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) + + { + return checkBinaryInputStream(first).readByte((second != NIL), + third); + } + + @Override + public LispObject execute (LispObject[] args) { + 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() { + final LispObject obj = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream = checkStream(obj); + return stream.readLine(true, NIL); + } + @Override + public LispObject execute(LispObject arg) { + if (arg == T) + arg = Symbol.TERMINAL_IO.symbolValue(); + else if (arg == NIL) + arg = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream = checkStream(arg); + return stream.readLine(true, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second) + + { + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream = checkStream(first); + return stream.readLine(second != NIL, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + + { + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream = checkStream(first); + return stream.readLine(second != NIL, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + + { + // recursive-p is ignored + if (first == T) + first = Symbol.TERMINAL_IO.symbolValue(); + else if (first == NIL) + first = Symbol.STANDARD_INPUT.symbolValue(); + final Stream stream = checkStream(first); + 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) + + { + 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, Fixnum.getInstance(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() { + final LispThread thread = LispThread.currentThread(); + final LispObject obj = Symbol.STANDARD_INPUT.symbolValue(thread); + final Stream stream = checkStream(obj); + return stream.read(true, NIL, false, thread); + } + @Override + public LispObject execute(LispObject arg) { + 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 = checkStream(arg); + return stream.read(true, NIL, false, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second) + + { + 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 = checkStream(first); + return stream.read(second != NIL, NIL, false, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + + { + 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 = checkStream(first); + return stream.read(second != NIL, third, false, thread); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + + { + 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 = checkStream(first); + 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) { + 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() { + return checkCharacterInputStream(Symbol.STANDARD_INPUT.symbolValue()).readChar(); + } + @Override + public LispObject execute(LispObject arg) { + return inSynonymOf(arg).readChar(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + + { + return inSynonymOf(first).readChar(second != NIL, NIL); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + + { + return inSynonymOf(first).readChar(second != NIL, third); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + + { + 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) { + 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) { + 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) { + return getStandardInput().unreadChar(checkCharacter(arg)); + } + @Override + public LispObject execute(LispObject first, LispObject second) + + { + 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) + + { + final AbstractVector v = checkVector(first); + final Stream stream = checkStream(second); + 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) + + { + 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, list(Symbol.VECTOR, + UNSIGNED_BYTE_8)); + for (int i = start; i < end; i++) { + int n = stream._readByte(); + if (n < 0) { + // End of file. + return Fixnum.getInstance(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) { + return checkStream(arg).getFilePosition(); + } + @Override + public LispObject execute(LispObject first, LispObject second) + + { + return checkStream(first).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) { + return Fixnum.getInstance(checkStream(arg).getLineNumber() + 1); + } + }; + + // ### stream-offset + private static final Primitive STREAM_OFFSET = + new Primitive("stream-offset", PACKAGE_SYS, false, "stream") { + @Override + public LispObject execute(LispObject arg) { + return number(checkStream(arg).getOffset()); + } + }; + + // ### stream-charpos stream => position + private static final Primitive STREAM_CHARPOS = + new Primitive("stream-charpos", PACKAGE_SYS, false) { + @Override + public LispObject execute(LispObject arg) { + Stream stream = checkCharacterOutputStream(arg); + return Fixnum.getInstance(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) + + { + Stream stream = checkCharacterOutputStream(first); + stream.setCharPos(Fixnum.getValue(second)); + return second; + } }; } Modified: trunk/abcl/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringInputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringInputStream.java Mon Jan 11 15:03:29 2010 @@ -54,6 +54,7 @@ public StringInputStream(String s, int start, int end) { + super(Symbol.STRING_INPUT_STREAM); elementType = Symbol.CHARACTER; setExternalFormat(keywordDefault); eolStyle = EolStyle.RAW; Modified: trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StringOutputStream.java Mon Jan 11 15:03:29 2010 @@ -48,6 +48,7 @@ private StringOutputStream(LispObject elementType) { + super(Symbol.STRING_OUTPUT_STREAM); this.elementType = elementType; this.eolStyle = EolStyle.RAW; initAsCharacterOutputStream(stringWriter = new StringWriter()); Modified: trunk/abcl/src/org/armedbear/lisp/StructureObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StructureObject.java (original) +++ trunk/abcl/src/org/armedbear/lisp/StructureObject.java Mon Jan 11 15:03:29 2010 @@ -35,11 +35,23 @@ import static org.armedbear.lisp.Lisp.*; -public final class StructureObject extends LispObject +public class StructureObject extends LispObject { private final StructureClass structureClass; private final LispObject[] slots; + public StructureObject(Symbol symbol) + + { + structureClass = (StructureClass) LispClass.findClass(symbol/*, true*/); // Might return null. + if (structureClass == null) { + System.err.println("No mitens sitten: " + BuiltInClass.SYSTEM_STREAM.toString()); + System.err.println("joopa joo:" + Symbol.SYSTEM_STREAM.name); + System.err.println("Oh noes, structure object got a null class:" + symbol.toString() + ", symbol name:" + symbol.name ); + } + slots = new LispObject[0]; + } + public StructureObject(Symbol symbol, LispObject[] slots) { Modified: trunk/abcl/src/org/armedbear/lisp/SynonymStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SynonymStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SynonymStream.java Mon Jan 11 15:03:29 2010 @@ -41,6 +41,7 @@ private SynonymStream(Symbol symbol) { + super(Symbol.SYNONYM_STREAM); this.symbol = symbol; } Modified: trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/TwoWayStream.java Mon Jan 11 15:03:29 2010 @@ -42,6 +42,7 @@ public TwoWayStream(Stream in, Stream out) { + super(Symbol.TWO_WAY_STREAM); this.in = in; this.out = out; isInputStream = true; Modified: trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java Mon Jan 11 15:03:29 2010 @@ -6,7 +6,6 @@ import java.io.StringWriter; import org.armedbear.lisp.Stream; - /** * A bidirectional stream that captures input from a modal dialog. The dialog reports a label (prompt line) * which shows to the user everything that has been printed to the stream up to the moment when the dialog @@ -54,6 +53,7 @@ * Inits this stream. Should be called by subclasses' constructors. */ protected DialogPromptStream() { + super(org.armedbear.lisp.Symbol.SYSTEM_STREAM); initAsCharacterOutputStream(writtenSoFar); initAsCharacterInputStream(reader); } Modified: trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ trunk/abcl/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Mon Jan 11 15:03:29 2010 @@ -81,7 +81,7 @@ } public void setStandardInput(InputStream stream, LispThread thread) { - thread.setSpecialVariable(Symbol.STANDARD_INPUT, new Stream(stream, Symbol.CHARACTER, true)); + thread.setSpecialVariable(Symbol.STANDARD_INPUT, new Stream(Symbol.SYSTEM_STREAM, stream, Symbol.CHARACTER, true)); } public void setStandardInput(InputStream stream) { @@ -108,7 +108,7 @@ public LispObject loadFromClasspath(String classpathResource) { InputStream istream = getClass().getResourceAsStream(classpathResource); - Stream stream = new Stream(istream, Symbol.CHARACTER); + Stream stream = new Stream(Symbol.SYSTEM_STREAM, istream, Symbol.CHARACTER); return load(stream); } @@ -236,8 +236,8 @@ 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); + Stream outStream = new Stream(Symbol.SYSTEM_STREAM, out, Symbol.CHARACTER); + Stream inStream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); retVal = evaluator.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)), makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)), inStream, outStream, Modified: trunk/abcl/src/org/armedbear/lisp/socket_stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/socket_stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/socket_stream.java Mon Jan 11 15:03:29 2010 @@ -53,9 +53,9 @@ LispObject elementType = second; // Checked by caller. try { Stream in = - new Stream(socket.getInputStream(), elementType, third); + new Stream(Symbol.SYSTEM_STREAM, socket.getInputStream(), elementType, third); Stream out = - new Stream(socket.getOutputStream(), elementType, third); + new Stream(Symbol.SYSTEM_STREAM, socket.getOutputStream(), elementType, third); return new SocketStream(socket, in, out); } catch (Exception e) { From ehuelsmann at common-lisp.net Mon Jan 11 20:37:31 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 Jan 2010 15:37:31 -0500 Subject: [armedbear-cvs] r12363 - branches/0.18.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 11 15:37:22 2010 New Revision: 12363 Log: Backport r12350 upto 12355 and 12359: fixes to recently added functionality. Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Mon Jan 11 15:37:22 2010 @@ -37,15 +37,30 @@ public final class WrongNumberOfArgumentsException extends ProgramError { - private final Operator operator; + private Operator operator; + private int expectedArgs; + private String message; - public WrongNumberOfArgumentsException(Operator operator) + public WrongNumberOfArgumentsException(Operator operator) { + this(operator, -1); + } - { + public WrongNumberOfArgumentsException(Operator operator, int expectedArgs) { // 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; + this.expectedArgs = expectedArgs; + setFormatControl(getMessage()); + setFormatArguments(NIL); + } + + public WrongNumberOfArgumentsException(String message) { + super(StandardClass.PROGRAM_ERROR); + if(message == null) { + throw new NullPointerException("message can not be null"); + } + this.message = message; setFormatControl(getMessage()); setFormatArguments(NIL); } @@ -53,6 +68,9 @@ @Override public String getMessage() { + if(message != null) { + return message; + } FastStringBuffer sb = new FastStringBuffer("Wrong number of arguments"); LispObject lambdaName = operator.getLambdaName(); @@ -60,7 +78,12 @@ sb.append(" for "); sb.append(operator.getLambdaName().writeToString()); } + if(expectedArgs >= 0) { + sb.append("; "); + sb.append(expectedArgs); + sb.append(" expected"); + } sb.append('.'); - return sb.toString(); + return message = sb.toString(); } } From ehuelsmann at common-lisp.net Mon Jan 11 20:49:45 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 11 Jan 2010 15:49:45 -0500 Subject: [armedbear-cvs] r12364 - in branches/0.18.x/abcl: . nbproject src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 11 15:49:44 2010 New Revision: 12364 Log: Backport r12350 upto 12355 and 12359: fixes to recently added functionality (attempt 2). Modified: branches/0.18.x/abcl/CHANGES branches/0.18.x/abcl/nbproject/project.properties branches/0.18.x/abcl/netbeans-build.xml branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java branches/0.18.x/abcl/src/org/armedbear/lisp/Java.java branches/0.18.x/abcl/src/org/armedbear/lisp/JavaObject.java Modified: branches/0.18.x/abcl/CHANGES ============================================================================== --- branches/0.18.x/abcl/CHANGES (original) +++ branches/0.18.x/abcl/CHANGES Mon Jan 11 15:49:44 2010 @@ -23,6 +23,7 @@ * Line numbers in generated java classes incorrect * JCALL, JNEW doesn't select best match when multiple applicable methods * STREAM-EXTERNAL-FORMAT always returns :DEFAULT, instead of actual format + * REPL no longer hangs in Netbeans 6.[578] output window * Lambda-list variables replaced by surrounding SYMBOL-MACROLET @@ -30,7 +31,7 @@ * LispObject does not inherit from Lisp anymore * Many functions declared 'final' for performance improvement - + * SYSTEM:*SOURCE* FASLs for system files no longer refer to intermediate build location Version 0.17.0 Modified: branches/0.18.x/abcl/nbproject/project.properties ============================================================================== --- branches/0.18.x/abcl/nbproject/project.properties (original) +++ branches/0.18.x/abcl/nbproject/project.properties Mon Jan 11 15:49:44 2010 @@ -1,10 +1,11 @@ application.title=abcl application.vendor= build.classes.dir=${build.dir}/classes -build.classes.excludes=**/*.java,**/*.form +build.classes.excludes=**/*.java,**/*.form,**/*.lisp # This directory is removed when the project is cleaned: build.dir=build build.generated.dir=${build.dir}/generated +build.generated.sources.dir=${build.dir}/generated-sources # Only compile against the classpath explicitly listed here: build.sysclasspath=ignore build.test.classes.dir=${build.dir}/test/classes @@ -43,6 +44,7 @@ javadoc.use=true javadoc.version=false javadoc.windowtitle= +jaxbwiz.endorsed.dirs="${netbeans.home}/../ide12/modules/ext/jaxb/api" jnlp.codebase.type=local jnlp.codebase.url=file:/Users/evenson/work/abcl/dist/ jnlp.enabled=false Modified: branches/0.18.x/abcl/netbeans-build.xml ============================================================================== --- branches/0.18.x/abcl/netbeans-build.xml (original) +++ branches/0.18.x/abcl/netbeans-build.xml Mon Jan 11 15:49:44 2010 @@ -7,20 +7,7 @@ - build.classes.dir: ${build.classes.dir} - - - - - - - - - - - + Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Mon Jan 11 15:49:44 2010 @@ -34,11 +34,8 @@ package org.armedbear.lisp; import static org.armedbear.lisp.Lisp.*; - import java.util.Hashtable; - - public class AutoloadedFunctionProxy extends Function { public enum FunctionType @@ -240,6 +237,7 @@ return new JavaObject(new Hashtable()); } + // ### proxy-preloaded-function final private static Primitive PROXY_PRELOADED_FUNCTION = new Primitive("proxy-preloaded-function", PACKAGE_SYS, false, "symbol name") @@ -284,7 +282,7 @@ } }; - + // ### function-preload final private static Primitive FUNCTION_PRELOAD = new Primitive("function-preload", PACKAGE_SYS, false, "name") { Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/Java.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/Java.java Mon Jan 11 15:49:44 2010 @@ -841,6 +841,14 @@ return false; } + public static Class maybeBoxClass(Class clazz) { + if(clazz.isPrimitive()) { + return getBoxedClass(clazz); + } else { + return clazz; + } + } + private static Class getBoxedClass(Class clazz) { if (clazz.equals(int.class)) { return Integer.class; Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/JavaObject.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/JavaObject.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/JavaObject.java Mon Jan 11 15:49:44 2010 @@ -47,12 +47,14 @@ public JavaObject(Object obj) { this.obj = obj; - this.intendedClass = obj != null ? obj.getClass() : null; + this.intendedClass = + obj != null ? Java.maybeBoxClass(obj.getClass()) : null; } /** * Constructs a Java Object with the given intended class, used to access - * the object reflectively. + * the object reflectively. If the class represents a primitive type, + * the corresponding wrapper type is used instead. * @throws ClassCastException if the object is not an instance of the * intended class. */ @@ -60,8 +62,11 @@ if(obj != null && intendedClass == null) { intendedClass = obj.getClass(); } - if(intendedClass != null && !intendedClass.isInstance(obj)) { - throw new ClassCastException(obj + " can not be cast to " + intendedClass); + if(intendedClass != null) { + intendedClass = Java.maybeBoxClass(intendedClass); + if(!intendedClass.isInstance(obj)) { + throw new ClassCastException(obj + " can not be cast to " + intendedClass); + } } this.obj = obj; this.intendedClass = intendedClass; @@ -229,13 +234,19 @@ } @Override - public Object javaInstance(Class c) { + public Object javaInstance(Class c) { if(obj == null) { - return obj; - } else if(c.isAssignableFrom(intendedClass)) { + if(c.isPrimitive()) { + throw new NullPointerException("Cannot assign null to " + c); + } return obj; } else { - return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); + c = Java.maybeBoxClass(c); + if(c.isAssignableFrom(intendedClass)) { + return obj; + } else { + return error(new TypeError(intendedClass.getName() + " is not assignable to " + c.getName())); + } } } From ehuelsmann at common-lisp.net Tue Jan 12 19:44:28 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 12 Jan 2010 14:44:28 -0500 Subject: [armedbear-cvs] r12365 - in tags/0.18.0: . abcl abcl/nbproject abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 12 14:44:24 2010 New Revision: 12365 Log: Tag 0.18.0. Added: tags/0.18.0/ - copied from r12362, /branches/0.18.x/ tags/0.18.0/abcl/CHANGES - copied, changed from r12364, /branches/0.18.x/abcl/CHANGES tags/0.18.0/abcl/nbproject/project.properties - copied unchanged from r12364, /branches/0.18.x/abcl/nbproject/project.properties tags/0.18.0/abcl/netbeans-build.xml - copied unchanged from r12364, /branches/0.18.x/abcl/netbeans-build.xml tags/0.18.0/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java - copied unchanged from r12364, /branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java tags/0.18.0/abcl/src/org/armedbear/lisp/Java.java - copied unchanged from r12364, /branches/0.18.x/abcl/src/org/armedbear/lisp/Java.java tags/0.18.0/abcl/src/org/armedbear/lisp/JavaObject.java - copied unchanged from r12364, /branches/0.18.x/abcl/src/org/armedbear/lisp/JavaObject.java tags/0.18.0/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java - copied unchanged from r12363, /branches/0.18.x/abcl/src/org/armedbear/lisp/WrongNumberOfArgumentsException.java Modified: tags/0.18.0/abcl/src/org/armedbear/lisp/Version.java Copied: tags/0.18.0/abcl/CHANGES (from r12364, /branches/0.18.x/abcl/CHANGES) ============================================================================== --- /branches/0.18.x/abcl/CHANGES (original) +++ tags/0.18.0/abcl/CHANGES Tue Jan 12 14:44:24 2010 @@ -1,6 +1,7 @@ Version 0.18.0 ============== - +svn://common-lisp.net/project/armedbear/svn/tags/0.18.0/abcl +(12 Jan, 2010) Features: Modified: tags/0.18.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.18.0/abcl/src/org/armedbear/lisp/Version.java Tue Jan 12 14:44:24 2010 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.18.0-dev"; + return "0.18.0"; } } From ehuelsmann at common-lisp.net Tue Jan 12 19:47:46 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 12 Jan 2010 14:47:46 -0500 Subject: [armedbear-cvs] r12366 - tags/0.18.0 Message-ID: Author: ehuelsmann Date: Tue Jan 12 14:47:45 2010 New Revision: 12366 Log: Delete botched tag. Removed: tags/0.18.0/ From ehuelsmann at common-lisp.net Tue Jan 12 19:48:26 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 12 Jan 2010 14:48:26 -0500 Subject: [armedbear-cvs] r12367 - in tags/0.18.0: . abcl abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 12 14:48:25 2010 New Revision: 12367 Log: Re-tag 0.18.0. Added: tags/0.18.0/ - copied from r12365, /branches/0.18.x/ Modified: tags/0.18.0/abcl/CHANGES tags/0.18.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.18.0/abcl/CHANGES ============================================================================== --- /branches/0.18.x/abcl/CHANGES (original) +++ tags/0.18.0/abcl/CHANGES Tue Jan 12 14:48:25 2010 @@ -1,6 +1,7 @@ Version 0.18.0 ============== - +svn://common-lisp.net/project/armedbear/svn/tags/0.18.0/abcl +(12 Jan, 2010) Features: Modified: tags/0.18.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.18.0/abcl/src/org/armedbear/lisp/Version.java Tue Jan 12 14:48:25 2010 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.18.0-dev"; + return "0.18.0"; } } From ehuelsmann at common-lisp.net Tue Jan 12 21:30:47 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 12 Jan 2010 16:30:47 -0500 Subject: [armedbear-cvs] r12368 - public_html/releases Message-ID: Author: ehuelsmann Date: Tue Jan 12 16:30:42 2010 New Revision: 12368 Log: Add distribution archives (without adding them to the rest of the site yet). Added: public_html/releases/abcl-bin-0.18.0.tar.gz (contents, props changed) public_html/releases/abcl-bin-0.18.0.zip (contents, props changed) public_html/releases/abcl-src-0.18.0.tar.gz (contents, props changed) public_html/releases/abcl-src-0.18.0.zip (contents, props changed) Added: public_html/releases/abcl-bin-0.18.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.18.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.18.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.18.0.zip ============================================================================== Binary file. No diff available. From ehuelsmann at common-lisp.net Tue Jan 12 22:23:54 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 12 Jan 2010 17:23:54 -0500 Subject: [armedbear-cvs] r12369 - public_html Message-ID: Author: ehuelsmann Date: Tue Jan 12 17:23:50 2010 New Revision: 12369 Log: Fix page title (which refers to old release). Modified: public_html/release-notes-0.18.shtml Modified: public_html/release-notes-0.18.shtml ============================================================================== --- public_html/release-notes-0.18.shtml (original) +++ public_html/release-notes-0.18.shtml Tue Jan 12 17:23:50 2010 @@ -3,7 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> - ABCL - Release notes v0.17 + ABCL - Release notes v0.18 From ehuelsmann at common-lisp.net Wed Jan 13 18:47:37 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 13 Jan 2010 13:47:37 -0500 Subject: [armedbear-cvs] r12370 - public_html/releases Message-ID: Author: ehuelsmann Date: Wed Jan 13 13:47:32 2010 New Revision: 12370 Log: Add signature files. Added: public_html/releases/abcl-bin-0.18.0.tar.gz.asc public_html/releases/abcl-bin-0.18.0.zip.asc public_html/releases/abcl-src-0.18.0.tar.gz.asc public_html/releases/abcl-src-0.18.0.zip.asc Added: public_html/releases/abcl-bin-0.18.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.18.0.tar.gz.asc Wed Jan 13 13:47:32 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktOFCQACgkQi5O0Epaz9TkHGQCffS+5utir4jiHcYYR58MYno0d +8EMAnjYht5uxuUYZGbVwqQn2CF2niabo +=j1fD +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-bin-0.18.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.18.0.zip.asc Wed Jan 13 13:47:32 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktOFDEACgkQi5O0Epaz9TlhbACdHYIrI6qpas31lvx13y5aZ3x6 +5+cAnAqL7+NlfoXuyDQdy79AYHTT2IBN +=x3wK +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.18.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.18.0.tar.gz.asc Wed Jan 13 13:47:32 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktOFDoACgkQi5O0Epaz9TkBzQCfTtqGvWSwi/LPc11mwgPYaUHC +51wAnjiR/IeQxTqz0qcPMu8BUoqZ316q +=k7d2 +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.18.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.18.0.zip.asc Wed Jan 13 13:47:32 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktOFEAACgkQi5O0Epaz9TnWuACeIKyvOs2pkqlc8z5T/+PhhOLG +6KMAn2IUWTzl+XfNw3/fUN9rEpgbePHz +=2wHw +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Wed Jan 13 19:06:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 13 Jan 2010 14:06:25 -0500 Subject: [armedbear-cvs] r12371 - public_html Message-ID: Author: ehuelsmann Date: Wed Jan 13 14:06:23 2010 New Revision: 12371 Log: Make 0.18 show up on the site. Modified: public_html/index.shtml public_html/left-menu Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Wed Jan 13 14:06:23 2010 @@ -32,9 +32,9 @@ using Java to Lisp integration APIs. -Download 0.17.0 +Download 0.18.0 (zip) Users Modified: public_html/left-menu ============================================================================== --- public_html/left-menu (original) +++ public_html/left-menu Wed Jan 13 14:06:23 2010 @@ -1,7 +1,7 @@
Project page
Testimonials
-Release notes
+Release notes
Paid support

From ehuelsmann at common-lisp.net Wed Jan 13 19:23:03 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 13 Jan 2010 14:23:03 -0500 Subject: [armedbear-cvs] r12372 - developer-resources Message-ID: Author: ehuelsmann Date: Wed Jan 13 14:23:02 2010 New Revision: 12372 Log: Improved release template (I hope). Modified: developer-resources/release-announcement.txt Modified: developer-resources/release-announcement.txt ============================================================================== --- developer-resources/release-announcement.txt (original) +++ developer-resources/release-announcement.txt Wed Jan 13 14:23:02 2010 @@ -1,23 +1,29 @@ -Subject: [ANNOUNCE] ABCL 0.17.0 released +Subject: [ANNOUNCE] ABCL 0.18.0 released On behalf of the developers of ABCL (Armed Bear Common Lisp) I'm glad to -be able to announce the 0.17.0 release. ABCL is a Common Lisp -implementation implemented in Java and running on the JVM, featuring -both an interpreter and a compiler. The compiler targets the JVM directly -meaning that its output is runnable JVM bytecode. The fact that ABCL is -written in Java allows for relatively easy embedding in larger applications. -For integration with existing applications ABCL implements JSR-223. +be able to announce the 0.18.0 release. +ABCL is a Common Lisp implementation implemented in Java and running on the +JVM, featuring both an interpreter and a compiler. The compiler targets the +JVM directly meaning that its output is runnable JVM bytecode. The fact +that ABCL is written in Java allows for relatively easy embedding in larger +applications. For integration with existing applications ABCL implements +Java Specification Request (JSR) 223: Java scripting API. -This release features - among lots of other things - performance improvements, -a fix for unexpected thread termination due to uncaught exceptions and -example code for running ABCL on Google App Engine. You can find the full + +This release features - among lots of other things - faster initial startup, +faster special variable lookup and portable fasl files. You can find the full release notes at: http://common-lisp.net/project/armedbear/release-notes-0.17.shtml +and the list of changes at: + + http://trac.common-lisp.net/armedbear/browser/trunk/abcl/CHANGES + + If you have questions regarding use or licensing, or you find issues, please report back to the development list: @@ -26,21 +32,21 @@ Source distribution archives can be downloaded in ZIP or gzipped tar form: - http://common-lisp.net/project/armedbear/releases/abcl-src-0.17.0.tar.gz - http://common-lisp.net/project/armedbear/releases/abcl-src-0.17.0.zip + http://common-lisp.net/project/armedbear/releases/abcl-src-0.18.0.tar.gz + http://common-lisp.net/project/armedbear/releases/abcl-src-0.18.0.zip Signatures are available under: - http://common-lisp.net/project/armedbear/releases/abcl-src-0.17.0.tar.gz.asc - http://common-lisp.net/project/armedbear/releases/abcl-src-0.17.0.zip.asc + http://common-lisp.net/project/armedbear/releases/abcl-src-0.18.0.tar.gz.asc + http://common-lisp.net/project/armedbear/releases/abcl-src-0.18.0.zip.asc In addition, binaries are also available: - http://common-lisp.net/project/armedbear/releases/abcl-bin-0.17.0.tar.gz - http://common-lisp.net/project/armedbear/releases/abcl-bin-0.17.0.zip + http://common-lisp.net/project/armedbear/releases/abcl-bin-0.18.0.tar.gz + http://common-lisp.net/project/armedbear/releases/abcl-bin-0.18.0.zip With associated signatures: - http://common-lisp.net/project/armedbear/releases/abcl-bin-0.17.0.tar.gz.asc - http://common-lisp.net/project/armedbear/releases/abcl-bin-0.17.0.zip.asc + http://common-lisp.net/project/armedbear/releases/abcl-bin-0.18.0.tar.gz.asc + http://common-lisp.net/project/armedbear/releases/abcl-bin-0.18.0.zip.asc From ehuelsmann at common-lisp.net Wed Jan 13 19:55:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 13 Jan 2010 14:55:25 -0500 Subject: [armedbear-cvs] r12373 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 13 14:55:22 2010 New Revision: 12373 Log: Change parents of FUNDAMENTAL-STREAM in Gray streams. Note: includes experimental removal of override of TWO-WAY-STREAM. Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Modified: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp Wed Jan 13 14:55:22 2010 @@ -179,7 +179,7 @@ (or (xp::xp-structure-p stream) (funcall *old-streamp* stream))) -(defclass fundamental-stream ()) +(defclass fundamental-stream (standard-object stream)) (defgeneric gray-close (stream &key abort)) (defgeneric gray-open-stream-p (stream)) @@ -545,7 +545,8 @@ (funcall *old-read-sequence* sequence stream :start start :end end) (stream-read-sequence stream sequence start end))) -(defstruct two-way-stream-g +#| +(defstruct (two-way-stream-g (:include stream)) input-stream output-stream) (defun gray-make-two-way-stream (in out) @@ -563,6 +564,8 @@ (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) @@ -589,8 +592,11 @@ (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) From ehuelsmann at common-lisp.net Wed Jan 13 21:47:26 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 13 Jan 2010 16:47:26 -0500 Subject: [armedbear-cvs] r12374 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 13 16:47:23 2010 New Revision: 12374 Log: Simplify inspection of variables in (NetBeans) debugger by making symbols print readably. Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 13 16:47:23 2010 @@ -266,6 +266,11 @@ return sb.toString(); } + @Override + public String toString() { + return "(Symbol)" + getQualifiedName(); + } + /** Gets the value associated with the symbol * as set by SYMBOL-VALUE. * From ehuelsmann at common-lisp.net Wed Jan 13 22:01:15 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 13 Jan 2010 17:01:15 -0500 Subject: [armedbear-cvs] r12375 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 13 17:01:14 2010 New Revision: 12375 Log: Harmonize Symbol printing with what stream already does; same for packages. Modified: trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Package.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Package.java Wed Jan 13 17:01:14 2010 @@ -829,7 +829,13 @@ sb.append(name); sb.append("\")"); return sb.toString(); - } else if (name != null) { + } else + return toString(); + } + + @Override + public String toString() { + if (name != null) { FastStringBuffer sb = new FastStringBuffer("#"); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 13 17:01:14 2010 @@ -268,7 +268,7 @@ @Override public String toString() { - return "(Symbol)" + getQualifiedName(); + return getQualifiedName(); } /** Gets the value associated with the symbol From astalla at common-lisp.net Thu Jan 14 22:08:00 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 14 Jan 2010 17:08:00 -0500 Subject: [armedbear-cvs] r12376 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Jan 14 17:07:57 2010 New Revision: 12376 Log: Calling PRIN1-TO-STRING to print Lisp stack frames, so as to allow the standard printing settings to apply (e.g. custom PRINT-OBJECT methods). Modified: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Modified: trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispStackFrame.java Thu Jan 14 17:07:57 2010 @@ -119,8 +119,7 @@ String result = ""; final String LISP_STACK_FRAME = "LISP-STACK-FRAME"; try { - result = unreadableString(LISP_STACK_FRAME + " " - + toLispString().getStringValue()); + result = Symbol.PRIN1_TO_STRING.execute(this.toLispList()).writeToString(); } catch (Throwable t) { // error while printing stack Debug.trace("Serious printing error: "); Debug.trace(t); From astalla at common-lisp.net Fri Jan 15 20:36:45 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 15 Jan 2010 15:36:45 -0500 Subject: [armedbear-cvs] r12377 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 15 15:36:39 2010 New Revision: 12377 Log: Set the symbol for java-classes to the class name to allow to print them correctly. Modified: trunk/abcl/src/org/armedbear/lisp/JavaClass.java Modified: trunk/abcl/src/org/armedbear/lisp/JavaClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClass.java Fri Jan 15 15:36:39 2010 @@ -40,8 +40,9 @@ private static final Map, JavaClass> cache = new HashMap, JavaClass>(); private JavaClass(Class javaClass) { - this.javaClass = javaClass; - setDirectSuperclass(BuiltInClass.JAVA_OBJECT); + super(new Symbol(javaClass.getCanonicalName())); + this.javaClass = javaClass; + setDirectSuperclass(BuiltInClass.JAVA_OBJECT); } private void initCPL() { From ehuelsmann at common-lisp.net Fri Jan 15 20:40:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 15 Jan 2010 15:40:35 -0500 Subject: [armedbear-cvs] r12378 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 15 15:40:31 2010 New Revision: 12378 Log: Create a dependable reader dynamic environment. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Fri Jan 15 15:40:31 2010 @@ -81,6 +81,7 @@ return load(); } + final private synchronized Function load() { if (fun != null) return fun; @@ -91,6 +92,14 @@ for (int i = 0; i < symsToSave.length; i++) thread.bindSpecial(symsToSave[i], savedSyms[i]); + // set a specific reader environment, because we may be triggered in + // any undefined dynamic environment; we want something predictable + thread.bindSpecial(Symbol.READ_SUPPRESS, NIL); + thread.bindSpecial(Symbol.READ_EVAL, T); + thread.bindSpecial(Symbol.READ_BASE, LispInteger.getInstance(10)); + // don't need to bind *READ-DEFAULT-FLOAT-FORMAT*, + // because DUMP-FORM sets it to NIL, forcing exponent markers everywhere + byte[] classbytes = (byte[])((Hashtable)cache.javaInstance()).get(name); try { From astalla at common-lisp.net Fri Jan 15 20:51:23 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 15 Jan 2010 15:51:23 -0500 Subject: [armedbear-cvs] r12379 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri Jan 15 15:51:22 2010 New Revision: 12379 Log: Fixed print-object for JavaObjects to call writeToString() on the object. Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri Jan 15 15:51:22 2010 @@ -50,6 +50,9 @@ (format stream "~S" (class-name (class-of object)))) object) +(defmethod print-object ((obj java:java-object) stream) + (write-string (%write-to-string obj) stream)) + (defmethod print-object ((class java:java-class) stream) (write-string (%write-to-string class) stream)) From ehuelsmann at common-lisp.net Sat Jan 16 20:13:48 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 16 Jan 2010 15:13:48 -0500 Subject: [armedbear-cvs] r12380 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 16 15:13:42 2010 New Revision: 12380 Log: Add internal DEFSTRUCT administration to the STREAM and SYSTEM-STREAM types. Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java trunk/abcl/src/org/armedbear/lisp/boot.lisp Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java (original) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Sat Jan 16 15:13:42 2010 @@ -139,6 +139,12 @@ (StructureClass)addClass(Symbol.STRUCTURE_OBJECT, new StructureClass(Symbol.STRUCTURE_OBJECT, list(CLASS_T))); + /* All the stream classes below are being defined as structure classes + but won't be available as such until further action is taken: + the 'defstruct' internal administration is missing. + + For STREAM and SYSTEM-STREAM, that bit is added in boot.lisp */ + public static final LispClass STREAM = addClass(Symbol.STREAM, new StructureClass(Symbol.STREAM, list(STRUCTURE_OBJECT))); Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/boot.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Sat Jan 16 15:13:42 2010 @@ -171,6 +171,18 @@ (load-system-file "require") (load-system-file "defstruct") + +;; The actual stream and system-stream classes +;; are created in BuiltInClass.java, however, that code does not +;; set up the structure internals correctly: we wouldn't be able +;; to :include the structure classes. Fix that here. +(defstruct (stream (:constructor nil) + (:copier nil) + (:predicate nil))) ;; Predicate STREAMP defined elsewhere +(defstruct (system-stream (:include stream) + (:constructor nil) + (:copier nil))) + (load-system-file "restart") (load-system-file "late-setf") (load-system-file "debug") From ehuelsmann at common-lisp.net Sun Jan 17 14:36:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Jan 2010 09:36:43 -0500 Subject: [armedbear-cvs] r12381 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 17 09:36:36 2010 New Revision: 12381 Log: Support disassembly of proxied functions. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sun Jan 17 09:36:36 2010 @@ -284,7 +284,8 @@ fun = new AutoloadedFunctionProxy(sym, name, cache, cachedSyms, fType); - + fun.setClassBytes((byte[])((Hashtable)cache.javaInstance()) + .get(name.getStringValue())); } return fun; From vvoutilainen at common-lisp.net Sun Jan 17 20:53:24 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 17 Jan 2010 15:53:24 -0500 Subject: [armedbear-cvs] r12382 - branches/0.18.x/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Jan 17 15:53:21 2010 New Revision: 12382 Log: Backport r12376-r12379 and r12381. This fixes maxima, adds support for disassembling proxied functions, and adds fixes to printing java objects. Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java branches/0.18.x/abcl/src/org/armedbear/lisp/JavaClass.java branches/0.18.x/abcl/src/org/armedbear/lisp/LispStackFrame.java branches/0.18.x/abcl/src/org/armedbear/lisp/print-object.lisp Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sun Jan 17 15:53:21 2010 @@ -81,6 +81,7 @@ return load(); } + final private synchronized Function load() { if (fun != null) return fun; @@ -91,6 +92,14 @@ for (int i = 0; i < symsToSave.length; i++) thread.bindSpecial(symsToSave[i], savedSyms[i]); + // set a specific reader environment, because we may be triggered in + // any undefined dynamic environment; we want something predictable + thread.bindSpecial(Symbol.READ_SUPPRESS, NIL); + thread.bindSpecial(Symbol.READ_EVAL, T); + thread.bindSpecial(Symbol.READ_BASE, LispInteger.getInstance(10)); + // don't need to bind *READ-DEFAULT-FLOAT-FORMAT*, + // because DUMP-FORM sets it to NIL, forcing exponent markers everywhere + byte[] classbytes = (byte[])((Hashtable)cache.javaInstance()).get(name); try { @@ -275,7 +284,8 @@ fun = new AutoloadedFunctionProxy(sym, name, cache, cachedSyms, fType); - + fun.setClassBytes((byte[])((Hashtable)cache.javaInstance()) + .get(name.getStringValue())); } return fun; Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/JavaClass.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/JavaClass.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/JavaClass.java Sun Jan 17 15:53:21 2010 @@ -40,8 +40,9 @@ private static final Map, JavaClass> cache = new HashMap, JavaClass>(); private JavaClass(Class javaClass) { - this.javaClass = javaClass; - setDirectSuperclass(BuiltInClass.JAVA_OBJECT); + super(new Symbol(javaClass.getCanonicalName())); + this.javaClass = javaClass; + setDirectSuperclass(BuiltInClass.JAVA_OBJECT); } private void initCPL() { Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/LispStackFrame.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/LispStackFrame.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/LispStackFrame.java Sun Jan 17 15:53:21 2010 @@ -119,8 +119,7 @@ String result = ""; final String LISP_STACK_FRAME = "LISP-STACK-FRAME"; try { - result = unreadableString(LISP_STACK_FRAME + " " - + toLispString().getStringValue()); + result = Symbol.PRIN1_TO_STRING.execute(this.toLispList()).writeToString(); } catch (Throwable t) { // error while printing stack Debug.trace("Serious printing error: "); Debug.trace(t); Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/print-object.lisp (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/print-object.lisp Sun Jan 17 15:53:21 2010 @@ -50,6 +50,9 @@ (format stream "~S" (class-name (class-of object)))) object) +(defmethod print-object ((obj java:java-object) stream) + (write-string (%write-to-string obj) stream)) + (defmethod print-object ((class java:java-class) stream) (write-string (%write-to-string class) stream)) From vvoutilainen at common-lisp.net Sun Jan 17 21:04:51 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 17 Jan 2010 16:04:51 -0500 Subject: [armedbear-cvs] r12383 - trunk/abcl Message-ID: Author: vvoutilainen Date: Sun Jan 17 16:04:51 2010 New Revision: 12383 Log: Changelogs for the newest releases. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun Jan 17 16:04:51 2010 @@ -1,5 +1,21 @@ +Version 0.18.1 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.18.1/abcl +(17 Jan, 2010) + +Features: + + * Support for printing java objects with print-object + * Support for disassembling proxied functions + +Bugs fixed: + + * maxima works again + Version 0.18.0 ============== +svn://common-lisp.net/project/armedbear/svn/tags/0.18.0/abcl +(12 Jan, 2010) Features: From vvoutilainen at common-lisp.net Sun Jan 17 21:06:15 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 17 Jan 2010 16:06:15 -0500 Subject: [armedbear-cvs] r12384 - branches/0.18.x/abcl Message-ID: Author: vvoutilainen Date: Sun Jan 17 16:06:15 2010 New Revision: 12384 Log: Backport the CHANGES file to the release branch. Modified: branches/0.18.x/abcl/CHANGES Modified: branches/0.18.x/abcl/CHANGES ============================================================================== --- branches/0.18.x/abcl/CHANGES (original) +++ branches/0.18.x/abcl/CHANGES Sun Jan 17 16:06:15 2010 @@ -1,5 +1,21 @@ +Version 0.18.1 +============== +svn://common-lisp.net/project/armedbear/svn/tags/0.18.1/abcl +(17 Jan, 2010) + +Features: + + * Support for printing java objects with print-object + * Support for disassembling proxied functions + +Bugs fixed: + + * maxima works again + Version 0.18.0 ============== +svn://common-lisp.net/project/armedbear/svn/tags/0.18.0/abcl +(12 Jan, 2010) Features: From ehuelsmann at common-lisp.net Sun Jan 17 21:12:25 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Jan 2010 16:12:25 -0500 Subject: [armedbear-cvs] r12385 - in tags/0.18.1: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 17 16:12:23 2010 New Revision: 12385 Log: Tag 0.18.1. Added: tags/0.18.1/ - copied from r12384, /branches/0.18.x/ Modified: tags/0.18.1/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.18.1/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.18.1/abcl/src/org/armedbear/lisp/Version.java Sun Jan 17 16:12:23 2010 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.18.0-dev"; + return "0.18.1"; } } From ehuelsmann at common-lisp.net Sun Jan 17 21:15:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Jan 2010 16:15:57 -0500 Subject: [armedbear-cvs] r12386 - branches/0.18.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 17 16:15:56 2010 New Revision: 12386 Log: Update development (branch) version. Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.18.x/abcl/src/org/armedbear/lisp/Version.java Sun Jan 17 16:15:56 2010 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.18.0-dev"; + return "0.18.2-dev"; } } From ehuelsmann at common-lisp.net Sun Jan 17 22:18:50 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Jan 2010 17:18:50 -0500 Subject: [armedbear-cvs] r12387 - public_html/releases Message-ID: Author: ehuelsmann Date: Sun Jan 17 17:18:42 2010 New Revision: 12387 Log: Add 0.18.1 release archives. Added: public_html/releases/abcl-bin-0.18.1.tar.gz (contents, props changed) public_html/releases/abcl-bin-0.18.1.zip (contents, props changed) public_html/releases/abcl-src-0.18.1.tar.gz (contents, props changed) public_html/releases/abcl-src-0.18.1.zip (contents, props changed) Added: public_html/releases/abcl-bin-0.18.1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.18.1.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.18.1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.18.1.zip ============================================================================== Binary file. No diff available. From ehuelsmann at common-lisp.net Sun Jan 17 22:44:27 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Jan 2010 17:44:27 -0500 Subject: [armedbear-cvs] r12388 - public_html/releases Message-ID: Author: ehuelsmann Date: Sun Jan 17 17:44:24 2010 New Revision: 12388 Log: Add 0.18.1 release signature files. Added: public_html/releases/abcl-bin-0.18.1.tar.gz.asc public_html/releases/abcl-bin-0.18.1.zip.asc public_html/releases/abcl-src-0.18.1.tar.gz.asc public_html/releases/abcl-src-0.18.1.zip.asc Added: public_html/releases/abcl-bin-0.18.1.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.18.1.tar.gz.asc Sun Jan 17 17:44:24 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktTj24ACgkQi5O0Epaz9TmrXgCfey9o5dXnp0hJcvZOWLRqiTIf +YQEAnjZfx7DkvnO/JcOUKQaK1PCrqleT +=pial +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-bin-0.18.1.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.18.1.zip.asc Sun Jan 17 17:44:24 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktTj3gACgkQi5O0Epaz9TnXTQCePcABF5ULtGMpGKmBDcTE87ei +eSkAn1KvA9sxlpowwl7DPpmIniV4WL78 +=b/XY +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.18.1.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.18.1.tar.gz.asc Sun Jan 17 17:44:24 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktTj4YACgkQi5O0Epaz9Tla6ACeMrU0c7OOUWiWoS18DGK6Q2Qf +00IAn1jMzJZl7lQabArlYrpXdRp7V9BT +=ObNp +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.18.1.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.18.1.zip.asc Sun Jan 17 17:44:24 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAktTj4wACgkQi5O0Epaz9Tn2wgCdHdUih7tMbgFoBvYyBMHjlXW2 +WhYAnjdUdVj301IIbUlPoQ90Jq5pVR7G +=UrSv +-----END PGP SIGNATURE----- From ehuelsmann at common-lisp.net Sun Jan 17 22:46:03 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 17 Jan 2010 17:46:03 -0500 Subject: [armedbear-cvs] r12389 - public_html Message-ID: Author: ehuelsmann Date: Sun Jan 17 17:46:02 2010 New Revision: 12389 Log: Update website with release 0.18.1. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Jan 17 17:46:02 2010 @@ -32,9 +32,9 @@ using Java to Lisp integration APIs. -Download 0.18.0 +Download 0.18.1 (zip) Users From astalla at common-lisp.net Mon Jan 18 19:07:27 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 18 Jan 2010 14:07:27 -0500 Subject: [armedbear-cvs] r12390 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jan 18 14:07:21 2010 New Revision: 12390 Log: Changed output-ugly-object to invoke print-object for Java objects, as suggested by Alan Ruttenberg. Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp Modified: trunk/abcl/src/org/armedbear/lisp/print.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/print.lisp Mon Jan 18 14:07:21 2010 @@ -142,6 +142,8 @@ (print-object object stream)))) ((standard-object-p object) (print-object object stream)) + ((java::java-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)))) From ehuelsmann at common-lisp.net Mon Jan 18 20:12:37 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 18 Jan 2010 15:12:37 -0500 Subject: [armedbear-cvs] r12391 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 18 15:12:34 2010 New Revision: 12391 Log: Prevent duplicate subclasses: only push new classes not already present in the list. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jan 18 15:12:34 2010 @@ -520,7 +520,7 @@ (list (find-class 'standard-object))))) (setf (class-direct-superclasses class) supers) (dolist (superclass supers) - (push class (class-direct-subclasses superclass)))) + (pushnew class (class-direct-subclasses superclass)))) (let ((slots (mapcar #'(lambda (slot-properties) (apply #'make-direct-slot-definition class slot-properties)) direct-slots))) From ehuelsmann at common-lisp.net Sat Jan 23 09:26:27 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 Jan 2010 04:26:27 -0500 Subject: [armedbear-cvs] r12392 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 23 04:26:24 2010 New Revision: 12392 Log: Move a constant definition from boot.lisp to Java, as the precedent seems to be we have constants defined in Java. Also remove an unused function from boot.lisp. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/boot.lisp 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 Sat Jan 23 04:26:24 2010 @@ -2610,6 +2610,19 @@ Symbol.INTERNAL_TIME_UNITS_PER_SECOND.initializeConstant(Fixnum.getInstance(1000)); } + static + { + Symbol.LAMBDA_LIST_KEYWORDS + .initializeConstant(list(Symbol.AND_OPTIONAL, + Symbol.AND_REST, + Symbol.AND_KEY, + Symbol.AND_AUX, + Symbol.AND_BODY, + Symbol.AND_WHOLE, + Symbol.AND_ALLOW_OTHER_KEYS, + Symbol.AND_ENVIRONMENT)); + } + // ### call-registers-limit public static final Symbol CALL_REGISTERS_LIMIT = exportConstant("CALL-REGISTERS-LIMIT", PACKAGE_SYS, Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/boot.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Sat Jan 23 04:26:24 2010 @@ -165,10 +165,6 @@ (load-system-file "error") (load-system-file "defpackage") (load-system-file "define-modify-macro") - -(defconstant lambda-list-keywords - '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)) - (load-system-file "require") (load-system-file "defstruct") @@ -191,12 +187,6 @@ (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) (unless *noinform* (%format t "Startup completed in ~A seconds.~%" From ehuelsmann at common-lisp.net Sat Jan 23 09:27:35 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 Jan 2010 04:27:35 -0500 Subject: [armedbear-cvs] r12393 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 23 04:27:34 2010 New Revision: 12393 Log: Tell the compiler about some functions which don't require clearing the VALUES array. Modified: trunk/abcl/src/org/armedbear/lisp/known-functions.lisp Modified: trunk/abcl/src/org/armedbear/lisp/known-functions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/known-functions.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/known-functions.lisp Sat Jan 23 04:27:34 2010 @@ -223,6 +223,9 @@ numerator denominator boole array-dimension + array-row-major-index + array-rank + array-total-size %dpb ash) * integer) From ehuelsmann at common-lisp.net Sat Jan 23 13:40:39 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 23 Jan 2010 08:40:39 -0500 Subject: [armedbear-cvs] r12394 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 23 08:40:34 2010 New Revision: 12394 Log: Remove premature optimization: new array creation is faster than field access; at the same time, don't create too many new arrays. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java 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 Sat Jan 23 08:40:34 2010 @@ -54,15 +54,10 @@ 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 Parameter[] requiredParameters = new Parameter[0]; + private Parameter[] optionalParameters = requiredParameters; + private Parameter[] keywordParameters = requiredParameters; + private Parameter[] auxVars = requiredParameters; private final LispObject body; private final LispObject executionBody; private final Environment environment; @@ -75,12 +70,7 @@ private int minArgs; private int maxArgs; - private static final Symbol[] emptySymbolArray; - static - { - emptySymbolArray = new Symbol[0]; - } - private Symbol[] variables = emptySymbolArray; + private Symbol[] variables = new Symbol[0]; private LispObject specials = NIL; private boolean bindInitForms; From vvoutilainen at common-lisp.net Sun Jan 24 15:24:21 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 Jan 2010 10:24:21 -0500 Subject: [armedbear-cvs] r12395 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: vvoutilainen Date: Sun Jan 24 10:24:18 2010 New Revision: 12395 Log: Some patches to improve arglist display in Slime. Patch by Matthias H?lzl. Added: trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp trunk/abcl/test/lisp/abcl/mop-tests.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/test/lisp/abcl/package.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sun Jan 24 10:24:18 2010 @@ -207,8 +207,12 @@ (autoload 'disassemble) (in-package "MOP") -(export '(class-precedence-list class-slots slot-definition-name)) -(autoload '(class-precedence-list class-slots slot-definition-name) "clos") +(export '(class-precedence-list class-slots slot-definition-allocation + slot-definition-initargs slot-definition-initform + slot-definition-initfunction slot-definition-name + compute-applicable-methods + compute-applicable-methods-using-classes)) +(autoload '(class-precedence-list class-slots) "clos") ;; Java interface. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 24 10:24:18 2010 @@ -51,14 +51,11 @@ (in-package #:mop) -(export '(class-precedence-list class-slots slot-definition-name)) +(export '(class-precedence-list class-slots)) (defun class-slots (class) (%class-slots class)) -(defun slot-definition-name (slot-definition) - (%slot-definition-name slot-definition)) - (defmacro push-on-end (value location) `(setf ,location (nconc ,location (list ,value)))) @@ -1318,6 +1315,17 @@ code)) +(defun sort-methods (methods gf required-classes) + (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 (method args) (do* ((specializers (%method-specializers method) (cdr specializers)) (args args (cdr args))) @@ -1335,23 +1343,31 @@ (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))))))) + (sort-methods methods gf required-classes))) -(defun method-applicable-p-using-classes (method classes) +;;; METHOD-APPLICABLE-USING-CLASSES-P +;;; +;;; If the first return value is T, METHOD is definitely applicable to +;;; arguments that are instances of CLASSES. If the first value is +;;; NIL and the second value is T, METHOD is definitely not applicable +;;; to arguments that are instances of CLASSES; if the second value is +;;; NIL the applicability of METHOD cannot be determined by inspecting +;;; the classes of its arguments only. +;;; +(defun method-applicable-using-classes-p (method classes) (do* ((specializers (%method-specializers method) (cdr specializers)) - (classes classes (cdr classes))) - ((null specializers) t) + (classes classes (cdr classes)) + (knownp t)) + ((null specializers) + (if knownp (values t t) (values nil nil))) (let ((specializer (car specializers))) - (unless (subclassp (car classes) specializer) - (return nil))))) + (if (typep specializer 'eql-specializer) + (if (eql (class-of (eql-specializer-object specializer)) + (car classes)) + (setf knownp nil) + (return (values nil t))) + (unless (subclassp (car classes) specializer) + (return (values nil t))))))) (defun slow-method-lookup (gf args) (let ((applicable-methods (%compute-applicable-methods gf args))) @@ -1879,6 +1895,30 @@ (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) (%set-documentation x doc-type new-value)) +;;; Applicable methods + +(defgeneric compute-applicable-methods (gf args) + (:method ((gf standard-generic-function) args) + (%compute-applicable-methods gf args))) + +(defgeneric compute-applicable-methods-using-classes (gf classes) + (:method ((gf standard-generic-function) classes) + (let ((methods '())) + (dolist (method (generic-function-methods gf)) + (multiple-value-bind (applicable knownp) + (method-applicable-using-classes-p method classes) + (cond (applicable + (push method methods)) + ((not knownp) + (return-from compute-applicable-methods-using-classes + (values nil nil)))))) + (values (sort-methods methods gf classes) + t)))) + +(export '(compute-applicable-methods + compute-applicable-methods-using-classes)) + + ;;; Slot access (defun set-slot-value-using-class (new-value class instance slot-name) @@ -2197,6 +2237,37 @@ (defmethod compute-applicable-methods ((gf standard-generic-function) args) (%compute-applicable-methods gf args)) +;;; Slot definition accessors + +(export '(slot-definition-allocation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name)) + +(defgeneric slot-definition-allocation (slot-definition) + (:method ((slot-definition slot-definition)) + (%slot-definition-allocation slot-definition))) + +(defgeneric slot-definition-initargs (slot-definition) + (:method ((slot-definition slot-definition)) + (%slot-definition-initargs slot-definition))) + +(defgeneric slot-definition-initform (slot-definition) + (:method ((slot-definition slot-definition)) + (%slot-definition-initform slot-definition))) + +(defgeneric slot-definition-initfunction (slot-definition) + (:method ((slot-definition slot-definition)) + (%slot-definition-initfunction slot-definition))) + +(defgeneric slot-definition-name (slot-definition) + (:method ((slot-definition slot-definition)) + (%slot-definition-name slot-definition))) + +;;; No %slot-definition-type. + + ;;; Conditions. (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) Added: trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp Sun Jan 24 10:24:18 2010 @@ -0,0 +1,82 @@ +;;; mop-tests-setup.lisp +;;; +;;; Copyright (C) 2010 Matthias H?lzl +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +;;; Definitions used by mop-tests.lisp. Split into a separate file to +;;; avoid problems with the functions not being available during test +;;; runs. + +(in-package #:abcl.test.lisp) + +(defun find-classes (&rest args) + (mapcar #'find-class args)) + +(defgeneric mop-test.foo (x y) + (:method (x y) + (list :object x :object y)) + (:method ((x fixnum) y) + (list :fixnum x :object y)) + (:method ((x fixnum) (y fixnum)) + (list :fixnum x :fixnum y))) + +(defun find-foo (&rest specializers) + (find-method #'mop-test.foo nil + (mapcar #'find-class specializers))) + +(defgeneric mop-test.bar (x y) + (:method (x y) + (list :object x :object y)) + (:method ((x fixnum) y) + (list :fixnum x :object y)) + (:method ((x fixnum) (y fixnum)) + (list :fixnum x :fixnum y)) + (:method ((x fixnum) (y string)) + (list :fixnum x :fixnum y)) + (:method ((x fixnum) (y (eql 123))) + (list :fixnum x :123 y))) + +(defun find-bar (&rest specializers) + (find-method #'mop-test.bar nil + (mapcar #'find-class specializers))) + +(defgeneric mop-test.baz (x y) + (:method (x y) + (list :object x :object y)) + (:method ((x fixnum) y) + (list :fixnum x :object y)) + (:method ((x fixnum) (y fixnum)) + (list :fixnum x :fixnum y)) + (:method ((x (eql 234)) (y fixnum)) + (list :234 x :fixnum y))) + +(defun find-baz (&rest specializers) + (find-method #'mop-test.baz nil + (mapcar #'find-class specializers))) + +(defgeneric mop-test.quux (x y) + (:method (x y) + (list :object x :object y)) + (:method ((x fixnum) y) + (list :fixnum x :object y)) + (:method ((x fixnum) (y fixnum)) + (list :fixnum x :fixnum y)) + (:method ((x (eql :foo)) (y fixnum)) + (list :foo x :fixnum y))) + +(defun find-quux (&rest specializers) + (find-method #'mop-test.quux nil + (mapcar #'find-class specializers))) Added: trunk/abcl/test/lisp/abcl/mop-tests.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Sun Jan 24 10:24:18 2010 @@ -0,0 +1,307 @@ +;;; mop-tests.lisp +;;; +;;; Copyright (C) 2010 Matthias H?lzl +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + + +(load (merge-pathnames "test-utilities.lisp" *load-truename*)) +(compile-file (merge-pathnames "mop-tests-setup.lisp" *load-truename*)) +(load (merge-pathnames "mop-tests-setup" *load-truename*)) + +(in-package #:abcl.test.lisp) + +(deftest compute-applicable-methods.foo.1 + (equalp + (mop:compute-applicable-methods #'mop-test.foo '(111 222)) + (mop:compute-applicable-methods-using-classes + #'mop-test.foo (find-classes 'fixnum 'fixnum))) + t) + +(deftest compute-applicable-methods.foo.2 + (equalp + (mop:compute-applicable-methods #'mop-test.foo '(x y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.foo (find-classes 'symbol 'symbol))) + t) + +(deftest compute-applicable-methods.foo.3 + (equalp + (mop:compute-applicable-methods #'mop-test.foo '(111 y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.foo (find-classes 'fixnum 'symbol))) + t) + +(deftest compute-applicable-methods.foo.4 + (equalp + (mop:compute-applicable-methods #'mop-test.foo '(x 111)) + (mop:compute-applicable-methods-using-classes + #'mop-test.foo (find-classes 'symbol 'fixnum))) + t) + +(deftest compute-applicable-methods.foo.5 + (equalp + (mop:compute-applicable-methods #'mop-test.foo '(111 "asdf")) + (mop:compute-applicable-methods-using-classes + #'mop-test.foo (find-classes 'fixnum 'simple-base-string))) + t) + +(deftest compute-applicable-methods.foo.6 + (equalp (mop:compute-applicable-methods #'mop-test.foo '(111 222)) + (list (find-foo 'fixnum 'fixnum) + (find-foo 'fixnum t) + (find-foo t t))) + t) + +(deftest compute-applicable-methods.foo.7 + (equalp (mop:compute-applicable-methods #'mop-test.foo '(111 x)) + (list (find-foo 'fixnum t) + (find-foo t t))) + t) + +(deftest compute-applicable-methods.foo.8 + (equalp (mop:compute-applicable-methods #'mop-test.foo '(x 222)) + (list (find-foo t t))) + t) + + +(deftest compute-applicable-methods.bar.1 + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 222)) + (mop:compute-applicable-methods-using-classes + #'mop-test.bar (find-classes 'fixnum 'fixnum))) + ;;; Bar with two fixnums might select EQL specializer for second + ;;; argument. + nil) + +(deftest compute-applicable-methods.bar.1a + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 222)) + (list (find-bar 'fixnum 'fixnum) + (find-bar 'fixnum t) + (find-bar t t))) + t) + +(deftest compute-applicable-methods.bar.1b + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 123)) + (list (find-method #'mop-test.bar nil (list (find-class 'fixnum) '(eql 123))) + (find-bar 'fixnum 'fixnum) + (find-bar 'fixnum t) + (find-bar t t))) + t) + +(deftest compute-applicable-methods.bar.1c + (mop:compute-applicable-methods-using-classes + #'mop-test.bar (find-classes 'fixnum 'fixnum)) + nil + nil) + +(deftest compute-applicable-methods.bar.2 + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(x y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.bar (find-classes 'symbol 'symbol))) + t) + +(deftest compute-applicable-methods.bar.2a + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(x y)) + (list (find-bar t t))) + t) + +(deftest compute-applicable-methods.bar.3 + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.bar (find-classes 'fixnum 'symbol))) + t) + +(deftest compute-applicable-methods.bar.3a + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 y)) + (list (find-bar 'fixnum t) + (find-bar t t))) + t) + +(deftest compute-applicable-methods.bar.4 + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(x 111)) + (mop:compute-applicable-methods-using-classes + #'mop-test.bar (find-classes 'symbol 'fixnum))) + t) + +(deftest compute-applicable-methods.bar.4a + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(x 111)) + (list (find-bar t t))) + t) + +(deftest compute-applicable-methods.bar.5 + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 "asdf")) + (mop:compute-applicable-methods-using-classes + #'mop-test.bar (find-classes 'fixnum 'simple-base-string))) + t) + +(deftest compute-applicable-methods.bar.5a + (equalp + (mop:compute-applicable-methods #'mop-test.bar '(111 "asdf")) + (list (find-bar 'fixnum 'string) + (find-bar 'fixnum t) + (find-bar t t))) + t) + + +(deftest compute-applicable-methods.baz.1 + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(111 222)) + (mop:compute-applicable-methods-using-classes + #'mop-test.baz (find-classes 'fixnum 'fixnum))) + ;; Two fixnum arguments might select EQL specializer for first + ;; argument. + nil) + +(deftest compute-applicable-methods.baz.1a + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(111 222)) + (list (find-baz 'fixnum 'fixnum) + (find-baz 'fixnum t) + (find-baz t t))) + t) + +(deftest compute-applicable-methods.baz.1b + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(234 222)) + (list (find-method #'mop-test.baz nil (list '(eql 234) (find-class 'fixnum))) + (find-baz 'fixnum 'fixnum) + (find-baz 'fixnum t) + (find-baz t t))) + t) + +(deftest compute-applicable-methods.baz.1c + (mop:compute-applicable-methods-using-classes + #'mop-test.baz (find-classes 'fixnum 'fixnum)) + nil + nil) + +(deftest compute-applicable-methods.baz.2 + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(x y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.baz (find-classes 'symbol 'symbol))) + t) + +(deftest compute-applicable-methods.baz.3 + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(111 y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.baz (find-classes 'fixnum 'symbol))) + t) + +(deftest compute-applicable-methods.baz.4 + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(x 111)) + (mop:compute-applicable-methods-using-classes + #'mop-test.baz (find-classes 'symbol 'fixnum))) + t) + +(deftest compute-applicable-methods.baz.5 + (equalp + (mop:compute-applicable-methods #'mop-test.baz '(111 "asdf")) + (mop:compute-applicable-methods-using-classes + #'mop-test.baz (find-classes 'fixnum 'simple-base-string))) + t) + + +(deftest compute-applicable-methods.quux.1 + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(111 222)) + (mop:compute-applicable-methods-using-classes + #'mop-test.quux (find-classes 'fixnum 'fixnum))) + t) + +(deftest compute-applicable-methods.quux.1a + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(111 222)) + (list (find-quux 'fixnum 'fixnum) + (find-quux 'fixnum t) + (find-quux t t))) + t) + +(deftest compute-applicable-methods.quux.2 + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(x y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.quux (find-classes 'symbol 'symbol))) + t) + +(deftest compute-applicable-methods.quux.2a + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(x y)) + (list (find-quux t t))) + t) + +(deftest compute-applicable-methods.quux.3 + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(111 y)) + (mop:compute-applicable-methods-using-classes + #'mop-test.quux (find-classes 'fixnum 'symbol))) + t) + +(deftest compute-applicable-methods.quux.3a + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(111 y)) + (list (find-quux 'fixnum t) + (find-quux t t))) + t) + +(deftest compute-applicable-methods.quux.4 + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(x 111)) + (mop:compute-applicable-methods-using-classes + #'mop-test.quux (find-classes 'symbol 'fixnum))) + ;; Symbol/fixnum might trigger EQL spezializer + nil) + +(deftest compute-applicable-methods.quux.4a + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(x 111)) + (list (find-quux t t))) + t) + +(deftest compute-applicable-methods.quux.4b + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(:foo 111)) + (list (find-method #'mop-test.quux nil + (list '(eql :foo) (find-class 'fixnum))) + + (find-quux t t))) + t) + +(deftest compute-applicable-methods.quux.4c + (mop:compute-applicable-methods-using-classes + #'mop-test.quux (find-classes 'symbol 'fixnum)) + nil + nil) + +(deftest compute-applicable-methods.quux.5 + (equalp + (mop:compute-applicable-methods #'mop-test.quux '(111 "asdf")) + (mop:compute-applicable-methods-using-classes + #'mop-test.quux (find-classes 'fixnum 'simple-base-string))) + t) + + Modified: trunk/abcl/test/lisp/abcl/package.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package.lisp (original) +++ trunk/abcl/test/lisp/abcl/package.lisp Sun Jan 24 10:24:18 2010 @@ -18,6 +18,7 @@ (load "compiler-tests.lisp") (load "condition-tests.lisp") + (load "mop-tests.lisp") (load "file-system-tests.lisp") (load "java-tests.lisp") (load "math-tests.lisp") From ehuelsmann at common-lisp.net Sun Jan 24 18:29:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 Jan 2010 13:29:43 -0500 Subject: [armedbear-cvs] r12396 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 24 13:29:41 2010 New Revision: 12396 Log: Update trunk development version to 0.19. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Sun Jan 24 13:29:41 2010 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.18.0-dev"; + return "0.19.0-dev"; } } From vvoutilainen at common-lisp.net Sun Jan 24 21:41:29 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 24 Jan 2010 16:41:29 -0500 Subject: [armedbear-cvs] r12397 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Jan 24 16:41:26 2010 New Revision: 12397 Log: Fix MAKE-BROADCAST-STREAM.8. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java 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 Sun Jan 24 16:41:26 2010 @@ -107,7 +107,7 @@ protected EolStyle eolStyle = platformEolStyle; protected char eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; - protected LispObject externalFormat = NIL; + protected LispObject externalFormat = keywordDefault; protected String encoding = null; protected char lastChar = 0; From ehuelsmann at common-lisp.net Sun Jan 24 21:59:57 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 Jan 2010 16:59:57 -0500 Subject: [armedbear-cvs] r12398 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 24 16:59:56 2010 New Revision: 12398 Log: Move lambda-list analysis from runtime to compile time for compiled functions. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp 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 Sun Jan 24 16:59:56 2010 @@ -41,11 +41,11 @@ 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; + public static final int REQUIRED = 0; + public static final int OPTIONAL = 1; + public static final int KEYWORD = 2; + public static final int REST = 3; + public static final int AUX = 4; // States. private static final int STATE_REQUIRED = 0; @@ -75,8 +75,50 @@ private boolean bindInitForms; - public Closure(LispObject lambdaExpression, Environment env) + /** Construct a closure object with a lambda-list described + * by these parameters. + * + * + * @param required Required parameters or an empty array for none + * @param optional Optional parameters or an empty array for none + * @param keyword Keyword parameters or an empty array for none + * @param keys NIL if the lambda-list doesn't contain &key, T otherwise + * @param rest the &rest parameter, or NIL if none + * @param moreKeys NIL if &allow-other-keys not present, T otherwise + */ + public Closure(Parameter[] required, + Parameter[] optional, + Parameter[] keyword, + Symbol keys, Symbol rest, Symbol moreKeys) { + minArgs = required.length; + maxArgs = (rest == NIL && moreKeys == NIL) + ? minArgs + optional.length + 2*keyword.length : -1; + + arity = (rest == NIL && moreKeys == NIL && keys == NIL + && optional.length == 0) + ? maxArgs : -1; + + requiredParameters = required; + optionalParameters = optional; + keywordParameters = keyword; + + if (rest != NIL) + restVar = rest; + + andKey = keys != NIL; + allowOtherKeys = moreKeys != NIL; + variables = processVariables(); + bindInitForms = false; + + // stuff we don't need: we're a compiled function + body = null; + executionBody = null; + environment = null; + } + + + public Closure(LispObject lambdaExpression, Environment env) { this(null, lambdaExpression, env); } @@ -982,7 +1024,7 @@ } } - private static class Parameter + public static class Parameter { private final Symbol var; private final LispObject initForm; Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sun Jan 24 16:59:56 2010 @@ -41,8 +41,16 @@ public ClosureBinding[] ctx; - public CompiledClosure(LispObject lambdaList) + public CompiledClosure(Parameter[] required, + Parameter[] optional, + Parameter[] keyword, + Symbol keys, Symbol rest, Symbol moreKeys) + { + super(required, optional, keyword, keys, rest, moreKeys); + } + + public CompiledClosure(LispObject lambdaList) { super(list(Symbol.LAMBDA, lambdaList), null); } Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Jan 24 16:59:56 2010 @@ -58,6 +58,87 @@ ;;; Pass 1. +(defun parse-lambda-list (lambda-list) + "Breaks the lambda list into the different elements, returning the values + + required-vars + optional-vars + key-vars + key-p + rest-var + allow-other-keys-p + aux-vars + whole-var + env-var + +where each of the vars returned is a list with these elements: + + var - the actual variable name + initform - the init form if applicable; optional, keyword and aux vars + p-var - variable indicating presence + keyword - the keyword argument to match against + +" + (let ((state :req) + req opt key rest whole env aux key-p allow-others-p) + (dolist (arg lambda-list) + (case arg + (&optional (setf state :opt)) + (&key (setf state :key + key-p t)) + (&rest (setf state :rest)) + (&aux (setf state :aux)) + (&allow-other-keys (setf state :none + allow-others-p t)) + (&whole (setf state :whole)) + (&environment (setf state :env)) + (t + (case state + (:req (push arg req)) + (:rest (setf rest (list arg) + state :none)) + (:env (setf env (list arg) + state :req)) + (:whole (setf whole (list arg) + state :req)) + (:none + (error "Invalid lambda list: argument found in :none state.")) + (:opt + (cond + ((symbolp arg) + (push (list arg nil nil nil) opt)) + ((consp arg) + (push (list (car arg) (cadr arg) (caddr arg)) opt)) + (t + (error "Invalid state.")))) + (:aux + (cond + ((symbolp arg) + (push (list arg nil nil nil) aux)) + ((consp arg) + (push (list (car arg) (cadr arg) nil nil) aux)) + (t + (error "Invalid :aux state.")))) + (:key + (cond + ((symbolp arg) + (push (list arg nil nil (sys::keywordify arg)) key)) + ((and (consp arg) + (consp (car arg))) + (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key)) + ((consp arg) + (push (list (car arg) (cadr arg) (caddr arg) + (sys::keywordify (car arg))) key)) + (t + (error "Invalid :key state.")))) + (t (error "Invalid state found.")))))) + (values + (nreverse req) + (nreverse opt) + (nreverse key) + key-p + rest allow-others-p + (nreverse aux) whole env))) ;; Returns a list of declared free specials, if any are found. (declaim (ftype (function (list list block-node) list) 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 Jan 24 16:59:56 2010 @@ -253,6 +253,9 @@ (defconstant +lisp-package-class+ "org/armedbear/lisp/Package") (defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable") (defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream") +(defconstant +lisp-closure-class+ "org/armedbear/lisp/Closure") +(defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter") +(defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;") (defstruct (instruction (:constructor %make-instruction (opcode args))) (opcode 0 :type (integer 0 255)) @@ -1816,22 +1819,144 @@ (list +java-string+) +lisp-object+)) (emit-push-nil))) +(defun emit-read-from-string (object) + (emit-constructor-lambda-list object)) + (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")) + req-params-register + opt-params-register + key-params-register + rest-p + keys-p + more-keys-p (*code* ()) (*handlers* nil)) (setf (method-max-locals constructor) 1) + (unless (equal super +lisp-primitive-class+) + (multiple-value-bind + (req opt key key-p rest + allow-other-keys-p) + (parse-lambda-list args) + (setf rest-p rest + more-keys-p allow-other-keys-p + keys-p key-p) + (when t + ;; process required args + (emit-push-constant-int (length req)) + (emit 'anewarray +lisp-closure-parameter-class+) + (astore (setf req-params-register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (do ((i 0 (1+ i)) + (req req (cdr req))) + ((endp req)) + (aload req-params-register) + (emit-push-constant-int i) + (emit 'new +lisp-closure-parameter-class+) + (emit 'dup) + (emit-push-t) ;; we don't need the actual symbol + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+)) + (emit 'aastore))) + (when t + ;; process optional args + (emit-push-constant-int (length opt)) + (emit 'anewarray +lisp-closure-parameter-class+) + (astore (setf opt-params-register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (do ((i 0 (1+ i)) + (opt opt (cdr opt))) + ((endp opt)) + (aload opt-params-register) + (emit-push-constant-int i) + (emit 'new +lisp-closure-parameter-class+) + (emit 'dup) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second (car opt))) ;; initform + (if (null (third (car opt))) ;; + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I") + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+ +lisp-object+ + +lisp-object+ "I")) + (emit 'aastore))) + (when t + ;; process key args + (emit-push-constant-int (length key)) + (emit 'anewarray +lisp-closure-parameter-class+) + (astore (setf key-params-register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (do ((i 0 (1+ i)) + (key key (cdr key))) + ((endp key)) + (aload key-params-register) + (emit-push-constant-int i) + (emit 'new +lisp-closure-parameter-class+) + (emit 'dup) + (let ((keyword (fourth (car key)))) + (if (keywordp keyword) + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit-invokestatic +lisp-class+ "internKeyword" + (list +java-string+) +lisp-symbol+)) + ;; symbol is not really a keyword; yes, that's allowed! + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit 'ldc (pool-string + (package-name (symbol-package keyword)))) + (emit-invokestatic +lisp-class+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+)))) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second (car key))) + (if (null (third (car key))) + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+ +lisp-symbol+ + +lisp-object+ +lisp-object+)) + (emit 'aastore))) + + )) (aload 0) ;; this (cond ((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 +lisp-compiled-closure-class+) + ((and (null req-params-register) + (equal super +lisp-compiled-closure-class+)) (emit-constructor-lambda-list args) (emit-invokespecial-init super (lisp-object-arg-types 1))) + ((and + (equal super +lisp-compiled-closure-class+)) + (aload req-params-register) + (aload opt-params-register) + (aload key-params-register) + (if keys-p + (emit-push-t) + (progn + (emit-push-nil) + (emit 'checkcast +lisp-symbol-class+))) + (if rest-p + (emit-push-t) + (progn + (emit-push-nil) + (emit 'checkcast +lisp-symbol-class+))) + (if more-keys-p + (emit-push-t) + (progn + (emit-push-nil) + (emit 'checkcast +lisp-symbol-class+))) + (emit-invokespecial-init super + (list +lisp-closure-parameter-array+ + +lisp-closure-parameter-array+ + +lisp-closure-parameter-array+ + +lisp-symbol+ + +lisp-symbol+ +lisp-symbol+))) (t (aver nil))) (setf *code* (append *static-code* *code*)) From ehuelsmann at common-lisp.net Sun Jan 24 22:26:31 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 24 Jan 2010 17:26:31 -0500 Subject: [armedbear-cvs] r12399 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 24 17:26:29 2010 New Revision: 12399 Log: Remove debugging cruft. 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 Sun Jan 24 17:26:29 2010 @@ -1844,82 +1844,81 @@ (setf rest-p rest more-keys-p allow-other-keys-p keys-p key-p) - (when t - ;; process required args - (emit-push-constant-int (length req)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf req-params-register (method-max-locals constructor))) - (incf (method-max-locals constructor)) - (do ((i 0 (1+ i)) - (req req (cdr req))) - ((endp req)) - (aload req-params-register) - (emit-push-constant-int i) - (emit 'new +lisp-closure-parameter-class+) - (emit 'dup) - (emit-push-t) ;; we don't need the actual symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ - (list +lisp-symbol+)) - (emit 'aastore))) - (when t - ;; process optional args - (emit-push-constant-int (length opt)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf opt-params-register (method-max-locals constructor))) - (incf (method-max-locals constructor)) - (do ((i 0 (1+ i)) - (opt opt (cdr opt))) - ((endp opt)) - (aload opt-params-register) - (emit-push-constant-int i) - (emit 'new +lisp-closure-parameter-class+) - (emit 'dup) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second (car opt))) ;; initform - (if (null (third (car opt))) ;; - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I") - (emit-invokespecial-init +lisp-closure-parameter-class+ - (list +lisp-symbol+ +lisp-object+ - +lisp-object+ "I")) - (emit 'aastore))) - (when t - ;; process key args - (emit-push-constant-int (length key)) - (emit 'anewarray +lisp-closure-parameter-class+) - (astore (setf key-params-register (method-max-locals constructor))) - (incf (method-max-locals constructor)) - (do ((i 0 (1+ i)) - (key key (cdr key))) - ((endp key)) - (aload key-params-register) - (emit-push-constant-int i) - (emit 'new +lisp-closure-parameter-class+) - (emit 'dup) - (let ((keyword (fourth (car key)))) - (if (keywordp keyword) - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit-invokestatic +lisp-class+ "internKeyword" - (list +java-string+) +lisp-symbol+)) - ;; symbol is not really a keyword; yes, that's allowed! - (progn - (emit 'ldc (pool-string (symbol-name keyword))) - (emit 'ldc (pool-string - (package-name (symbol-package keyword)))) - (emit-invokestatic +lisp-class+ "internInPackage" - (list +java-string+ +java-string+) - +lisp-symbol+)))) - (emit-push-t) ;; we don't need the actual variable-symbol - (emit-read-from-string (second (car key))) - (if (null (third (car key))) - (emit-push-nil) - (emit-push-t)) ;; we don't need the actual supplied-p symbol - (emit-invokespecial-init +lisp-closure-parameter-class+ - (list +lisp-symbol+ +lisp-symbol+ - +lisp-object+ +lisp-object+)) - (emit 'aastore))) + ;; process required args + (emit-push-constant-int (length req)) + (emit 'anewarray +lisp-closure-parameter-class+) + (astore (setf req-params-register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (do ((i 0 (1+ i)) + (req req (cdr req))) + ((endp req)) + (aload req-params-register) + (emit-push-constant-int i) + (emit 'new +lisp-closure-parameter-class+) + (emit 'dup) + (emit-push-t) ;; we don't need the actual symbol + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+)) + (emit 'aastore)) + + ;; process optional args + (emit-push-constant-int (length opt)) + (emit 'anewarray +lisp-closure-parameter-class+) + (astore (setf opt-params-register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (do ((i 0 (1+ i)) + (opt opt (cdr opt))) + ((endp opt)) + (aload opt-params-register) + (emit-push-constant-int i) + (emit 'new +lisp-closure-parameter-class+) + (emit 'dup) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second (car opt))) ;; initform + (if (null (third (car opt))) ;; + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I") + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+ +lisp-object+ + +lisp-object+ "I")) + (emit 'aastore)) + + ;; process key args + (emit-push-constant-int (length key)) + (emit 'anewarray +lisp-closure-parameter-class+) + (astore (setf key-params-register (method-max-locals constructor))) + (incf (method-max-locals constructor)) + (do ((i 0 (1+ i)) + (key key (cdr key))) + ((endp key)) + (aload key-params-register) + (emit-push-constant-int i) + (emit 'new +lisp-closure-parameter-class+) + (emit 'dup) + (let ((keyword (fourth (car key)))) + (if (keywordp keyword) + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit-invokestatic +lisp-class+ "internKeyword" + (list +java-string+) +lisp-symbol+)) + ;; symbol is not really a keyword; yes, that's allowed! + (progn + (emit 'ldc (pool-string (symbol-name keyword))) + (emit 'ldc (pool-string + (package-name (symbol-package keyword)))) + (emit-invokestatic +lisp-class+ "internInPackage" + (list +java-string+ +java-string+) + +lisp-symbol+)))) + (emit-push-t) ;; we don't need the actual variable-symbol + (emit-read-from-string (second (car key))) + (if (null (third (car key))) + (emit-push-nil) + (emit-push-t)) ;; we don't need the actual supplied-p symbol + (emit-invokespecial-init +lisp-closure-parameter-class+ + (list +lisp-symbol+ +lisp-symbol+ + +lisp-object+ +lisp-object+)) + (emit 'aastore)) )) (aload 0) ;; this From ehuelsmann at common-lisp.net Mon Jan 25 06:58:51 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 25 Jan 2010 01:58:51 -0500 Subject: [armedbear-cvs] r12400 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 25 01:58:48 2010 New Revision: 12400 Log: Make NIL-as-a-symbol available for use for the compiler. Shaves off a few kB from our JAR. Modified: trunk/abcl/src/org/armedbear/lisp/Nil.java trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp 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 Mon Jan 25 01:58:48 2010 @@ -37,7 +37,7 @@ public final class Nil extends Symbol { - final static Nil NIL = new Nil(PACKAGE_CL); + final public static Symbol NIL = new Nil(PACKAGE_CL); public Nil(Package pkg) { Modified: trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp Mon Jan 25 01:58:48 2010 @@ -51,6 +51,7 @@ (initialize-known-symbols "org.armedbear.lisp.Symbol" symbols) (initialize-known-symbols "org.armedbear.lisp.Keyword" symbols) (initialize-known-symbols "org.armedbear.lisp.Lisp" symbols) + (initialize-known-symbols "org.armedbear.lisp.Nil" symbols) (defun lookup-known-symbol (symbol) "Returns the name of the field and its class designator From astalla at common-lisp.net Mon Jan 25 22:42:41 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 25 Jan 2010 17:42:41 -0500 Subject: [armedbear-cvs] r12401 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jan 25 17:42:38 2010 New Revision: 12401 Log: Added a flag to local functions that tracks whether they need an actual function object to be created (i.e. they are capture with FUNCTION). Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Mon Jan 25 17:42:38 2010 @@ -840,6 +840,8 @@ (list 'FUNCTION compiland))) ((setf local-function (find-local-function (cadr form))) (dformat t "p1-function local function ~S~%" (cadr form)) + ;;we found out that the function needs a reference + (setf (local-function-references-needed-p local-function) t) (let ((variable (local-function-variable local-function))) (when variable (dformat t "p1-function ~S used non-locally~%" 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 Mon Jan 25 17:42:38 2010 @@ -364,7 +364,11 @@ environment ;; the environment in which the function is stored in ;; case of a function from an enclosing lexical environment ;; which itself isn't being compiled - (references-allowed-p t) + (references-allowed-p t) ;;whether a reference to the function CAN be captured + (references-needed-p nil) ;;whether a reference to the function NEEDS to be + ;;captured, because the function name is used in a + ;;(function ...) form. Obviously implies + ;;references-allowed-p. ) (defvar *local-functions* ()) @@ -464,10 +468,11 @@ block)) (defstruct (flet-node (:conc-name flet-) - (:include binding-node))) -(defknown make-let/let*-node () t) -(defun make-let/let*-node () - (let ((block (%make-let/let*-node))) + (:include binding-node) + (:constructor %make-flet-node ()))) +(defknown make-flet-node () t) +(defun make-flet-node () + (let ((block (%make-flet-node))) (push block (compiland-blocks *current-compiland*)) block)) From mevenson at common-lisp.net Tue Jan 26 11:15:51 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 26 Jan 2010 06:15:51 -0500 Subject: [armedbear-cvs] r12402 - in trunk/abcl: . src/org/armedbear/lisp test/lisp/abcl test/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 26 06:15:48 2010 New Revision: 12402 Log: Move abcl-test-lisp to ASDF packaging. Change to ASDF packaging of abcl-test-lisp. Remove ASDF system 'abcl-tests' as ASDF systems without components don't carry dependencies transitively. Remove unneed :BEFORE load of abcl-test-lisp. Renamed conflicting tests now that they are loaded via ASDF. Implement ability to run tests matching a string. Export ABCL.TEST.LISP::RUN-MATCHING as external symbol. Added 'test/lisp/abcl/math-tests.lisp' back to ABCL.TEST.LISP, fixing errors that prevented it from working. Fix bug with directories specified to three-arg form of SYS:ZIP. JAR files always use '/' to name hierarchial entries. Allow of a top directory for creating hierarchially ZIPs: for arguments like "pathname pathnames &optional topdir" all pathnames will be interpolated relative to topdir. Contains the version of jar-file tests corresponding to PATHNAME, TRUENAME, and PROBE-FILE. The tests for jar-file will currently fail as it needs the implementation of SYS:UNZIP which in turn depends on the new version of Pathname which should follow shortly in a separate commit. jar-file initilization rewritten in Lisp, so it works under Windows. Java tests for Pathname and Stream. Help my dyslexic brain by renaming *abcl-{lisp-test,test,lisp}-directory* to *abcl-test-directory*. Refinement of jar-file tests. Correct all JAR-FILE.PATHNAME.* tests. JAR-FILE tests use the cross-platform form of COPY-FILE. Renamed test, using WITH-JAR-FILE-INIT macro. Added: trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java Removed: trunk/abcl/test/lisp/abcl/package-load.sh Modified: trunk/abcl/abcl.asd trunk/abcl/src/org/armedbear/lisp/zip.java trunk/abcl/test/lisp/abcl/condition-tests.lisp trunk/abcl/test/lisp/abcl/file-system-tests.lisp trunk/abcl/test/lisp/abcl/jar-file.lisp trunk/abcl/test/lisp/abcl/math-tests.lisp trunk/abcl/test/lisp/abcl/misc-tests.lisp trunk/abcl/test/lisp/abcl/mop-tests.lisp trunk/abcl/test/lisp/abcl/package.lisp trunk/abcl/test/lisp/abcl/test-utilities.lisp Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Tue Jan 26 06:15:48 2010 @@ -10,7 +10,6 @@ (defsystem :abcl :version "0.5.0") (defmethod perform :after ((o load-op) (c (eql (find-system :abcl)))) - (operate 'load-op :abcl-tests :force t) (operate 'load-op :abcl-test-lisp :force t) (operate 'load-op :cl-bench :force t) (operate 'load-op :ansi-compiled :force t) @@ -20,38 +19,30 @@ (defmethod perform ((o test-op) (c (eql (find-system :abcl)))) (operate 'test-op :abcl-tests :force t)) -;;; A collection of test suites for ABCL. -(defsystem :abcl-tests - :version "2.0" - :depends-on (:abcl-test-lisp - :ansi-compiled :ansi-interpreted - :cl-bench)) - -(defmethod perfom :before ((o test-op (c (eql find-system :abcl-tests)))) - (operate 'load-op :abcl-test-lisp) - (operate 'load-op :ansi-compiled) - (operate 'load-op :cl-bench)) - -;;; Run via (asdf:operate 'asdf:test-op :abcl-tests :force t) -(defmethod perform ((o test-op) (c (eql (find-system :abcl-tests)))) - ;; Additional test suite invocations would go here. - (operate 'test-op :abcl-test-lisp) - (operate 'test-op :ansi-compiled) - (operate 'test-op :cl-bench)) - ;;; Test ABCL with the Lisp unit tests collected in "test/lisp/abcl" (defsystem :abcl-test-lisp :version "1.1" :components - ((:module abcl-rt :pathname "test/lisp/abcl/" :serial t :components - ((:file "rt-package") (:file "rt"))) + ((:module abcl-rt + :pathname "test/lisp/abcl/" :serial t :components + ((:file "rt-package") (:file "rt") + (:file "test-utilities"))) (:module package :depends-on (abcl-rt) :pathname "test/lisp/abcl/" :components - ((:file "package"))))) -(defmethod perform :before ((o test-op) (c (eql (find-system - :abcl-test-lisp)))) - (operate 'load-op :abcl-test-lisp :force t)) + ((:file "package"))) + (:module test :depends-on (package) + :pathname "test/lisp/abcl/" :components + ((:file "compiler-tests") + (:file "condition-tests") + (:file "mop-tests-setup") + (:file "mop-tests" :depends-on ("mop-tests-setup")) + (:file "file-system-tests") + (:file "jar-file") + (:file "math-tests") + (:file "misc-tests") + (:file "pathname-tests"))))) + (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) "Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)." - (funcall (intern (symbol-name 'run) :abcl-test))) + (funcall (intern (symbol-name 'run) :abcl.test.lisp))) ;;; Test ABCL with the interpreted ANSI tests (defsystem :ansi-interpreted :version "1.0.1" Modified: trunk/abcl/src/org/armedbear/lisp/zip.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/zip.java (original) +++ trunk/abcl/src/org/armedbear/lisp/zip.java Tue Jan 26 06:15:48 2010 @@ -39,6 +39,8 @@ import java.io.FileInputStream; import java.io.FileOutputStream; import java.io.IOException; +import java.util.HashSet; +import java.util.Set; import java.util.zip.ZipEntry; import java.util.zip.ZipOutputStream; @@ -47,7 +49,7 @@ { private zip() { - super("zip", PACKAGE_SYS, true, "pathname pathnames"); + super("zip", PACKAGE_SYS, true, "pathname pathnames &optional topdir"); } @Override @@ -94,5 +96,74 @@ return zipfilePathname; } + @Override + public LispObject execute(LispObject first, LispObject second, LispObject third) + { + 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)); + Pathname root = (Pathname)coerceToPathname(third); + String rootPath = root.getDirectoryNamestring(); + int rootPathLength = rootPath.length(); + Set directories = new HashSet(); + 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())); + } + String directory = ""; + String dir = pathname.getDirectoryNamestring(); + if (dir.length() > rootPathLength) { + String d = dir.substring(rootPathLength); + int i = 0; + int j; + while ((j = d.indexOf(File.separator, i)) != -1) { + i = j + 1; + directory = d.substring(0, j).replace(File.separatorChar, '/') + "/"; + if (!directories.contains(directory)) { + directories.add(directory); + ZipEntry entry = new ZipEntry(directory); + out.putNextEntry(entry); + out.closeEntry(); + } + } + } + File file = new File(namestring); + if (file.isDirectory()) { + list = list.cdr(); + continue; + } + FileInputStream in = new FileInputStream(file); + ZipEntry entry = new ZipEntry(directory + 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(); } Modified: trunk/abcl/test/lisp/abcl/condition-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/condition-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/condition-tests.lisp Tue Jan 26 06:15:48 2010 @@ -16,8 +16,6 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(load (merge-pathnames "test-utilities.lisp" *load-truename*)) - (in-package #:abcl.test.lisp) (defun filter (string) Modified: trunk/abcl/test/lisp/abcl/file-system-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/file-system-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/file-system-tests.lisp Tue Jan 26 06:15:48 2010 @@ -33,12 +33,6 @@ :device (pathname-device *load-truename*) :directory (pathname-directory *load-truename*))) -(defmacro signals-error (form error-name) - `(locally (declare (optimize safety)) - (handler-case ,form - (error (c) (typep c ,error-name)) - (:no-error (&rest ignored) (declare (ignore ignored)) nil)))) - (defun pathnames-equal-p (pathname1 pathname2) #-(or allegro clisp cmu lispworks) (equal pathname1 pathname2) @@ -425,7 +419,7 @@ ;; Allegro's version component is :UNSPECIFIC. (pushnew 'user-homedir-pathname.1 *expected-failures*) -(deftest directory-namestring.1 +(deftest file-system.directory-namestring.1 (let ((pathname (user-homedir-pathname))) (equal (namestring pathname) (directory-namestring pathname))) #-windows @@ -434,15 +428,15 @@ ;; The drive prefix ("C:\\") is not part of the directory namestring. nil) #+clisp -(pushnew 'directory-namestring.1 *expected-failures*) +(pushnew 'file-system.directory-namestring.1 *expected-failures*) -(deftest directory-namestring.2 +(deftest file.system.directory-namestring.2 (let ((pathname (user-homedir-pathname))) (equal (directory-namestring pathname) (namestring (make-pathname :directory (pathname-directory pathname))))) t) #+clisp -(pushnew 'directory-namestring.2 *expected-failures*) +(pushnew 'file-system.directory-namestring.2 *expected-failures*) (deftest ensure-directories-exist.1 (let* ((tmp (make-temporary-filename *this-directory*)) Modified: trunk/abcl/test/lisp/abcl/jar-file.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-file.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-file.lisp Tue Jan 26 06:15:48 2010 @@ -1,88 +1,277 @@ (in-package #:abcl.test.lisp) -#-:unix (error "Load test setup currently needs UNIX shell script support.") +(defvar *jar-file-init* nil) -(defun load-init () - (let* ((*default-pathname-defaults* *this-directory*) - (asdf::*verbose-out* *standard-output*) - (package-command (format nil "cd ~A; sh ~A" - *this-directory* - (merge-pathnames "package-load.sh")))) +;;; From CL-FAD +(defvar *stream-buffer-size* 8192) +(defun cl-fad-copy-stream (from to &optional (checkp t)) + "Copies into TO \(a stream) from FROM \(also a stream) until the end +of FROM is reached, in blocks of *stream-buffer-size*. The streams +should have the same element type. If CHECKP is true, the streams are +checked for compatibility of their types." + (when checkp + (unless (subtypep (stream-element-type to) (stream-element-type from)) + (error "Incompatible streams ~A and ~A." from to))) + (let ((buf (make-array *stream-buffer-size* + :element-type (stream-element-type from)))) + (loop + (let ((pos (read-sequence buf from))) + (when (zerop pos) (return)) + (write-sequence buf to :end pos)))) + (values)) + +(defun cl-fad-copy-file (from to &key overwrite) + "Copies the file designated by the non-wild pathname designator FROM +to the file designated by the non-wild pathname designator TO. If +OVERWRITE is true overwrites the file designtated by TO if it exists." + (let ((element-type '(unsigned-byte 8))) + (with-open-file (in from :element-type element-type) + (with-open-file (out to :element-type element-type + :direction :output + :if-exists (if overwrite + :supersede :error)) + (cl-fad-copy-stream in out)))) + (values)) + +(defun jar-file-init () + (let* ((*default-pathname-defaults* *abcl-test-directory*) + (asdf::*verbose-out* *standard-output*)) (compile-file "foo.lisp") (compile-file "bar.lisp") (compile-file "eek.lisp") - (asdf:run-shell-command package-command)) + (let* ((dir (merge-pathnames "tmp/" *abcl-test-directory*)) + (sub (merge-pathnames "a/b/" dir))) + (when (probe-directory dir) + (delete-directory-and-files dir)) + (ensure-directories-exist sub) + (sys:unzip (merge-pathnames "foo.abcl") + dir) + (sys:unzip (merge-pathnames "foo.abcl") + sub) + (cl-fad-copy-file (merge-pathnames "bar.abcl") + (merge-pathnames "bar.abcl" dir)) + (cl-fad-copy-file (merge-pathnames "bar.abcl") + (merge-pathnames "bar.abcl" sub)) + (cl-fad-copy-file (merge-pathnames "eek.lisp") + (merge-pathnames "eek.lisp" dir)) + (cl-fad-copy-file (merge-pathnames "eek.lisp") + (merge-pathnames "eek.lisp" sub)) + (sys:zip (merge-pathnames "baz.jar") + (append + (directory (merge-pathnames "*" dir)) + (directory (merge-pathnames "*" sub))) + dir) + (delete-directory-and-files dir))) (setf *jar-file-init* t)) -(defvar *jar-file-init* nil) - (defmacro with-jar-file-init (&rest body) - `(let ((*default-pathname-defaults* *this-directory*)) + `(let ((*default-pathname-defaults* *abcl-test-directory*)) (progn (unless *jar-file-init* - (load-init)) + (jar-file-init)) , at body))) - -(deftest jar-file-load.1 +#+nil +(defmacro with-jar-file-init (&rest body) + `(progv '(*default-pathname-defaults*) '(,*abcl-test-directory*) + (unless *jar-file-init* + (load-init)) + , at body)) + +(deftest jar-file.load.1 (with-jar-file-init - (load "foo")) + (load "jar:file:baz.jar!/foo")) t) -(deftest jar-file-load.2 +(deftest jar-file.load.2 (with-jar-file-init - (load "foo.lisp")) + (load "jar:file:baz.jar!/bar")) t) -(deftest jar-file-load.3 +(deftest jar-file.load.3 (with-jar-file-init - (load "foo.abcl")) + (load "jar:file:baz.jar!/bar.abcl")) t) -(deftest jar-file-load.4 +(deftest jar-file.load.4 (with-jar-file-init - (load "jar:file:baz.jar!/foo")) + (load "jar:file:baz.jar!/eek")) t) -(deftest jar-file-load.6 +(deftest jar-file.load.5 (with-jar-file-init - (load "jar:file:baz.jar!/bar")) + (load "jar:file:baz.jar!/eek.lisp")) t) -(deftest jar-file-load.7 +(deftest jar-file.load.6 (with-jar-file-init - (load "jar:file:baz.jar!/bar.abcl")) + (load "jar:file:baz.jar!/a/b/foo")) t) -(deftest jar-file-load.8 +(deftest jar-file.load.7 (with-jar-file-init - (load "jar:file:baz.jar!/eek")) + (load "jar:file:baz.jar!/a/b/bar")) t) -(deftest jar-file-load.9 +(deftest jar-file.load.8 (with-jar-file-init - (load "jar:file:baz.jar!/eek.lisp")) + (load "jar:file:baz.jar!/a/b/bar.abcl")) + t) + +(deftest jar-file.load.9 + (with-jar-file-init + (load "jar:file:baz.jar!/a/b/eek")) t) +(deftest jar-file.load.10 + (with-jar-file-init + (load "jar:file:baz.jar!/a/b/eek.lisp")) + t) -(deftest jar-file-probe-file.1 +(deftest jar-file.probe-file.1 (with-jar-file-init (probe-file "jar:file:baz.jar!/eek.lisp")) - #p"jar:file:baz.jar!/eek.lisp") ; WRONG: PROBE-FILE should return - ; TRUENAME on existence. + #p#.(format nil "jar:file:~A/baz.jar!/eek.lisp" + (namestring *abcl-test-directory*))) +(deftest jar-file.probe-file.2 + (with-jar-file-init + (probe-file "jar:file:baz.jar!/a/b/bar.abcl")) + #p#.(format nil "jar:file:~A/baz.jar!/a/b/bar.abcl" + (namestring *abcl-test-directory*))) + +(deftest jar-file.probe-file.3 + (with-jar-file-init + (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._")) + #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" + (namestring *abcl-test-directory*))) + +(deftest jar-file.probe-file.4 + (with-jar-file-init + (probe-file "jar:file:baz.jar!/a/b")) + nil) -(deftest jar-file-merge-pathnames.1 +(deftest jar-file.probe-file.5 + (with-jar-file-init + (probe-file "jar:file:baz.jar!/a/b/")) + #p#.(format nil "jar:file:~Abaz.jar!/a/b/" + (namestring *abcl-test-directory*))) + +(deftest jar-file.merge-pathnames.1 + (merge-pathnames + "/bar.abcl" #p"jar:file:baz.jar!/foo") + #p"jar:file:baz.jar!/bar.abcl") + +(deftest jar-file.merge-pathnames.2 (merge-pathnames - "!/foo" #p"jar:file:baz.jar") + "/bar.abcl" #p"jar:file:baz.jar!/foo/") + #p"jar:file:baz.jar!/foo/bar.abcl") + +(deftest jar-file.merge-pathnames.3 + (merge-pathnames + "jar:file:baz.jar!/foo" "bar") #p"jar:file:baz.jar!/foo") -(deftest jar-file-truename.1 - (truename "jar:file:baz.jar!/foo") - (format nil "jar:file:~S/baz.jar!/foo" - *this-directory*)) - +(deftest jar-file.truename.1 + (signals-error (truename "jar:file:baz.jar!/foo") + 'file-error) + t) + +(deftest jar-file.pathname.1 + (let* ((p #p"jar:file:foo/baz.jar!/") + (d (first (pathname-device p)))) + (values + (pathname-directory d) (pathname-name d) (pathname-type d))) + (:relative "foo") "baz" "jar") + +(deftest jar-file.pathname.2 + (let* ((p #p"jar:file:baz.jar!/foo.abcl") + (d (first (pathname-device p)))) + (values + (pathname-name d) (pathname-type d) + (pathname-directory p) (pathname-name p) (pathname-type p))) + "baz" "jar" + nil "foo" "abcl") + +(deftest jar-file.pathname.3 + (let* ((p #p"jar:jar:file:baz.jar!/foo.abcl!/") + (d0 (first (pathname-device p))) + (d1 (second (pathname-device p)))) + (values + (pathname-name d0) (pathname-type d0) + (pathname-name d1) (pathname-type d1))) + "baz" "jar" + "foo" "abcl") + +(deftest jar-file.pathname.4 + (let* ((p #p"jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls") + (d0 (first (pathname-device p))) + (d1 (second (pathname-device p)))) + (values + (pathname-directory d0) (pathname-name d0) (pathname-type d0) + (pathname-directory d1) (pathname-name d1) (pathname-type d1) + (pathname-directory p) (pathname-name p) (pathname-type p))) + (:relative "a") "baz" "jar" + (:relative "b" "c") "foo" "abcl" + (:relative "this" "that") "foo-20" "cls") + +(deftest jar-file.pathname.5 + (let* ((p #p"jar:jar:file:a/foo/baz.jar!/b/c/foo.abcl!/armed/bear/bar-1.cls") + (d0 (first (pathname-device p))) + (d1 (second (pathname-device p)))) + (values + (pathname-directory d0) (pathname-name d0) (pathname-type d0) + (pathname-directory d1) (pathname-name d1) (pathname-type d1) + (pathname-directory p) (pathname-name p) (pathname-type p))) + (:relative "a" "foo" ) "baz" "jar" + (:relative "b" "c") "foo" "abcl" + (:relative "armed" "bear") "bar-1" "cls") + +(deftest jar-file.pathname.6 + (let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class") + (d (first (pathname-device p)))) + + (values + d + (pathname-directory p) (pathname-name p) (pathname-type p))) + "http://example.org/abcl.jar" + (:relative "org" "armedbear" "lisp") "Version" "class") + +(deftest jar-file.pathname.7 + (let* ((p #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls") + (d (pathname-device p)) + (d0 (first d)) + (d1 (second d))) + (values + d0 + (pathname-name d1) (pathname-type d1) + (pathname-name p) (pathname-type p))) + "http://example.org/abcl.jar" + "foo" "abcl" + "foo-1" "cls") + +(deftest jar-file.pathname.8 + (let* ((p #p"jar:file:/a/b/foo.jar!/") + (d (first (pathname-device p)))) + (values + (pathname-directory d) (pathname-name d) (pathname-type d))) + (:ABSOLUTE "a" "b") "foo" "jar") + +(deftest jar-file.pathname.9 + (let* ((p #p"jar:file:a/b/foo.jar!/c/d/foo.lisp") + (d (first (pathname-device p)))) + (values + (pathname-directory d) (pathname-name d) (pathname-type d) + (pathname-directory p) (pathname-name p) (pathname-type p))) + (:RELATIVE "a" "b") "foo" "jar" + (:RELATIVE "c" "d") "foo" "lisp") + + + + + + Modified: trunk/abcl/test/lisp/abcl/math-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/math-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/math-tests.lisp Tue Jan 26 06:15:48 2010 @@ -35,15 +35,17 @@ #+sbcl `(sb-int:get-floating-point-modes)) #+(or abcl cmu sbcl) -(defun restore-default-floating-point-modes () +(defmacro restore-default-floating-point-modes () #+abcl - (set-floating-point-modes :traps '(:overflow :underflow)) + `(ext:set-floating-point-modes :traps '(:overflow :underflow)) #+(or cmu sbcl) - (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))) + `(set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))) #+(or abcl cmu sbcl) (eval-when (:compile-toplevel :load-toplevel :execute) - (restore-default-floating-point-modes)) + (restore-default-floating-point-modes)) +;; (ext:set-floating-point-modes :traps '(:overflow :underflow))) +;; (deftest most-negative-fixnum.1 (= (/ most-negative-fixnum -1) (- most-negative-fixnum)) @@ -354,7 +356,7 @@ (expt #c(0 0.0) 4) #c(0.0 0.0)) -(deftest expt.25 +(deftest expt.26 (expt #c(0 0.0) 4.0) #c(0.0 0.0)) @@ -451,7 +453,7 @@ (signals-error (truncate least-positive-double-float 2) 'floating-point-underflow) t) -(deftest read-from-string.1 +(deftest math.read-from-string.1 #+(or cmu sbcl) (unwind-protect (signals-error (read-from-string "1.0f-1000") 'reader-error) Modified: trunk/abcl/test/lisp/abcl/misc-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/misc-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/misc-tests.lisp Tue Jan 26 06:15:48 2010 @@ -19,12 +19,12 @@ (in-package #:abcl.test.lisp) -(deftest dotimes.1 +(deftest misc.dotimes.1 (progn - (fmakunbound 'dotimes.1) - (defun dotimes.1 () + (fmakunbound 'misc.dotimes.1) + (defun misc.dotimes.1 () (let ((sum 0)) (dotimes (i 10) (setq i 42) (incf sum i)) sum)) - (dotimes.1)) + (misc.dotimes.1)) 420) (deftest dotimes.1.compiled @@ -36,12 +36,12 @@ (dotimes.1.compiled)) 420) -(deftest dotimes.2 +(deftest misc.dotimes.2 (progn - (fmakunbound 'dotimes.2) - (defun dotimes.2 (count) + (fmakunbound 'misc.dotimes.2) + (defun misc.dotimes.2 (count) (let ((sum 0)) (dotimes (i count) (setq i 42) (incf sum i)) sum)) - (dotimes.2 10)) + (misc.dotimes.2 10)) 420) (deftest dotimes.2.compiled Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/mop-tests.lisp (original) +++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Tue Jan 26 06:15:48 2010 @@ -16,11 +16,6 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -(load (merge-pathnames "test-utilities.lisp" *load-truename*)) -(compile-file (merge-pathnames "mop-tests-setup.lisp" *load-truename*)) -(load (merge-pathnames "mop-tests-setup" *load-truename*)) - (in-package #:abcl.test.lisp) (deftest compute-applicable-methods.foo.1 Modified: trunk/abcl/test/lisp/abcl/package.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/package.lisp (original) +++ trunk/abcl/test/lisp/abcl/package.lisp Tue Jan 26 06:15:48 2010 @@ -1,32 +1,32 @@ (defpackage #:abcl.test.lisp (:use #:cl #:abcl-rt) - (:nicknames "ABCL-TEST") - (:export #:run)) + (:nicknames "ABCL-TEST-LISP" "ABCL-TEST") + (:export + #:run #:run-matching)) (in-package #:abcl.test.lisp) -(defvar *abcl-lisp-test-directory* - (pathname (directory-namestring *load-truename*)) - "The directory in which the ABCL test source files are located.") +(defparameter *abcl-test-directory* + (make-pathname :host (pathname-host *load-truename*) + :device (pathname-device *load-truename*) + :directory (pathname-directory *load-truename*))) (defun run () "Run the Lisp test suite for ABCL." + (let ((*default-pathname-defaults* *abcl-test-directory*)) + (do-tests))) - (let ((*default-pathname-defaults* *abcl-lisp-test-directory*)) - (rem-all-tests) - - (load "test-utilities.lisp") - - (load "compiler-tests.lisp") - (load "condition-tests.lisp") - (load "mop-tests.lisp") - (load "file-system-tests.lisp") - (load "java-tests.lisp") - (load "math-tests.lisp") - (load "misc-tests.lisp") - - (when (find :unix *features*) - (load "jar-file.lisp")) +;;; XXX move this into test-utilities.lisp? +(defun run-matching (&optional (match "jar-file.")) + (let* ((matching (string-upcase match)) + (tests + (remove-if-not + (lambda (name) (search matching name)) + (mapcar (lambda (entry) + (symbol-name (abcl-rt::name entry))) + (rest abcl-rt::*entries*))))) + (dolist (test tests) + (do-test (intern test :abcl.test.lisp))))) + - (do-tests))) \ No newline at end of file Modified: trunk/abcl/test/lisp/abcl/test-utilities.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/test-utilities.lisp (original) +++ trunk/abcl/test/lisp/abcl/test-utilities.lisp Tue Jan 26 06:15:48 2010 @@ -24,6 +24,7 @@ #+(and lispworks win32) (pushnew :windows *features*) +#+nil ;; Taken care of by ASDF (unless (member "ABCL-RT" *modules* :test #'string=) (load (merge-pathnames "rt-package.lisp" *load-truename*)) (load #+abcl (compile-file-if-needed (merge-pathnames "rt.lisp" *load-truename*)) @@ -32,15 +33,17 @@ #-abcl (compile-file (merge-pathnames "rt.lisp" *load-truename*))) (provide "ABCL-RT")) -(in-package #:abcl-regression-test) -(export '(signals-error)) +(in-package #:abcl-regression-test) (defmacro signals-error (form error-name) `(locally (declare (optimize safety)) (handler-case ,form (condition (c) (typep c ,error-name)) (:no-error (&rest ignored) (declare (ignore ignored)) nil)))) +(export '(signals-error)) + + #+nil (rem-all-tests) Added: trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java ============================================================================== --- (empty file) +++ trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java Tue Jan 26 06:15:48 2010 @@ -0,0 +1,58 @@ +package org.armedbear.lisp; + +import java.net.MalformedURLException; +import org.junit.Test; +import static org.junit.Assert.*; +import org.junit.runner.JUnitCore; + + +import java.net.URL; +import java.io.File; +import java.io.FileWriter; +import java.io.InputStream; +import java.io.InputStreamReader; +import java.io.IOException; + +public class PathnameTest +{ + public static void main(final String args[]) { + JUnitCore.main("org.armedbear.lisp.PathnameTest"); + } + + @Test + public void constructorURL() + { + URL url = null; + try { + url = new URL("file:///Users/evenson/work/abcl/build/classes/org/armedbear/lisp/boot.lisp"); + } catch (MalformedURLException e) { + System.out.println(e.getMessage()); + } + Pathname pathname = new Pathname(url); + assertNotNull(pathname); + assertNotNull(pathname.getNamestring()); + assertNotNull(pathname.name); + assertNotNull(pathname.type); + assertNotNull(pathname.directory); + } + + @Test + public void getInputStream() throws IOException { + File file = File.createTempFile("foo", "lisp"); + FileWriter output = new FileWriter(file); + String contents = "(defun foo () 42)"; + output.append(contents); + output.close(); + Pathname pathname = Pathname.makePathname(file); + InputStream input = pathname.getInputStream(); + InputStreamReader reader = new InputStreamReader(input); + char[] buffer = new char[1024]; + StringBuilder result = new StringBuilder(); + int i; + while((i = reader.read(buffer, 0, buffer.length)) != -1) { + result.append(buffer, 0, i); + } + assertEquals(contents, result.toString()); + file.delete(); + } +} Added: trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java ============================================================================== --- (empty file) +++ trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java Tue Jan 26 06:15:48 2010 @@ -0,0 +1,31 @@ +package org.armedbear.lisp; + +import static org.junit.Assert.*; + +import java.io.File; +import java.io.FileWriter; +import org.junit.Test; +import java.io.IOException; + +public class StreamTest +{ + @Test + public void readLispObject() { + File file = null; + try { + file = File.createTempFile("foo", "lisp"); + FileWriter output = new FileWriter(file); + String contents = "(defun foo () 42)"; + output.append(contents); + output.close(); + } catch (IOException e) { + System.out.println("Failed to create temp file" + e); + return; + } + Pathname pathname = Pathname.makePathname(file); + Stream in = new Stream(Symbol.SYSTEM_STREAM, pathname.getInputStream(), Symbol.CHARACTER); + LispObject o = in.read(false, Lisp.EOF, false, LispThread.currentThread()); + assertFalse(o.equals(Lisp.NIL)); + file.delete(); + } +} \ No newline at end of file From mevenson at common-lisp.net Tue Jan 26 11:21:20 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 26 Jan 2010 06:21:20 -0500 Subject: [armedbear-cvs] r12403 - trunk/abcl/test/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 26 06:21:19 2010 New Revision: 12403 Log: Set standard svn properties. Modified: trunk/abcl/test/src/org/armedbear/lisp/FastStringBufferTest.java (props changed) trunk/abcl/test/src/org/armedbear/lisp/PathnameTest.java (props changed) trunk/abcl/test/src/org/armedbear/lisp/StreamTest.java (props changed) From mevenson at common-lisp.net Tue Jan 26 11:31:00 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 26 Jan 2010 06:31:00 -0500 Subject: [armedbear-cvs] r12404 - in trunk/abcl: . nbproject Message-ID: Author: mevenson Date: Tue Jan 26 06:30:57 2010 New Revision: 12404 Log: Debugging ABCL compilation support; upgrade to JUnit-4.8.1. Netbeans uses compiled directories before source. Setting the property 'abcl.compile.lisp.skip' will skip the compilation of the Lisp files which can be useful to debug under Netbeans when debugging fundamental parts of ABCL. Started to document useful Ant-based build knobs in 'build.properties.in'. Added PathnameTest and StreamTest to Java unit tests. Start documenting properties that affect the Ant build in 'build.properties.in'. Modified: trunk/abcl/build.properties.in trunk/abcl/build.xml trunk/abcl/nbproject/project.properties trunk/abcl/netbeans-build.xml Modified: trunk/abcl/build.properties.in ============================================================================== --- trunk/abcl/build.properties.in (original) +++ trunk/abcl/build.properties.in Tue Jan 26 06:30:57 2010 @@ -1,2 +1,11 @@ # build.properties # $Id: build.properties,v 1.23 2007-03-03 19:19:11 piso Exp $ + +# Contents show up in JAR Manifest in the Implementation-Source attribute +#version.src=[abcl] + +# If set, ABCL attempts to perform incremental compilation +#abcl.build.incremental=true + +# Skip the compilation of Lisp sources (for debugging) +#abcl.compile.lisp.skip=true Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Tue Jan 26 06:30:57 2010 @@ -76,6 +76,7 @@ + @@ -269,7 +270,7 @@ value="${src.dir}/org/armedbear/lisp/"/> - + - + - + + - + @@ -623,18 +625,19 @@ - + - + + depends="abcl.test.pre-compile"> + + Modified: trunk/abcl/nbproject/project.properties ============================================================================== --- trunk/abcl/nbproject/project.properties (original) +++ trunk/abcl/nbproject/project.properties Tue Jan 26 06:30:57 2010 @@ -18,6 +18,7 @@ dist.dir=dist dist.jar=${dist.dir}/abcl.jar dist.javadoc.dir=${dist.dir}/javadoc +endorsed.classpath= excludes= file.reference.abcl-src=src includes=org/armedbear/lisp/**/*.java,org/armedbear/lisp/**/*.lisp @@ -55,15 +56,15 @@ meta.inf.dir=${src.dir}/META-INF platform.active=default_platform run.classpath=\ - ${javac.classpath}:\ - ${build.classes.dir} + ${build.classes.dir}:\ + ${javac.classpath} # 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} + ${build.test.classes.dir}:\ + ${javac.test.classpath} source.encoding=UTF-8 src.dir=${file.reference.abcl-src} src.doc.dir=doc Modified: trunk/abcl/netbeans-build.xml ============================================================================== --- trunk/abcl/netbeans-build.xml (original) +++ trunk/abcl/netbeans-build.xml Tue Jan 26 06:30:57 2010 @@ -6,8 +6,12 @@ probably fail otherwise. --> - - + + + + + + From mevenson at common-lisp.net Thu Jan 28 08:49:39 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 28 Jan 2010 03:49:39 -0500 Subject: [armedbear-cvs] r12405 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Jan 28 03:49:36 2010 New Revision: 12405 Log: Don't invoke the entire ABCL runtime just to get the version number during compilation. Modified: trunk/abcl/build.xml trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Thu Jan 28 03:49:36 2010 @@ -270,24 +270,14 @@ value="${src.dir}/org/armedbear/lisp/"/> - - - + - - - - - - + classname="org.armedbear.lisp.Version" + logerror="yes"/> - Built ABCL version: ${abcl.version} + ABCL version: ${abcl.version} Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Thu Jan 28 03:49:36 2010 @@ -43,4 +43,8 @@ { return "0.19.0-dev"; } + + public static void main(String args[]) { + System.out.println(Version.getVersion()); + } } From mevenson at common-lisp.net Fri Jan 29 08:45:37 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 29 Jan 2010 03:45:37 -0500 Subject: [armedbear-cvs] r12406 - in trunk/abcl: . test/lisp/abcl Message-ID: Author: mevenson Date: Fri Jan 29 03:45:34 2010 New Revision: 12406 Log: Where possible collect bug reports as unit tests so they can stay fixed. Added: trunk/abcl/test/lisp/abcl/bugs.lisp Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Fri Jan 29 03:45:34 2010 @@ -38,6 +38,7 @@ (:file "jar-file") (:file "math-tests") (:file "misc-tests") + (:file "bugs") (:file "pathname-tests"))))) (defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp)))) Added: trunk/abcl/test/lisp/abcl/bugs.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/bugs.lisp Fri Jan 29 03:45:34 2010 @@ -0,0 +1,26 @@ +(in-package :abcl.test.lisp) + +;;; When these bugs get fixed, they should be moved elsewhere in the +;;; testsuite so they remain fixed. + +(deftest bugs.translate-logical-pathname + #| + Date: Mon, 18 Jan 2010 10:51:07 -0500 + Message-ID: <29af5e2d1001180751l7cf79a3ay929cef1deb9ed063 at mail.gmail.com> + Subject: Re: [armedbear-devel] translate-logical-pathname and :wild-inferiors + regression + From: Alan Ruttenberg + |# + (progn + (setf (logical-pathname-translations "ido") + '((#P"IDO:IDO-CORE;**;*.*" + #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/ido-core/**/*.*") + (#P"IDO:IMMUNOLOGY;**;*.*" + #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/**/*.*") + (#P"IDO:TOOLS;**;*.*" + #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/tools/**/*.*") + (#P"IDO:LIB;**;*.*" + #P"/Users/alanr/repos/infectious-disease-ontology/trunk/lib/**/*.*"))) + (translate-pathname #P"IDO:IMMUNOLOGY;" #P"IDO:IMMUNOLOGY;**;*.*" + #P"/Users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/**/*.*")) + #P"/users/alanr/repos/infectious-disease-ontology/trunk/src/ontology/immunology/") \ No newline at end of file From ehuelsmann at common-lisp.net Fri Jan 29 21:56:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 29 Jan 2010 16:56:41 -0500 Subject: [armedbear-cvs] r12407 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 29 16:56:38 2010 New Revision: 12407 Log: Refer to autoloads.lisp from Autoload.java to explain the goal of autoloading. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java 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 Fri Jan 29 16:56:38 2010 @@ -35,6 +35,9 @@ import static org.armedbear.lisp.Lisp.*; +/** See autoloads.lisp for a general explanation of what we're + * trying to achieve here. + */ public class Autoload extends Function { protected final String fileName; From ehuelsmann at common-lisp.net Fri Jan 29 22:17:54 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 29 Jan 2010 17:17:54 -0500 Subject: [armedbear-cvs] r12408 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 29 17:17:52 2010 New Revision: 12408 Log: Fix an issue reported in September by Matthew Mondor to the ECL list (about ECL, ofcourse) which we're also handling incorrectly: FIND-SYMBOL requires a string argument. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri Jan 29 17:17:52 2010 @@ -3300,14 +3300,16 @@ @Override public LispObject execute(LispObject arg) { - return getCurrentPackage().findSymbol(arg.getStringValue()); + return getCurrentPackage() + .findSymbol(checkString(arg).getStringValue()); } @Override public LispObject execute(LispObject first, LispObject second) { - return coerceToPackage(second).findSymbol(first.getStringValue()); + return coerceToPackage(second) + .findSymbol(checkString(first).getStringValue()); } }; From astalla at common-lisp.net Sat Jan 30 23:08:38 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 30 Jan 2010 18:08:38 -0500 Subject: [armedbear-cvs] r12409 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sat Jan 30 18:08:35 2010 New Revision: 12409 Log: Rewriting of function calls with (lambda ...) as the operator to let* forms. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sat Jan 30 18:08:35 2010 @@ -140,6 +140,175 @@ rest allow-others-p (nreverse aux) whole env))) +(define-condition lambda-list-mismatch (error) + ((mismatch-type :reader lambda-list-mismatch-type :initarg :mismatch-type))) + +(defmacro push-argument-binding (var form temp-bindings bindings) + (let ((g (gensym))) + `(let ((,g (gensym (symbol-name '#:temp)))) + (push (list ,g ,form) ,temp-bindings) + (push (list ,var ,g) ,bindings)))) + +(defun match-lambda-list (parsed-lambda-list arguments) + (flet ((pop-required-argument () + (if (null arguments) + (error 'lambda-list-mismatch :mismatch-type :too-few-arguments) + (pop arguments))) + (var (var-info) (car var-info)) + (initform (var-info) (cadr var-info)) + (p-var (var-info) (caddr var-info))) + (destructuring-bind (req opt key key-p rest allow-others-p aux whole env) + parsed-lambda-list + (declare (ignore whole env)) + (let (req-bindings temp-bindings bindings ignorables) + ;;Required arguments. + (setf req-bindings + (loop :for var :in req :collect `(,var ,(pop-required-argument)))) + + ;;Optional arguments. + (when opt + (dolist (var-info opt) + (if arguments + (progn + (push-argument-binding (var var-info) (pop arguments) + temp-bindings bindings) + (when (p-var var-info) + (push `(,(p-var var-info) t) bindings))) + (progn + (push `(,(var var-info) ,(initform var-info)) bindings) + (when (p-var var-info) + (push `(,(p-var var-info) nil) bindings))))) + (setf bindings (nreverse bindings))) + + (unless (or key-p rest (null arguments)) + (error 'lambda-list-mismatch :mismatch-type :too-many-arguments)) + + ;;Keyword and rest arguments. + (if key-p + (multiple-value-bind (kbindings ktemps kignor) + (match-keyword-and-rest-args + key allow-others-p rest arguments) + (setf bindings (append bindings kbindings) + temp-bindings (append temp-bindings ktemps) + ignorables (append kignor ignorables))) + (when rest + (let (rest-binding) + (push-argument-binding (var rest) `(list , at arguments) + temp-bindings rest-binding) + (setf bindings (append bindings rest-binding))))) + + ;;Aux parameters. + (when aux + (setf bindings + `(, at bindings + ,@(loop + :for var-info :in aux + :collect `(,(var var-info) ,(initform var-info)))))) + + (values + (append req-bindings temp-bindings bindings) + ignorables))))) + +(defun match-keyword-and-rest-args (key allow-others-p rest arguments) + (flet ((var (var-info) (car var-info)) + (initform (var-info) (cadr var-info)) + (p-var (var-info) (caddr var-info)) + (keyword (var-info) (cadddr var-info))) + (when (oddp (list-length arguments)) + (error 'lambda-list-mismatch + :mismatch-type :odd-number-of-keyword-arguments)) + + (let (temp-bindings bindings other-keys-found-p ignorables) + ;;If necessary, make up a fake argument to hold :allow-other-keys, + ;;needed later. This also handles nicely: + ;; 3.4.1.4.1 Suppressing Keyword Argument Checking + ;;third statement. + (unless (find :allow-other-keys key :key #'keyword) + (let ((allow-other-keys-temp (gensym (symbol-name :allow-other-keys)))) + (push allow-other-keys-temp ignorables) + (push (list allow-other-keys-temp nil nil :allow-other-keys) key))) + + ;;First, let's bind the keyword arguments that have been passed by + ;;the caller. If we encounter an unknown keyword, remember it. + ;;As per the above, :allow-other-keys will never be considered + ;;an unknown keyword. + (loop + :for var :in arguments :by #'cddr + :for value :in (cdr arguments) by #'cddr + :do (let ((var-info (find var key :key #'keyword))) + (if var-info + ;;var is one of the declared keyword arguments + (progn + (push-argument-binding (var var-info) value + temp-bindings bindings) + ;(push `(,(var var-info) ,value) bindings) + (when (p-var var-info) + (push `(,(p-var var-info) t) bindings))) + (setf other-keys-found-p t)))) + + ;;Then, let's bind those arguments that haven't been passed in + ;;to their default value, in declaration order. + (loop + :for var-info :in key + :do (unless (find (var var-info) bindings :key #'car) + (push `(,(var var-info) ,(initform var-info)) bindings) + (when (p-var var-info) + (push `(,(p-var var-info) nil) bindings)))) + + ;;If necessary, check for unrecognized keyword arguments. + (when (and other-keys-found-p (not allow-others-p)) + (if (loop + :for var :in arguments :by #'cddr + :if (eq var :allow-other-keys) + :do (return t)) + ;;We know that :allow-other-keys has been passed, so we + ;;can access the binding for it and be sure to get the + ;;value passed by the user and not an initform. + (let* ((arg (var (find :allow-other-keys key :key #'keyword))) + (binding (find arg bindings :key #'car)) + (form (cadr binding))) + (if (constantp form) + (unless (eval form) + (error 'lambda-list-mismatch + :mismatch-type :unknown-keyword)) + (setf (cadr binding) + `(or ,(cadr binding) + (error 'program-error + "Unrecognized keyword argument"))))) + ;;TODO: it would be nice to report *which* keyword + ;;is unknown + (error 'lambda-list-mismatch :mismatch-type :unknown-keyword))) + (when rest + (push `(,(var rest) + (list ,@(let (list) + (loop + :for var :in arguments :by #'cddr + :for val :in (cdr arguments) :by #'cddr + :do (let ((bound-var + (var (find var key :key #'keyword)))) + (push var list) + (if bound-var + (push bound-var list) + (push val list)))) + (nreverse list)))) + bindings)) + (values + (nreverse bindings) + temp-bindings + ignorables)))) + +#||test for the above +(handler-case + (let ((lambda-list + (multiple-value-list + (jvm::parse-lambda-list + '(a b &optional (c 42) &rest foo &key (bar c) baz ((kaz kuz) bar)))))) + (jvm::match-lambda-list + lambda-list + '((print 1) 3 (print 32) :bar 2))) + (jvm::lambda-list-mismatch (x) (jvm::lambda-list-mismatch-type x))) +||# + ;; Returns a list of declared free specials, if any are found. (declaim (ftype (function (list list block-node) list) process-declarations-for-vars)) @@ -1055,28 +1224,44 @@ (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))) + (let ((op (car form)) + (args (cdr form))) + (if (and (listp op) + (eq (car op) 'lambda)) + (handler-case + (let ((lambda-list + (multiple-value-list (parse-lambda-list (cadr op)))) + (body (cddr op))) + (multiple-value-bind (bindings ignorables) + (match-lambda-list lambda-list args) + `(let* ,bindings + (declare (ignorable , at ignorables)) + , at body))) + (lambda-list-mismatch (x) + (warn "Invalid function call: ~S (mismatch type: ~A)" + form (lambda-list-mismatch-type x)) + 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) @@ -1184,7 +1369,7 @@ (t (p1-function-call form)))) ((and (consp op) (eq (%car op) 'LAMBDA)) - (p1 (list* 'FUNCALL form))) + (p1 (rewrite-function-call form))) (t form)))))) From vvoutilainen at common-lisp.net Sun Jan 31 00:06:12 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sat, 30 Jan 2010 19:06:12 -0500 Subject: [armedbear-cvs] r12410 - in trunk/abcl/doc/design: . streams Message-ID: Author: vvoutilainen Date: Sat Jan 30 19:06:11 2010 New Revision: 12410 Log: Add documentation for the streams. Added: trunk/abcl/doc/design/ trunk/abcl/doc/design/streams/ trunk/abcl/doc/design/streams/README trunk/abcl/doc/design/streams/design.html trunk/abcl/doc/design/streams/design.rst trunk/abcl/doc/design/streams/pprint-problem.dia trunk/abcl/doc/design/streams/pprint-problem.png (contents, props changed) trunk/abcl/doc/design/streams/pprint-solution.dia trunk/abcl/doc/design/streams/pprint-solution.png (contents, props changed) Added: trunk/abcl/doc/design/streams/README ============================================================================== --- (empty file) +++ trunk/abcl/doc/design/streams/README Sat Jan 30 19:06:11 2010 @@ -0,0 +1,8 @@ +To generate html from rst, use +rst2html design.rst > design.html + +The .dia files are uncompressed dia diagrams. Just export +them to png from dia if you need to do modifications. +You can do the exports from the command line by using +dia -t pprint-problem.dia +dia -t pprint-solution.dia Added: trunk/abcl/doc/design/streams/design.html ============================================================================== --- (empty file) +++ trunk/abcl/doc/design/streams/design.html Sat Jan 30 19:06:11 2010 @@ -0,0 +1,326 @@ + + + + + + +Design of lisp streams in ABCL + + + +
+

Design of lisp streams in ABCL

+ +
+

The previous design

+

Previously, ABCL streams were built-in classes. This presented some problems for Gray streams, +because ABCL CLOS can't use a built-in class as a base class, and Gray streams derive from +a system-stream class. This was corrected by converting ABCL streams to be structure-objects +instead of built-in classes, allowing CLOS to derive from the streams. There was, however, another +problem that revealed a need to change the design in more drastic ways.

+
+

The problem with the previous design

+

While converting the streams from built-in classes to structure-objects allowed derivation, +the pretty printer still didn't work with Gray streams. Gray streams replace the system stream +functions, saving the old function symbols so that they can be later invoked. The pretty printer, +however, just replaces the stream functions, and calls the low-level primitives directly, thus +bypassing Gray streams completely. The attached image portrays the problem, where pprint will, +for example, invoke %stream-write-char, thus bypassing any methods that there may be for +stream-write-char using Gray streams.

+pprint-problem.png +
+
+
+

The planned future design and solution to the problem

+

The solution to the problem is quite similar to how SBCL does its streams. First of all, the pretty printer will +no longer replace stream functions. The stream functionality will be based on closures in the slots of +the structure-object representing the stream, and those closures will invoke low-level i/o functions that +are stream-specific.

+

The pretty printer will just setup closures that will extract the underlying stream +object from a pprint-wrapped stream, and invoke its low-level functions. If pprint wrapping isn't present, +the slots will contain closures that directly invoke low-level functions of streams. Gray streams will +still replace the stream functions, because it's capable of invoking the replaced functions.

+

In addition to these changes, it is planned that the stream function primitives will be moved from the Stream +java class to a streamfunctions library, allowing the stream functions to be written in lisp rather than java. +There's an ongoing aspiration to increase the lisp/java code ratio of ABCL, and this new design allows for that.

+pprint-solution.png +
+
+ + Added: trunk/abcl/doc/design/streams/design.rst ============================================================================== --- (empty file) +++ trunk/abcl/doc/design/streams/design.rst Sat Jan 30 19:06:11 2010 @@ -0,0 +1,44 @@ +============================== +Design of lisp streams in ABCL +============================== + +The previous design +------------------- + +Previously, ABCL streams were built-in classes. This presented some problems for Gray streams, +because ABCL CLOS can't use a built-in class as a base class, and Gray streams derive from +a system-stream class. This was corrected by converting ABCL streams to be structure-objects +instead of built-in classes, allowing CLOS to derive from the streams. There was, however, another +problem that revealed a need to change the design in more drastic ways. + +The problem with the previous design +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +While converting the streams from built-in classes to structure-objects allowed derivation, +the pretty printer still didn't work with Gray streams. Gray streams replace the system stream +functions, saving the old function symbols so that they can be later invoked. The pretty printer, +however, just replaces the stream functions, and calls the low-level primitives directly, thus +bypassing Gray streams completely. The attached image portrays the problem, where pprint will, +for example, invoke %stream-write-char, thus bypassing any methods that there may be for +stream-write-char using Gray streams. + +.. image:: pprint-problem.png + +The planned future design and solution to the problem +----------------------------------------------------- + +The solution to the problem is quite similar to how SBCL does its streams. First of all, the pretty printer will +no longer replace stream functions. The stream functionality will be based on closures in the slots of +the structure-object representing the stream, and those closures will invoke low-level i/o functions that +are stream-specific. + +The pretty printer will just setup closures that will extract the underlying stream +object from a pprint-wrapped stream, and invoke its low-level functions. If pprint wrapping isn't present, +the slots will contain closures that directly invoke low-level functions of streams. Gray streams will +still replace the stream functions, because it's capable of invoking the replaced functions. + +In addition to these changes, it is planned that the stream function primitives will be moved from the Stream +java class to a streamfunctions library, allowing the stream functions to be written in lisp rather than java. +There's an ongoing aspiration to increase the lisp/java code ratio of ABCL, and this new design allows for that. + +.. image:: pprint-solution.png Added: trunk/abcl/doc/design/streams/pprint-problem.dia ============================================================================== --- (empty file) +++ trunk/abcl/doc/design/streams/pprint-problem.dia Sat Jan 30 19:06:11 2010 @@ -0,0 +1,907 @@ + + + + + + + + + + + + + #Letter# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #usercode.lisp# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #pprint.lisp# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #gray-streams.lisp# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #Stream.java (primitives)# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #methods for stream-write-char etc., as allowed by Gray streams# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #%stream-write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #stream-write-char (method call)# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #pprint _always_ calls the +primitives in Stream.java# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #gray streams allow methods# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #If pprint is loaded, gray streams methods won't be called!# + + + + + + + + + + + + + + + + + + + + + Added: trunk/abcl/doc/design/streams/pprint-problem.png ============================================================================== Binary file. No diff available. Added: trunk/abcl/doc/design/streams/pprint-solution.dia ============================================================================== --- (empty file) +++ trunk/abcl/doc/design/streams/pprint-solution.dia Sat Jan 30 19:06:11 2010 @@ -0,0 +1,1614 @@ + + + + + + + + + + + + + #Letter# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #solution to the pprint/gray-streams problem# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #usercode.lisp# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #gray-streams.lisp# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #streamfunctions# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #Stream.java# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #methods for stream-write-char etc., as allowed by Gray streams# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #slots in Stream structure-object# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #pprint.lisp# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #system stream slots# + + + ## + + + ## + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #old-write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #stream-write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #binary-output# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #binary-output# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #binary-output# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #binary-output# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #write-char# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #binary-output# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #primitives move to here from Stream.java# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #gray-streams either calls a method +or a saved streamfunction# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #slots allow for dispatching# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #pprint creates wrapped streams, and sets slots +to contain closures that extract the underlying +stream and invoke Stream.java# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #system slots invoke Stream.java# + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + #Stream.java contains functions that are +overridden in extending Java classes, as before# + + + + + + + + + + + + + + + + + + + + + Added: trunk/abcl/doc/design/streams/pprint-solution.png ============================================================================== Binary file. No diff available. From astalla at common-lisp.net Sun Jan 31 20:13:10 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 31 Jan 2010 15:13:10 -0500 Subject: [armedbear-cvs] r12411 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun Jan 31 15:13:07 2010 New Revision: 12411 Log: Lambda call inlining: fixed nasty bug that made the compiler go into infinite recursion when compiling an invalid lambda call. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Jan 31 15:13:07 2010 @@ -1238,8 +1238,8 @@ (declare (ignorable , at ignorables)) , at body))) (lambda-list-mismatch (x) - (warn "Invalid function call: ~S (mismatch type: ~A)" - form (lambda-list-mismatch-type x)) + (compiler-warn "Invalid function call: ~S (mismatch type: ~A)" + form (lambda-list-mismatch-type x)) form)) (if (unsafe-p args) (let ((arg1 (car args))) @@ -1302,6 +1302,10 @@ (setf (compiland-%single-valued-p *current-compiland*) nil))))) (p1-default form)) +(defun %funcall (fn &rest args) + "Dummy FUNCALL wrapper to force p1 not to optimize the call." + (apply fn args)) + (defknown p1 (t) t) (defun p1 (form) (cond ((symbolp form) @@ -1369,7 +1373,10 @@ (t (p1-function-call form)))) ((and (consp op) (eq (%car op) 'LAMBDA)) - (p1 (rewrite-function-call form))) + (let ((maybe-optimized-call (rewrite-function-call form))) + (if (eq maybe-optimized-call form) + (p1 `(%funcall (function ,op) ,@(cdr form))) + (p1 maybe-optimized-call)))) (t form))))))