From ehuelsmann at common-lisp.net Wed Dec 3 20:38:58 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 03 Dec 2008 20:38:58 +0000 Subject: [armedbear-cvs] r11410 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Dec 3 20:38:57 2008 New Revision: 11410 Log: Fix string out-of-bounds error. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Wed Dec 3 20:38:57 2008 @@ -1933,7 +1933,7 @@ { try { - for (int i = 0; i++ < s.length();) + for (int i = 0; i < s.length(); i++) //###FIXME: the number of writes can be greatly reduced by // writing the space between newlines as chunks. _writeChar(s.charAt(i)); From ehuelsmann at common-lisp.net Wed Dec 3 21:35:51 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 03 Dec 2008 21:35:51 +0000 Subject: [armedbear-cvs] r11411 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Dec 3 21:35:51 2008 New Revision: 11411 Log: Fix eol-style initialization and double-output. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Wed Dec 3 21:35:51 2008 @@ -101,7 +101,7 @@ public final static EolStyle platformEolStyle = Utilities.isPlatformWindows ? EolStyle.CRLF : EolStyle.LF; protected EolStyle eolStyle = platformEolStyle; - protected char eolChar = 0; + protected char eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; protected LispObject externalFormat = LispObject.NIL; protected String encoding = null; @@ -1883,13 +1883,14 @@ try { if (eolStyle != EolStyle.RAW) { - for (int i = start; i++ < end;) + 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]); - } + + } else + writer.write(chars, start, end - start); - writer.write(chars, start, end - start); int index = -1; for (int i = end; i-- > start;) { From vvoutilainen at common-lisp.net Wed Dec 3 22:44:19 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 03 Dec 2008 22:44:19 +0000 Subject: [armedbear-cvs] r11412 - trunk/j/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed Dec 3 22:44:19 2008 New Revision: 11412 Log: Don't generate stack trace information when constructing a ConditionThrowable (or it's descendants, Go/Return/Throw). This makes the aforementioned operations faster. Modified: trunk/j/src/org/armedbear/lisp/ConditionThrowable.java Modified: trunk/j/src/org/armedbear/lisp/ConditionThrowable.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/ConditionThrowable.java (original) +++ trunk/j/src/org/armedbear/lisp/ConditionThrowable.java Wed Dec 3 22:44:19 2008 @@ -40,6 +40,14 @@ public ConditionThrowable() { } + /** + * Overridden in order to make ConditionThrowable construct + * faster. This avoids gathering stack trace information. + */ + public Throwable fillInStackTrace() + { + return this; + } public ConditionThrowable(Condition condition) { From vvoutilainen at common-lisp.net Wed Dec 3 22:52:02 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Wed, 03 Dec 2008 22:52:02 +0000 Subject: [armedbear-cvs] r11413 - trunk/j/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Wed Dec 3 22:52:02 2008 New Revision: 11413 Log: Add override annotation for fillInStackTrace. Modified: trunk/j/src/org/armedbear/lisp/ConditionThrowable.java Modified: trunk/j/src/org/armedbear/lisp/ConditionThrowable.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/ConditionThrowable.java (original) +++ trunk/j/src/org/armedbear/lisp/ConditionThrowable.java Wed Dec 3 22:52:02 2008 @@ -44,6 +44,7 @@ * Overridden in order to make ConditionThrowable construct * faster. This avoids gathering stack trace information. */ + @Override public Throwable fillInStackTrace() { return this; From ehuelsmann at common-lisp.net Thu Dec 4 19:19:10 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Dec 2008 19:19:10 +0000 Subject: [armedbear-cvs] r11414 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 4 19:19:09 2008 New Revision: 11414 Log: Un-duplicate Stream and FileStream implementations. Patch by: Hideo at Yokohama Tweaked by: me Modified: branches/open-external-format/src/org/armedbear/lisp/FileStream.java branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/FileStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/FileStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/FileStream.java Thu Dec 4 19:19:09 2008 @@ -49,10 +49,6 @@ private final RandomAccessCharacterFile racf; private final Pathname pathname; private final int bytesPerUnit; - private InputStream inst; - private OutputStream outst; - private Reader reader; - private Writer writer; public FileStream(Pathname pathname, String namestring, LispObject elementType, LispObject direction, @@ -113,10 +109,10 @@ isCharacterStream = true; bytesPerUnit = 1; if (isInputStream) { - reader = racf.getReader(); + initAsCharacterInputStream(racf.getReader()); } if (isOutputStream) { - writer = racf.getWriter(); + initAsCharacterOutputStream(racf.getWriter()); } } else { isBinaryStream = true; @@ -129,10 +125,10 @@ } bytesPerUnit = width / 8; if (isInputStream) { - inst = racf.getInputStream(); + initAsBinaryInputStream(racf.getInputStream()); } if (isOutputStream) { - outst = racf.getOutputStream(); + initAsBinaryOutputStream(racf.getOutputStream()); } } } @@ -165,23 +161,6 @@ } @Override - public LispObject listen() throws ConditionThrowable - { - try { - if (isInputStream) { - return (racf.position() < racf.length()) ? T : NIL; - } else { - streamNotInputStream(); - } - } - catch (IOException e) { - error(new StreamError(this, e)); - } - // Not reached. - return NIL; - } - - @Override public LispObject fileLength() throws ConditionThrowable { final long length; @@ -209,44 +188,6 @@ return number(length / bytesPerUnit); } - // Returns -1 at end of file. - @Override - protected int _readChar() throws ConditionThrowable - { - try { - int c = reader.read(); - if (eolStyle == EolStyle.CRLF) { - if (c == '\r') { - int c2 = reader.read(); - if (c2 == '\n') { - ++lineNumber; - return c2; - } else { - // '\r' was not followed by '\n' - // we cannot depend on characters to contain 1 byte only - // so we need to revert to the last known position. - // The classical use case for unreadChar - racf.unreadChar((char)c2); - } - } - return c; - } else if (c == eolChar) { - ++lineNumber; - return c; - } else { - return c; - } - } - catch (NullPointerException e) { - streamNotInputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - // Not reached. - return -1; - } - @Override protected void _unreadChar(int n) throws ConditionThrowable { @@ -265,129 +206,6 @@ } @Override - public void _writeChar(char c) throws ConditionThrowable - { - try { - if (c == '\n') { - if (eolStyle == EolStyle.CRLF) - writer.write('\r'); - writer.write(eolChar); - charPos = 0; - } else { - writer.write(c); - ++charPos; - } - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - - @Override - public void _writeChars(char[] chars, int start, int end) - throws ConditionThrowable { - _writeChars(chars, start, end, true); - } - - public void _writeChars(char[] chars, int start, int end, boolean maintainCharPos) - throws ConditionThrowable - { - try { - if (eolStyle == EolStyle.LF) { - /* we can do a little bit better in this special case */ - writer.write(chars, start, end); - if (maintainCharPos) { - int lastlfpos = -1; - for (int i = start; i < end; i++) { - if (chars[i] == '\n') { - lastlfpos = i; - } - } - if (lastlfpos == -1) { - charPos += end - start; - } else { - charPos = end - lastlfpos; - } - } - } else if (eolStyle == EolStyle.CRLF) { - for (int i = start; i < end; i++) { - char c = chars[i]; - if (c == '\n') { - writer.write('\r'); - writer.write('\n'); - charPos = 0; - } else { - writer.write(c); - ++charPos; - } - } - } else { - for (int i = start; i < end; i++) { - char c = chars[i]; - if (c == '\n') { - writer.write(eolChar); - charPos = 0; - } else { - writer.write(c); - ++charPos; - } - } - } - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - - @Override - public void _writeString(String s) throws ConditionThrowable - { - _writeChars(s.toCharArray(), 0, s.length(), true); - } - - @Override - public void _writeLine(String s) throws ConditionThrowable - { - _writeChars(s.toCharArray(), 0, s.length(), false); - if (eolStyle == EolStyle.CRLF) - _writeChar('\r'); - _writeChar(eolChar); - charPos = 0; - } - - // Reads an 8-bit byte. - @Override - public int _readByte() throws ConditionThrowable - { - try { - return inst.read(); // Reads an 8-bit byte. - } - catch (NullPointerException e) { - streamNotInputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - // Not reached. - return -1; - } - - // Writes an 8-bit byte. - @Override - public void _writeByte(int n) throws ConditionThrowable - { - try { - outst.write(n); // Writes an 8-bit byte. - } - catch (NullPointerException e) { - streamNotOutputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - - @Override public void _clearInput() throws ConditionThrowable { try { Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Thu Dec 4 19:19:09 2008 @@ -43,6 +43,7 @@ import java.io.OutputStreamWriter; import java.io.PrintWriter; import java.io.PushbackReader; +import java.io.Reader; import java.io.StringWriter; import java.io.Writer; import java.math.BigInteger; @@ -66,7 +67,8 @@ private boolean open = true; // Character input. - private PushbackReader reader; + private Reader reader; + private PushbackReader pushbackReader; protected int offset; protected int lineNumber; @@ -106,18 +108,32 @@ protected String encoding = null; // Binary input. - private BufferedInputStream in; + private InputStream in; // Binary output. - private BufferedOutputStream out; + private OutputStream out; + + // end of line character sequence. + private char[] eolseq; + + private void setEolSeq() { + if (eolStyle == EolStyle.CRLF) { + eolseq = new char[] { '\r', '\n' }; + } else if (eolStyle == EolStyle.CR) { + eolseq = new char[] { '\r' }; + } else { + eolseq = new char[] { '\n' }; + } + } protected Stream() { + setEolSeq(); } public Stream(InputStream inputStream, LispObject elementType) { - this(inputStream, elementType, null); + this(inputStream, elementType, null); } @@ -127,7 +143,6 @@ this.elementType = elementType; if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - isCharacterStream = true; InputStreamReader inputStreamReader; try { @@ -142,16 +157,17 @@ inputStreamReader = new InputStreamReader(inputStream); } - reader = new PushbackReader(new BufferedReader(inputStreamReader), - 2); + pushbackReader = new PushbackReader(new BufferedReader(inputStreamReader), + 2); + initAsCharacterInputStream(pushbackReader); } else { isBinaryStream = true; - in = new BufferedInputStream(inputStream); + InputStream in = new BufferedInputStream(inputStream); + initAsBinaryInputStream(in); } - isInputStream = true; - isOutputStream = false; + setEolSeq(); } public Stream(InputStream inputStream, LispObject elementType, boolean interactive) @@ -162,7 +178,7 @@ public Stream(OutputStream outputStream, LispObject elementType) { - this(outputStream, elementType, null); + this(outputStream, elementType, null); } // Output stream constructors. @@ -171,7 +187,7 @@ this.elementType = elementType; if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - isCharacterStream = true; + Writer writer; try { writer = (encoding == null) ? @@ -183,14 +199,14 @@ Debug.trace(e); writer = new OutputStreamWriter(outputStream); } + initAsCharacterOutputStream(writer); } else { - isBinaryStream = true; - out = new BufferedOutputStream(outputStream); + OutputStream out = new BufferedOutputStream(outputStream); + initAsBinaryOutputStream(out); } - isInputStream = false; - isOutputStream = true; + setEolSeq(); } public Stream(OutputStream outputStream, LispObject elementType, @@ -200,6 +216,31 @@ setInteractive(interactive); } + protected void initAsCharacterInputStream(Reader reader) + { + this.reader = reader; + isInputStream = true; + isCharacterStream = true; + } + + protected void initAsBinaryInputStream(InputStream in) { + this.in = in; + isInputStream = true; + isBinaryStream = true; + } + + protected void initAsCharacterOutputStream(Writer writer) { + this.writer = writer; + isOutputStream = true; + isCharacterStream = true; + } + + protected void initAsBinaryOutputStream(OutputStream out) { + this.out = out; + isOutputStream = true; + isBinaryStream = true; + } + public boolean isInputStream() throws ConditionThrowable { return isInputStream; @@ -254,7 +295,7 @@ eolStyle = platformEolStyle; eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; externalFormat = format; - + setEolSeq(); return; } @@ -1797,7 +1838,7 @@ { try { - reader.unread(n); + pushbackReader.unread(n); --offset; if (n == eolChar) --lineNumber; @@ -1848,9 +1889,7 @@ try { if (c == '\n') { - if (eolStyle == EolStyle.CRLF) - writer.write('\r'); - writer.write(eolChar); + writer.write(eolseq); writer.flush(); charPos = 0; } else { @@ -1898,19 +1937,19 @@ { index = i; break; - } - } + } + } if (index < 0) { // No newline. charPos += (end - start); - } + } else { charPos = end - (index + 1); writer.flush(); - } - } + } + } catch (NullPointerException e) { if (writer == null) @@ -1934,10 +1973,7 @@ { try { - for (int i = 0; i < s.length(); i++) - //###FIXME: the number of writes can be greatly reduced by - // writing the space between newlines as chunks. - _writeChar(s.charAt(i)); + _writeChars(s.toCharArray(), 0, s.length()); } catch (NullPointerException e) { From ehuelsmann at common-lisp.net Thu Dec 4 23:02:21 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Dec 2008 23:02:21 +0000 Subject: [armedbear-cvs] r11415 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 4 23:02:20 2008 New Revision: 11415 Log: Support EXTERNAL-FORMAT for socket streams. Found by: Hideo at Yokohama Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java branches/open-external-format/src/org/armedbear/lisp/socket.lisp branches/open-external-format/src/org/armedbear/lisp/socket_stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Thu Dec 4 23:02:20 2008 @@ -113,34 +113,21 @@ // Binary output. private OutputStream out; - // end of line character sequence. - private char[] eolseq; - - private void setEolSeq() { - if (eolStyle == EolStyle.CRLF) { - eolseq = new char[] { '\r', '\n' }; - } else if (eolStyle == EolStyle.CR) { - eolseq = new char[] { '\r' }; - } else { - eolseq = new char[] { '\n' }; - } - } - protected Stream() { - setEolSeq(); } public Stream(InputStream inputStream, LispObject elementType) { - this(inputStream, elementType, null); + this(inputStream, elementType, keywordDefault); } // Input stream constructors. - public Stream(InputStream inputStream, LispObject elementType, String encoding) + public Stream(InputStream inputStream, LispObject elementType, LispObject format) { this.elementType = elementType; + setExternalFormat(format); if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { InputStreamReader inputStreamReader; @@ -167,7 +154,6 @@ InputStream in = new BufferedInputStream(inputStream); initAsBinaryInputStream(in); } - setEolSeq(); } public Stream(InputStream inputStream, LispObject elementType, boolean interactive) @@ -178,13 +164,14 @@ public Stream(OutputStream outputStream, LispObject elementType) { - this(outputStream, elementType, null); + this(outputStream, elementType, keywordDefault); } // Output stream constructors. - public Stream(OutputStream outputStream, LispObject elementType, String encoding) + public Stream(OutputStream outputStream, LispObject elementType, LispObject format) { this.elementType = elementType; + setExternalFormat(format); if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { Writer writer; @@ -206,7 +193,6 @@ OutputStream out = new BufferedOutputStream(outputStream); initAsBinaryOutputStream(out); } - setEolSeq(); } public Stream(OutputStream outputStream, LispObject elementType, @@ -295,7 +281,6 @@ eolStyle = platformEolStyle; eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; externalFormat = format; - setEolSeq(); return; } @@ -1890,7 +1875,7 @@ { if (c == '\n') { writer.write(eolseq); - writer.flush(); + writer.flush(); charPos = 0; } else { writer.write(c); @@ -1928,7 +1913,7 @@ _writeChar(chars[i]); } else - writer.write(chars, start, end - start); + writer.write(chars, start, end - start); int index = -1; for (int i = end; i-- > start;) @@ -1947,7 +1932,7 @@ else { charPos = end - (index + 1); - writer.flush(); + writer.flush(); } } catch (NullPointerException e) Modified: branches/open-external-format/src/org/armedbear/lisp/socket.lisp ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/socket.lisp (original) +++ branches/open-external-format/src/org/armedbear/lisp/socket.lisp Thu Dec 4 23:02:20 2008 @@ -31,15 +31,16 @@ (in-package "SYSTEM") -(defun get-socket-stream (socket &key (element-type 'character)) - ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER." +(defun get-socket-stream (socket &key (element-type 'character) (external-format :default)) + ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. +EXTERNAL-FORMAT must be of the same format as specified for OPEN." (cond ((eq element-type 'character)) ((equal element-type '(unsigned-byte 8))) (t (error 'simple-type-error :format-control ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8)."))) - (%socket-stream socket element-type)) + (%socket-stream socket element-type external-format)) (defun make-socket (host port) (%make-socket host port)) Modified: branches/open-external-format/src/org/armedbear/lisp/socket_stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/socket_stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/socket_stream.java Thu Dec 4 23:02:20 2008 @@ -40,19 +40,19 @@ { private socket_stream() { - super("%socket-stream", PACKAGE_SYS, false, "socket element-type"); + super("%socket-stream", PACKAGE_SYS, false, "socket element-type external-format"); } - public LispObject execute(LispObject first, LispObject second) + public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { Socket socket = (Socket) ((JavaObject)first).getObject(); LispObject elementType = second; // Checked by caller. try { Stream in = - new Stream(socket.getInputStream(), elementType); + new Stream(socket.getInputStream(), elementType, third); Stream out = - new Stream(socket.getOutputStream(), elementType); + new Stream(socket.getOutputStream(), elementType, third); return new SocketStream(socket, in, out); } catch (Exception e) { From ehuelsmann at common-lisp.net Thu Dec 4 23:08:20 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Dec 2008 23:08:20 +0000 Subject: [armedbear-cvs] r11416 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 4 23:08:19 2008 New Revision: 11416 Log: Fix partially-reverted change: remove eolseq. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Thu Dec 4 23:08:19 2008 @@ -1874,8 +1874,12 @@ try { if (c == '\n') { - writer.write(eolseq); - writer.flush(); + if (eolStyle == EolStyle.CRLF) + writer.write("\r\n"); + else + writer.write(eolChar); + + writer.flush(); charPos = 0; } else { writer.write(c); From ehuelsmann at common-lisp.net Thu Dec 4 23:17:46 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 04 Dec 2008 23:17:46 +0000 Subject: [armedbear-cvs] r11417 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 4 23:17:46 2008 New Revision: 11417 Log: Rename variables shadowing fields. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Thu Dec 4 23:17:46 2008 @@ -151,8 +151,8 @@ else { isBinaryStream = true; - InputStream in = new BufferedInputStream(inputStream); - initAsBinaryInputStream(in); + InputStream stream = new BufferedInputStream(inputStream); + initAsBinaryInputStream(stream); } } @@ -174,24 +174,24 @@ setExternalFormat(format); if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - Writer writer; + Writer w; try { - writer = (encoding == null) ? + w = (encoding == null) ? new OutputStreamWriter(outputStream) : new OutputStreamWriter(outputStream, encoding); } catch (java.io.UnsupportedEncodingException e) { Debug.trace(e); - writer = new OutputStreamWriter(outputStream); + w = new OutputStreamWriter(outputStream); } - initAsCharacterOutputStream(writer); + initAsCharacterOutputStream(w); } else { - OutputStream out = new BufferedOutputStream(outputStream); - initAsBinaryOutputStream(out); + OutputStream stream = new BufferedOutputStream(outputStream); + initAsBinaryOutputStream(stream); } } From ehuelsmann at common-lisp.net Fri Dec 5 21:19:39 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 05 Dec 2008 21:19:39 +0000 Subject: [armedbear-cvs] r11418 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 5 21:19:37 2008 New Revision: 11418 Log: Add @Override modifiers before (possibly) editing these files. Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Fri Dec 5 21:19:37 2008 @@ -62,16 +62,19 @@ offset = start; } + @Override public LispObject typeOf() { return Symbol.STRING_INPUT_STREAM; } + @Override public LispObject classOf() { return BuiltInClass.STRING_INPUT_STREAM; } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.STRING_INPUT_STREAM) @@ -85,28 +88,32 @@ return super.typep(type); } + @Override public LispObject close(LispObject abort) throws ConditionThrowable { setOpen(false); return T; } + @Override public LispObject listen() { return offset < end ? T : NIL; } + @Override protected int _readChar() { if (offset >= end) return -1; int n = s.charAt(offset); ++offset; - if (n == '\n') + if (n == '\n') ++lineNumber; return n; } + @Override protected void _unreadChar(int n) { if (offset > start) { @@ -116,11 +123,13 @@ } } + @Override protected boolean _charReady() { return true; } + @Override public String toString() { return unreadableString("STRING-INPUT-STREAM"); @@ -131,11 +140,13 @@ private static final Primitive MAKE_STRING_INPUT_STREAM = new Primitive("make-string-input-stream", "string &optional start end") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { return new StringInputStream(arg.getStringValue()); } + @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { @@ -144,6 +155,7 @@ return new StringInputStream(s, start); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -161,6 +173,7 @@ private static final Primitive STRING_INPUT_STREAM_CURRENT = new Primitive("string-input-stream-current", PACKAGE_EXT, true, "stream") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { if (arg instanceof StringInputStream) Modified: branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Fri Dec 5 21:19:37 2008 @@ -54,16 +54,19 @@ setWriter(stringWriter = new StringWriter()); } + @Override public LispObject typeOf() { return Symbol.STRING_OUTPUT_STREAM; } + @Override public LispObject classOf() { return BuiltInClass.STRING_OUTPUT_STREAM; } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.STRING_OUTPUT_STREAM) @@ -77,6 +80,7 @@ return super.typep(type); } + @Override public void _writeChar(char c) throws ConditionThrowable { if (elementType == NIL) @@ -84,6 +88,7 @@ super._writeChar(c); } + @Override public void _writeChars(char[] chars, int start, int end) throws ConditionThrowable { @@ -92,6 +97,7 @@ super._writeChars(chars, start, end); } + @Override public void _writeString(String s) throws ConditionThrowable { if (elementType == NIL) @@ -99,6 +105,7 @@ super._writeString(s); } + @Override public void _writeLine(String s) throws ConditionThrowable { if (elementType == NIL) @@ -111,6 +118,7 @@ error(new TypeError("Attempt to write to a string output stream of element type NIL.")); } + @Override protected long _getFilePosition() throws ConditionThrowable { if (elementType == NIL) @@ -128,6 +136,7 @@ return s; } + @Override public String toString() { return unreadableString("STRING-OUTPUT-STREAM"); @@ -139,6 +148,7 @@ new Primitive("%make-string-output-stream", PACKAGE_SYS, false, "element-type") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { return new StringOutputStream(arg); @@ -150,6 +160,7 @@ private static final Primitive GET_OUTPUT_STREAM_STRING = new Primitive("get-output-stream-string", "string-output-stream") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { try { From ehuelsmann at common-lisp.net Fri Dec 5 22:58:22 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 05 Dec 2008 22:58:22 +0000 Subject: [armedbear-cvs] r11419 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 5 22:58:19 2008 New Revision: 11419 Log: Make one variable out of reader and pushbackReader: they need to point to the exact same stream anyway. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Fri Dec 5 22:58:19 2008 @@ -67,8 +67,7 @@ private boolean open = true; // Character input. - private Reader reader; - private PushbackReader pushbackReader; + private PushbackReader reader; protected int offset; protected int lineNumber; @@ -89,7 +88,7 @@ LF } - static final private Symbol keywordDefault = Packages.internKeyword("DEFAULT"); + static final protected Symbol keywordDefault = Packages.internKeyword("DEFAULT"); static final private Symbol keywordCodePage = Packages.internKeyword("CODE-PAGE"); static final private Symbol keywordID = Packages.internKeyword("ID"); @@ -106,6 +105,7 @@ protected char eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; protected LispObject externalFormat = LispObject.NIL; protected String encoding = null; + protected char lastChar = 0; // Binary input. private InputStream in; @@ -144,9 +144,7 @@ inputStreamReader = new InputStreamReader(inputStream); } - pushbackReader = new PushbackReader(new BufferedReader(inputStreamReader), - 2); - initAsCharacterInputStream(pushbackReader); + initAsCharacterInputStream(new BufferedReader(inputStreamReader)); } else { @@ -204,7 +202,11 @@ protected void initAsCharacterInputStream(Reader reader) { - this.reader = reader; + if (! (reader instanceof PushbackReader)) + this.reader = new PushbackReader(reader, 2); + else + this.reader = (PushbackReader)reader; + isInputStream = true; isCharacterStream = true; } @@ -1823,7 +1825,7 @@ { try { - pushbackReader.unread(n); + reader.unread(n); --offset; if (n == eolChar) --lineNumber; @@ -1874,15 +1876,16 @@ try { if (c == '\n') { - if (eolStyle == EolStyle.CRLF) - writer.write("\r\n"); - else - writer.write(eolChar); - + 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; } } @@ -1915,10 +1918,11 @@ //###FIXME: the number of writes can be greatly reduced by // writing the space between newlines as chunks. _writeChar(chars[i]); - - } else - writer.write(chars, start, end - start); + return; + } + writer.write(chars, start, end - start); + lastChar = chars[end-1]; int index = -1; for (int i = end; i-- > start;) { @@ -2137,6 +2141,7 @@ { writer.write(sw.toString()); writer.write('\n'); + lastChar = '\n'; writer.flush(); charPos = 0; } From ehuelsmann at common-lisp.net Fri Dec 5 23:28:58 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 05 Dec 2008 23:28:58 +0000 Subject: [armedbear-cvs] r11420 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 5 23:28:55 2008 New Revision: 11420 Log: Cleanup: with the right initialization, we can reuse most of the code in the superclass. Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Fri Dec 5 23:28:55 2008 @@ -33,12 +33,17 @@ package org.armedbear.lisp; +import java.io.IOException; +import java.io.StringReader; + public final class StringInputStream extends Stream { final String s; final int start; final int end; + private final StringReader stringReader; + public StringInputStream(String s) { this(s, 0, s.length()); @@ -52,14 +57,13 @@ public StringInputStream(String s, int start, int end) { elementType = Symbol.CHARACTER; - isInputStream = true; - isOutputStream = false; - isCharacterStream = true; - isBinaryStream = false; + setExternalFormat(keywordDefault); this.s = s; this.start = start; this.end = end; - offset = start; + + stringReader = new StringReader(s.substring(start, end)); + initAsCharacterInputStream(stringReader); } @Override @@ -89,41 +93,6 @@ } @Override - public LispObject close(LispObject abort) throws ConditionThrowable - { - setOpen(false); - return T; - } - - @Override - public LispObject listen() - { - return offset < end ? T : NIL; - } - - @Override - protected int _readChar() - { - if (offset >= end) - return -1; - int n = s.charAt(offset); - ++offset; - if (n == '\n') - ++lineNumber; - return n; - } - - @Override - protected void _unreadChar(int n) - { - if (offset > start) { - --offset; - if (n == '\n') - --lineNumber; - } - } - - @Override protected boolean _charReady() { return true; Modified: branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Fri Dec 5 23:28:55 2008 @@ -47,11 +47,7 @@ private StringOutputStream(LispObject elementType) { this.elementType = elementType; - isInputStream = false; - isOutputStream = true; - isCharacterStream = true; - isBinaryStream = false; - setWriter(stringWriter = new StringWriter()); + initAsCharacterOutputStream(stringWriter = new StringWriter()); } @Override @@ -81,44 +77,6 @@ } @Override - public void _writeChar(char c) throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeChar(c); - } - - @Override - public void _writeChars(char[] chars, int start, int end) - throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeChars(chars, start, end); - } - - @Override - public void _writeString(String s) throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeString(s); - } - - @Override - public void _writeLine(String s) throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeLine(s); - } - - private void writeError() throws ConditionThrowable - { - error(new TypeError("Attempt to write to a string output stream of element type NIL.")); - } - - @Override protected long _getFilePosition() throws ConditionThrowable { if (elementType == NIL) From ehuelsmann at common-lisp.net Fri Dec 5 23:31:20 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 05 Dec 2008 23:31:20 +0000 Subject: [armedbear-cvs] r11421 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 5 23:31:18 2008 New Revision: 11421 Log: Remove unused import. Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Fri Dec 5 23:31:18 2008 @@ -33,7 +33,6 @@ package org.armedbear.lisp; -import java.io.IOException; import java.io.StringReader; public final class StringInputStream extends Stream From ehuelsmann at common-lisp.net Sat Dec 6 12:16:02 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 12:16:02 +0000 Subject: [armedbear-cvs] r11422 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 12:16:01 2008 New Revision: 11422 Log: Fix CLEAR-INPUT tests. * Stream.java:Stream::_clearInput(): Check for end-of-stream (-1) return value in _readChar(). * Stream.java:Stream::reader: make protected so that it becomes available to subclasses. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Sat Dec 6 12:16:01 2008 @@ -65,9 +65,9 @@ private boolean interactive; private boolean open = true; - + // Character input. - private PushbackReader reader; + protected PushbackReader reader; protected int offset; protected int lineNumber; @@ -2068,8 +2068,9 @@ { if (reader != null) { - while (_charReady()) - _readChar(); + int c = 0; + while (_charReady() && (c >= 0)) + c = _readChar(); } else if (in != null) { From ehuelsmann at common-lisp.net Sat Dec 6 13:12:47 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 13:12:47 +0000 Subject: [armedbear-cvs] r11423 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 13:12:46 2008 New Revision: 11423 Log: More code re-use. Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Sat Dec 6 13:12:46 2008 @@ -92,12 +92,6 @@ } @Override - protected boolean _charReady() - { - return true; - } - - @Override public String toString() { return unreadableString("STRING-INPUT-STREAM"); From ehuelsmann at common-lisp.net Sat Dec 6 13:18:52 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 13:18:52 +0000 Subject: [armedbear-cvs] r11424 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 13:18:52 2008 New Revision: 11424 Log: Remove redundant variables. Found by: Douglas Miles Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Sat Dec 6 13:18:52 2008 @@ -37,10 +37,6 @@ public final class StringInputStream extends Stream { - final String s; - final int start; - final int end; - private final StringReader stringReader; public StringInputStream(String s) @@ -57,9 +53,6 @@ { elementType = Symbol.CHARACTER; setExternalFormat(keywordDefault); - this.s = s; - this.start = start; - this.end = end; stringReader = new StringReader(s.substring(start, end)); initAsCharacterInputStream(stringReader); From ehuelsmann at common-lisp.net Sat Dec 6 14:00:45 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 14:00:45 +0000 Subject: [armedbear-cvs] r11425 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 14:00:44 2008 New Revision: 11425 Log: Fix most reader test failures: don't increment the current position if we're past the end of our input stream. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Sat Dec 6 14:00:44 2008 @@ -1787,6 +1787,10 @@ try { int n = reader.read(); + + if (n < 0) + return -1; + ++offset; if (eolStyle == EolStyle.CRLF && n == '\r') { n = _readChar(); From ehuelsmann at common-lisp.net Sat Dec 6 14:18:06 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 14:18:06 +0000 Subject: [armedbear-cvs] r11426 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 14:18:06 2008 New Revision: 11426 Log: Make sure we don't write more characters to the string than requested: no eol translation for strings. Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Sat Dec 6 14:18:06 2008 @@ -53,7 +53,9 @@ { elementType = Symbol.CHARACTER; setExternalFormat(keywordDefault); - + //###FIXME: we actually want RAW here + eolStyle = EolStyle.LF; + stringReader = new StringReader(s.substring(start, end)); initAsCharacterInputStream(stringReader); } Modified: branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Sat Dec 6 14:18:06 2008 @@ -47,6 +47,8 @@ private StringOutputStream(LispObject elementType) { this.elementType = elementType; + //###FIXME we actually want RAW here + this.eolStyle = EolStyle.LF; initAsCharacterOutputStream(stringWriter = new StringWriter()); } @@ -81,7 +83,7 @@ { if (elementType == NIL) return 0; - return stringWriter.toString().length(); + return stringWriter.getBuffer().length(); } public LispObject getString() throws ConditionThrowable From ehuelsmann at common-lisp.net Sat Dec 6 18:45:07 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 18:45:07 +0000 Subject: [armedbear-cvs] r11427 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 18:45:06 2008 New Revision: 11427 Log: Fix STRING-INPUT-STREAM GET-OFFSET with non-zero :start offset. Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Sat Dec 6 18:45:06 2008 @@ -38,6 +38,7 @@ public final class StringInputStream extends Stream { private final StringReader stringReader; + private final int start; public StringInputStream(String s) { @@ -56,6 +57,8 @@ //###FIXME: we actually want RAW here eolStyle = EolStyle.LF; + this.start = start; + stringReader = new StringReader(s.substring(start, end)); initAsCharacterInputStream(stringReader); } @@ -92,6 +95,11 @@ return unreadableString("STRING-INPUT-STREAM"); } + @Override + public int getOffset() { + return start + super.getOffset(); + } + // ### make-string-input-stream // make-string-input-stream string &optional start end => string-stream private static final Primitive MAKE_STRING_INPUT_STREAM = From ehuelsmann at common-lisp.net Sat Dec 6 19:33:15 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 19:33:15 +0000 Subject: [armedbear-cvs] r11428 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 19:33:15 2008 New Revision: 11428 Log: Fix LISTEN.1 and LISTEN.3 by checking if a character can actually be read from the input stream, or whether it may be EOF. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Sat Dec 6 19:33:15 2008 @@ -63,6 +63,7 @@ protected boolean isCharacterStream; protected boolean isBinaryStream; + private boolean pastEnd = false; private boolean interactive; private boolean open = true; @@ -203,7 +204,7 @@ protected void initAsCharacterInputStream(Reader reader) { if (! (reader instanceof PushbackReader)) - this.reader = new PushbackReader(reader, 2); + this.reader = new PushbackReader(reader, 5); else this.reader = (PushbackReader)reader; @@ -1736,7 +1737,19 @@ public LispObject listen() throws ConditionThrowable { - return _charReady() ? T : NIL; + if (pastEnd) + return NIL; + + if (! _charReady()) + return NIL; + + int n = _readChar(); + if (n < 0) + return NIL; + + _unreadChar(n); + + return T; } public LispObject fileLength() throws ConditionThrowable @@ -1784,12 +1797,17 @@ */ protected int _readChar() throws ConditionThrowable { + if (pastEnd) + return -1; + try { int n = reader.read(); - if (n < 0) + if (n < 0) { + pastEnd = true; return -1; + } ++offset; if (eolStyle == EolStyle.CRLF && n == '\r') { @@ -2011,7 +2029,11 @@ { try { - return in.read(); // Reads an 8-bit byte. + int n = in.read(); + if (n < 0) + pastEnd = true; + + return n; // Reads an 8-bit byte. } catch (IOException e) { @@ -2080,8 +2102,12 @@ { try { + int n = 0; while (in.available() > 0) - in.read(); + n = in.read(); + + if (n < 0) + pastEnd = true; } catch (IOException e) { From ehuelsmann at common-lisp.net Sat Dec 6 19:44:21 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 19:44:21 +0000 Subject: [armedbear-cvs] r11429 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 19:44:21 2008 New Revision: 11429 Log: Fix LISTEN.6. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Sat Dec 6 19:44:21 2008 @@ -1849,6 +1849,7 @@ { reader.unread(n); --offset; + pastEnd = false; if (n == eolChar) --lineNumber; } From ehuelsmann at common-lisp.net Sat Dec 6 21:13:52 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 06 Dec 2008 21:13:52 +0000 Subject: [armedbear-cvs] r11430 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 6 21:13:50 2008 New Revision: 11430 Log: Resolve 2 FIXMEs. * Stream.java:Stream::_writeChars(): Don't try to access characters before 'start'. * StringInputStream.java:StringInputStream(), * StringOutputStream.java:StringOutputStream(): Use RAW eol style, as per the FIXME. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Sat Dec 6 21:13:50 2008 @@ -1945,7 +1945,9 @@ } writer.write(chars, start, end - start); - lastChar = chars[end-1]; + if (start < end) + lastChar = chars[end-1]; + int index = -1; for (int i = end; i-- > start;) { Modified: branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringInputStream.java Sat Dec 6 21:13:50 2008 @@ -54,8 +54,7 @@ { elementType = Symbol.CHARACTER; setExternalFormat(keywordDefault); - //###FIXME: we actually want RAW here - eolStyle = EolStyle.LF; + eolStyle = EolStyle.RAW; this.start = start; Modified: branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/StringOutputStream.java Sat Dec 6 21:13:50 2008 @@ -47,8 +47,7 @@ private StringOutputStream(LispObject elementType) { this.elementType = elementType; - //###FIXME we actually want RAW here - this.eolStyle = EolStyle.LF; + this.eolStyle = EolStyle.RAW; initAsCharacterOutputStream(stringWriter = new StringWriter()); } From ehuelsmann at common-lisp.net Sun Dec 7 07:39:57 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 07 Dec 2008 07:39:57 +0000 Subject: [armedbear-cvs] r11431 - branches/open-external-format/src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sun Dec 7 07:39:54 2008 New Revision: 11431 Log: RandomAccessCharacterFile should implement its reader as a decendant from PushbackReader, because we don't want Stream to wrap the reader in another PushbackReader. And while we're at it: do the same to the input stream. Modified: branches/open-external-format/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Modified: branches/open-external-format/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/util/RandomAccessCharacterFile.java Sun Dec 7 07:39:54 2008 @@ -35,10 +35,12 @@ package org.armedbear.lisp.util; import java.io.IOException; -import java.io.InputStream; +import java.io.PushbackInputStream; import java.io.OutputStream; import java.io.RandomAccessFile; +import java.io.PushbackReader; import java.io.Reader; +import java.io.StringReader; import java.io.Writer; import java.nio.ByteBuffer; import java.nio.CharBuffer; @@ -50,19 +52,21 @@ public class RandomAccessCharacterFile { - private class RandomAccessInputStream extends InputStream { + private class RandomAccessInputStream extends PushbackInputStream { - private RandomAccessInputStream() { - } - - private byte[] buf = new byte[1]; + public RandomAccessInputStream() { + super(null); + } + + private byte[] read_buf = new byte[1]; + @Override public int read() throws IOException { - int len = read(buf); + int len = read(read_buf); if (len == 1) { // byte is signed, char is unsigned, int is signed. // buf can hold 0xff, we want it as 0xff in int, not -1. - return 0xff & (int) buf[0]; + return 0xff & (int) read_buf[0]; } else { return -1; } @@ -73,6 +77,53 @@ return RandomAccessCharacterFile.this.read(b, off, len); } + @Override + public void unread(int b) throws IOException { + RandomAccessCharacterFile.this.unreadByte((byte)b); + } + + @Override + public void unread(byte[] b, int off, int len) throws IOException { + for (int i = 0; i < len; i++) + this.unread(b[off+i]); + } + + @Override + public void unread(byte[] b) throws IOException { + this.unread(b, 0, b.length); + } + + @Override + public int available() throws IOException { + return (int)(RandomAccessCharacterFile.this.length() + - RandomAccessCharacterFile.this.position()); + } + + @Override + public synchronized void mark(int readlimit) { + } + + @Override + public boolean markSupported() { + return false; + } + + @Override + public synchronized void reset() throws IOException { + throw new IOException("Operation not supported"); + } + + @Override + public long skip(long n) throws IOException { + RandomAccessCharacterFile.this.position(RandomAccessCharacterFile.this.position()+n); + return n; + } + + @Override + public int read(byte[] b) throws IOException { + return this.read(b, 0, b.length); + } + @Override public void close() throws IOException { RandomAccessCharacterFile.this.close(); @@ -105,18 +156,67 @@ RandomAccessCharacterFile.this.close(); } } - - private class RandomAccessReader extends Reader { + + // dummy reader which we need to call the Pushback constructor + // because a null value won't work + private static Reader staticReader = new StringReader(""); + + private class RandomAccessReader extends PushbackReader { private RandomAccessReader() { + // because we override all methods of Pushbackreader, + // staticReader will never be referenced + super(staticReader); } + @Override public void close() throws IOException { RandomAccessCharacterFile.this.close(); } + + private char[] read_buf = new char[1]; + @Override + public int read() throws IOException { + int n = this.read(read_buf); + + if (n == 1) + return read_buf[0]; + else + return -1; + } + + @Override + public void unread(int c) throws IOException { + RandomAccessCharacterFile.this.unreadChar((char)c); + } + + @Override + public void unread(char[] cbuf, int off, int len) throws IOException { + for (int i = 0; i < len; i++) + this.unread(cbuf[off+i]); + } + + @Override + public void unread(char[] cbuf) throws IOException { + this.unread(cbuf, 0, cbuf.length); + } + + @Override + public int read(CharBuffer target) throws IOException { + //FIXME: to be implemented + throw new IOException("Not implemented"); + } + + @Override + public int read(char[] cbuf) throws IOException { + return RandomAccessCharacterFile.this.read(cbuf, 0, cbuf.length); + } + + + @Override - public int read(char[] cb, int off, int len) throws IOException { + public int read(char[] cb, int off, int len) throws IOException { return RandomAccessCharacterFile.this.read(cb, off, len); } } @@ -198,11 +298,11 @@ return writer; } - public Reader getReader() { + public PushbackReader getReader() { return reader; } - public InputStream getInputStream() { + public PushbackInputStream getInputStream() { return inputStream; } From ehuelsmann at common-lisp.net Sun Dec 7 21:50:27 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 07 Dec 2008 21:50:27 +0000 Subject: [armedbear-cvs] r11432 - branches/open-external-format/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 7 21:50:26 2008 New Revision: 11432 Log: Support setting external format parameters without affecting the chosen encoding. Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java Modified: branches/open-external-format/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/open-external-format/src/org/armedbear/lisp/Stream.java (original) +++ branches/open-external-format/src/org/armedbear/lisp/Stream.java Sun Dec 7 21:50:26 2008 @@ -319,6 +319,12 @@ 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 From ehuelsmann at common-lisp.net Sun Dec 7 22:12:48 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 07 Dec 2008 22:12:48 +0000 Subject: [armedbear-cvs] r11433 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 7 22:12:47 2008 New Revision: 11433 Log: Strings are also BASE-STRING; SIMPLE-STRINGs are also SIMPLE-BASE-STRINGs. Modified: trunk/j/src/org/armedbear/lisp/AbstractString.java trunk/j/src/org/armedbear/lisp/SimpleString.java Modified: trunk/j/src/org/armedbear/lisp/AbstractString.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/AbstractString.java (original) +++ trunk/j/src/org/armedbear/lisp/AbstractString.java Sun Dec 7 22:12:47 2008 @@ -40,9 +40,13 @@ if (type instanceof Symbol) { if (type == Symbol.STRING) return T; + if (type == Symbol.BASE_STRING) + return T; } if (type == BuiltInClass.STRING) return T; + if (type == BuiltInClass.BASE_STRING) + return T; return super.typep(type); } Modified: trunk/j/src/org/armedbear/lisp/SimpleString.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/SimpleString.java (original) +++ trunk/j/src/org/armedbear/lisp/SimpleString.java Sun Dec 7 22:12:47 2008 @@ -118,10 +118,14 @@ return T; if (type == Symbol.SIMPLE_ARRAY) return T; + if (type == Symbol.SIMPLE_BASE_STRING) + return T; if (type == BuiltInClass.SIMPLE_STRING) return T; if (type == BuiltInClass.SIMPLE_ARRAY) return T; + if (type == BuiltInClass.SIMPLE_BASE_STRING) + return T; return super.typep(type); } From ehuelsmann at common-lisp.net Mon Dec 8 22:35:24 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 08 Dec 2008 22:35:24 +0000 Subject: [armedbear-cvs] r11435 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Dec 8 22:35:24 2008 New Revision: 11435 Log: Make sure we're consistently using java.nio.Charset charset names (by constructing streams with a CharsetEncoder/CharsetDecoder argument instead of an encoding name). Modified: trunk/j/src/org/armedbear/lisp/Stream.java Modified: trunk/j/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Stream.java (original) +++ trunk/j/src/org/armedbear/lisp/Stream.java Mon Dec 8 22:35:24 2008 @@ -47,6 +47,7 @@ import java.io.StringWriter; import java.io.Writer; import java.math.BigInteger; +import java.nio.charset.Charset; import java.util.BitSet; @@ -129,22 +130,14 @@ { this.elementType = elementType; setExternalFormat(format); + if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - InputStreamReader inputStreamReader; - try - { - inputStreamReader = - (encoding == null) ? - new InputStreamReader(inputStream) - : new InputStreamReader(inputStream, encoding); - } - catch (java.io.UnsupportedEncodingException e) - { - Debug.trace(e); - inputStreamReader = - new InputStreamReader(inputStream); - } + InputStreamReader inputStreamReader = + (encoding == null) ? + new InputStreamReader(inputStream) + : new InputStreamReader(inputStream, + Charset.forName(encoding).newDecoder()); initAsCharacterInputStream(new BufferedReader(inputStreamReader)); } else @@ -173,18 +166,11 @@ setExternalFormat(format); if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - Writer w; - try - { - w = (encoding == null) ? + Writer w = + (encoding == null) ? new OutputStreamWriter(outputStream) - : new OutputStreamWriter(outputStream, encoding); - } - catch (java.io.UnsupportedEncodingException e) - { - Debug.trace(e); - w = new OutputStreamWriter(outputStream); - } + : new OutputStreamWriter(outputStream, + Charset.forName(encoding).newEncoder()); initAsCharacterOutputStream(w); } else From ehuelsmann at common-lisp.net Tue Dec 9 21:34:17 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 09 Dec 2008 21:34:17 +0000 Subject: [armedbear-cvs] r11436 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 9 21:34:06 2008 New Revision: 11436 Log: Landing the EXTERNAL-FORMAT branch on trunk makes this 0.0.11.2. Modified: trunk/j/src/org/armedbear/lisp/Version.java Modified: trunk/j/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Version.java (original) +++ trunk/j/src/org/armedbear/lisp/Version.java Tue Dec 9 21:34:06 2008 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.0.11.1"; + return "0.0.11.2"; } } From ehuelsmann at common-lisp.net Tue Dec 9 23:23:44 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 09 Dec 2008 23:23:44 +0000 Subject: [armedbear-cvs] r11437 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 9 23:23:43 2008 New Revision: 11437 Log: Fix *compiled* LAMBDA.64. Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Tue Dec 9 23:23:43 2008 @@ -638,10 +638,11 @@ (setq var (second (%car var))) ;; *x* (when (or (special-variable-p var) (memq var declared-specials)) (push var specials)))))) + ;;//###FIXME: Ideally, we don't rewrite for specials at all (when specials ;; For each special... (dolist (special specials) - (let ((sym (gensym))) + (let ((sym special)) (let ((res nil) (keyp nil)) ;; Walk through the lambda list and replace each occurrence. From ehuelsmann at common-lisp.net Sat Dec 13 21:24:22 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 13 Dec 2008 21:24:22 +0000 Subject: [armedbear-cvs] r11438 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 13 21:24:21 2008 New Revision: 11438 Log: Fix a whole slew of failures involving MACROEXAND/EXPAND-IN-CURRENT-ENV. Back to 52 (compiled) failures. Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Sat Dec 13 21:24:21 2008 @@ -713,14 +713,14 @@ expansion))) (defun precompile-macrolet (form) - (let ((*local-functions-and-macros* *local-functions-and-macros*) - (macros (cadr form))) - (dolist (macro macros) - (let ((name (car macro)) - (lambda-list (cadr macro)) - (forms (cddr macro))) - (push (define-local-macro name lambda-list forms) *local-functions-and-macros*) - (push name *local-functions-and-macros*))) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*))) + (dolist (definition (cadr form)) + (environment-add-macro-definition + *compile-file-environment* + (car definition) + (make-macro (car definition) + (make-expander-for-macrolet definition)))) (multiple-value-bind (body decls) (parse-body (cddr form) nil) `(locally , at decls ,@(mapcar #'precompile1 body))))) From ehuelsmann at common-lisp.net Sun Dec 14 08:45:51 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 08:45:51 +0000 Subject: [armedbear-cvs] r11439 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 14 08:45:50 2008 New Revision: 11439 Log: Cleanup following r11438. Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Sun Dec 14 08:45:50 2008 @@ -690,28 +690,11 @@ (precompile1 (expand-macro form)) form)) -(defun define-local-macro (name lambda-list body) - (let* ((form (gensym)) - (env (gensym)) - (body (sys::parse-defmacro lambda-list form body name 'macrolet - :environment env)) - (expander `(lambda (,form ,env) (block ,name ,body))) - (compiled-expander (sys::%compile nil expander))) - (coerce-to-function (or compiled-expander expander)))) - (defvar *local-functions-and-macros* ()) (defun local-macro-function (name) (getf *local-functions-and-macros* name)) -(defun expand-local-macro (form) - (let ((expansion (funcall (local-macro-function (car form)) form nil))) - ;; If the expansion turns out to be a bare symbol, wrap it with PROGN so it - ;; won't be mistaken for a tag in an enclosing TAGBODY. - (if (symbolp expansion) - (list 'PROGN expansion) - expansion))) - (defun precompile-macrolet (form) (let ((*compile-file-environment* (make-environment *compile-file-environment*))) From ehuelsmann at common-lisp.net Sun Dec 14 09:18:14 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 09:18:14 +0000 Subject: [armedbear-cvs] r11440 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 14 09:18:12 2008 New Revision: 11440 Log: Add @Override decorators before modifying the file. Modified: trunk/j/src/org/armedbear/lisp/Environment.java Modified: trunk/j/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Environment.java (original) +++ trunk/j/src/org/armedbear/lisp/Environment.java Sun Dec 14 09:18:12 2008 @@ -67,16 +67,19 @@ vars = new Binding(symbol, value, vars); } + @Override public LispObject typeOf() { return Symbol.ENVIRONMENT; } + @Override public LispObject classOf() { return BuiltInClass.ENVIRONMENT; } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.ENVIRONMENT) @@ -247,6 +250,7 @@ return binding != null ? binding.specialp : false; } + @Override public String writeToString() throws ConditionThrowable { return unreadableString(Symbol.ENVIRONMENT); @@ -257,10 +261,12 @@ new Primitive("make-environment", PACKAGE_SYS, true, "&optional parent-environment") { + @Override public LispObject execute() { return new Environment(); } + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { if (arg == NIL) @@ -274,6 +280,7 @@ new Primitive("environment-add-macro-definition", PACKAGE_SYS, true, "environment name expander") { + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -291,6 +298,7 @@ new Primitive("environment-add-function-definition", PACKAGE_SYS, true, "environment name lambda-expression") { + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -304,6 +312,7 @@ private static final Primitive EMPTY_ENVIRONMENT_P = new Primitive("empty-environment-p", PACKAGE_SYS, true, "environment") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { try @@ -321,6 +330,7 @@ private static final Primitive ENVIRONMENT_VARS = new Primitive("environment-variables", PACKAGE_SYS, true, "environment") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { try From ehuelsmann at common-lisp.net Sun Dec 14 12:07:53 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 12:07:53 +0000 Subject: [armedbear-cvs] r11441 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 14 12:07:52 2008 New Revision: 11441 Log: Fix compiled MACROLET.13 and MACROLET.14: MACROEXPAND should know about symbol macros while expanding. Modified: trunk/j/src/org/armedbear/lisp/Environment.java trunk/j/src/org/armedbear/lisp/Primitives.java trunk/j/src/org/armedbear/lisp/SymbolMacro.java trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/Environment.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Environment.java (original) +++ trunk/j/src/org/armedbear/lisp/Environment.java Sun Dec 14 12:07:52 2008 @@ -308,6 +308,21 @@ } }; + // ### environment-add-symbol-binding + public static final Primitive ENVIRONMENT_ADD_SYMBOL_BINDING = + new Primitive("environment-add-symbol-binding", PACKAGE_SYS, true, + "environment symbol value") + { + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + throws ConditionThrowable + { + checkEnvironment(first).bind(checkSymbol(second), third); + return first; + } + }; + // ### empty-environment-p private static final Primitive EMPTY_ENVIRONMENT_P = new Primitive("empty-environment-p", PACKAGE_SYS, true, "environment") Modified: trunk/j/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Primitives.java (original) +++ trunk/j/src/org/armedbear/lisp/Primitives.java Sun Dec 14 12:07:52 2008 @@ -1728,6 +1728,17 @@ } }; + // ### make-symbol-macro + private static final Primitive MAKE_SYMBOL_MACRO = + new Primitive("make-symbol-macro", PACKAGE_SYS, true, "expansion") + { + public LispObject execute(LispObject arg) throws ConditionThrowable + { + return new SymbolMacro(arg); + } + }; + + // ### %defparameter private static final Primitive _DEFPARAMETER = new Primitive("%defparameter", PACKAGE_SYS, false) Modified: trunk/j/src/org/armedbear/lisp/SymbolMacro.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/SymbolMacro.java (original) +++ trunk/j/src/org/armedbear/lisp/SymbolMacro.java Sun Dec 14 12:07:52 2008 @@ -47,13 +47,4 @@ return expansion; } - // ### make-symbol-macro - private static final Primitive MAKE_MACRO = - new Primitive("make-symbol-macro", PACKAGE_SYS, false) - { - public LispObject execute(LispObject arg) throws ConditionThrowable - { - return new SymbolMacro(arg); - } - }; } Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Sun Dec 14 12:07:52 2008 @@ -719,6 +719,8 @@ (defun precompile-symbol-macrolet (form) (let ((*local-variables* *local-variables*) + (*compile-file-environment* + (make-environment *compile-file-environment*)) (defs (cadr form))) (dolist (def defs) (let ((sym (car def)) @@ -727,7 +729,11 @@ (error 'program-error :format-control "Attempt to bind the special variable ~S with SYMBOL-MACROLET." :format-arguments (list sym))) - (push (list sym :symbol-macro expansion) *local-variables*))) + (push (list sym :symbol-macro expansion) *local-variables*) + (environment-add-symbol-binding *compile-file-environment* + sym + (sys::make-symbol-macro expansion)) + )) (multiple-value-bind (body decls) (parse-body (cddr form) nil) (when decls From vvoutilainen at common-lisp.net Sun Dec 14 12:52:41 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 14 Dec 2008 12:52:41 +0000 Subject: [armedbear-cvs] r11442 - trunk/j/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Dec 14 12:52:39 2008 New Revision: 11442 Log: Remove remaining bits of local-macro-function and expand-local-macro as they are no longer needed. Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Sun Dec 14 12:52:39 2008 @@ -372,11 +372,6 @@ (when (symbolp op) (cond ((setf handler (get op 'precompile-handler)) (return-from precompile1 (funcall handler form))) - ((local-macro-function op) - (let ((result (expand-local-macro (precompile-cons form)))) - (return-from precompile1 (if (equal result form) - result - (precompile1 result))))) ((macro-function op *compile-file-environment*) (return-from precompile1 (precompile1 (expand-macro form)))) ((special-operator-p op) @@ -500,18 +495,14 @@ (defun precompile-setf (form) (let ((place (second form))) (cond ((and (consp place) - (local-macro-function (%car place))) - (let ((expansion (expand-local-macro place))) - (precompile1 (list* 'SETF expansion (cddr form))))) - ((and (consp place) (eq (%car place) 'VALUES)) - (setf form - (list* 'SETF - (list* 'VALUES - (mapcar #'precompile1 (%cdr place))) - (cddr form))) - (precompile1 (expand-macro form))) - ((symbolp place) + (setf form + (list* 'SETF + (list* 'VALUES + (mapcar #'precompile1 (%cdr place))) + (cddr form))) + (precompile1 (expand-macro form))) + ((symbolp place) (let ((varspec (find-varspec place))) (if (and varspec (eq (second varspec) :symbol-macro)) (precompile1 (list* 'SETF (copy-tree (third varspec)) (cddr form))) @@ -692,9 +683,6 @@ (defvar *local-functions-and-macros* ()) -(defun local-macro-function (name) - (getf *local-functions-and-macros* name)) - (defun precompile-macrolet (form) (let ((*compile-file-environment* (make-environment *compile-file-environment*))) From vvoutilainen at common-lisp.net Sun Dec 14 14:17:46 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 14 Dec 2008 14:17:46 +0000 Subject: [armedbear-cvs] r11443 - trunk/j/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Dec 14 14:17:40 2008 New Revision: 11443 Log: Fix macrolet.39 in compiled tests by using environment for local functions. Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Sun Dec 14 14:17:40 2008 @@ -828,8 +828,7 @@ (arglist (cadr def)) (body (cddr def))) ;; Macro names are shadowed by local functions. - (push nil *local-functions-and-macros*) - (push name *local-functions-and-macros*) + (environment-add-function-definition *compile-file-environment* name body) (list* name arglist (mapcar #'precompile1 body)))) (defun precompile-local-functions (defs) @@ -849,7 +848,8 @@ (find-use name (%cdr expression)))))) (defun precompile-flet/labels (form) - (let ((*local-functions-and-macros* *local-functions-and-macros*) + (let ((*compile-file-environment* + (make-environment *compile-file-environment*)) (operator (car form)) (locals (cadr form)) (body (cddr form))) From ehuelsmann at common-lisp.net Sun Dec 14 15:05:14 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 15:05:14 +0000 Subject: [armedbear-cvs] r11444 - branches/0.12.x Message-ID: Author: ehuelsmann Date: Sun Dec 14 15:05:13 2008 New Revision: 11444 Log: Create maintenance branch 0.12.x. Added: branches/0.12.x/ - copied from r11443, /trunk/ From ehuelsmann at common-lisp.net Sun Dec 14 15:06:51 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 15:06:51 +0000 Subject: [armedbear-cvs] r11445 - branches/0.12.x/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 14 15:06:50 2008 New Revision: 11445 Log: Update version string. Modified: branches/0.12.x/j/src/org/armedbear/lisp/Version.java Modified: branches/0.12.x/j/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.12.x/j/src/org/armedbear/lisp/Version.java (original) +++ branches/0.12.x/j/src/org/armedbear/lisp/Version.java Sun Dec 14 15:06:50 2008 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.0.11.2"; + return "0.12.0"; } } From ehuelsmann at common-lisp.net Sun Dec 14 15:23:11 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 15:23:11 +0000 Subject: [armedbear-cvs] r11446 - tags/0.12.0 Message-ID: Author: ehuelsmann Date: Sun Dec 14 15:23:10 2008 New Revision: 11446 Log: Create release tag. Added: tags/0.12.0/ - copied from r11445, /branches/0.12.x/ From ehuelsmann at common-lisp.net Sun Dec 14 15:24:51 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 15:24:51 +0000 Subject: [armedbear-cvs] r11447 - branches/0.12.x/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 14 15:24:50 2008 New Revision: 11447 Log: Update version number following release tag. Modified: branches/0.12.x/j/src/org/armedbear/lisp/Version.java Modified: branches/0.12.x/j/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.12.x/j/src/org/armedbear/lisp/Version.java (original) +++ branches/0.12.x/j/src/org/armedbear/lisp/Version.java Sun Dec 14 15:24:50 2008 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.12.0"; + return "0.12.1-dev"; } } From ehuelsmann at common-lisp.net Sun Dec 14 15:26:49 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 15:26:49 +0000 Subject: [armedbear-cvs] r11448 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 14 15:26:49 2008 New Revision: 11448 Log: Update version number following release branch and tag. Modified: trunk/j/src/org/armedbear/lisp/Version.java Modified: trunk/j/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Version.java (original) +++ trunk/j/src/org/armedbear/lisp/Version.java Sun Dec 14 15:26:49 2008 @@ -41,6 +41,6 @@ public static String getVersion() { - return "0.0.11.2"; + return "0.13.0-dev"; } } From ehuelsmann at common-lisp.net Sun Dec 14 19:32:03 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 14 Dec 2008 19:32:03 +0000 Subject: [armedbear-cvs] r11449 - public_html Message-ID: Author: ehuelsmann Date: Sun Dec 14 19:32:01 2008 New Revision: 11449 Log: Publish 0.12.0 on the website. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sun Dec 14 19:32:01 2008 @@ -40,7 +40,7 @@

ABCL is free software and comes with ABSOLUTELY NO WARRANTY.

- The latest version is 0.0.11, released October 18, 2008. + The latest version is 0.12.0, released December 14, 2008.

@@ -49,11 +49,11 @@

- abcl-0.0.11.tar.gz - (source, 632987 bytes) + abcl-0.12.0.tar.gz + (source, 656652 bytes)

- abcl-0.0.11.zip - (source, 1012345 bytes) + abcl-0.12.0.zip + (source, 1130754 bytes)

@@ -81,9 +81,11 @@ quality of ABCL being good enough for their needs though. See the testimonials page.

- ABCL 0.0.11 fails 47 out of 21702 tests in the GCL ANSI test suite. + ABCL 0.12.0 fails 44 out of 21702 tests in the GCL ANSI test suite + in interpreted mode. In compiled mode ABCL 0.12.0 fails 48 tests, + coming from ca 65 in the last release. Most notable recent fixes relate to special variables handling - and making sure the correct environments are used with for example + and making sure the compiler uses the correct environments with, e.g., LET/LET* and FLET/LABELS.

ABCL's CLOS is intolerably slow and does not handle on-the-fly From astalla at common-lisp.net Mon Dec 15 03:31:06 2008 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 15 Dec 2008 03:31:06 +0000 Subject: [armedbear-cvs] r11450 - in branches/scripting/j/src/org/armedbear/lisp: . scripting scripting/lisp Message-ID: Author: astalla Date: Mon Dec 15 03:31:04 2008 New Revision: 11450 Log: JavaBean property support (jproperty-value) Minor code cleanup Started jinterface-impl registration support on the Lisp side Modified: branches/scripting/j/src/org/armedbear/lisp/JProxy.java branches/scripting/j/src/org/armedbear/lisp/Java.java branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp branches/scripting/j/src/org/armedbear/lisp/java.lisp branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp Modified: branches/scripting/j/src/org/armedbear/lisp/JProxy.java ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/JProxy.java (original) +++ branches/scripting/j/src/org/armedbear/lisp/JProxy.java Mon Dec 15 03:31:04 2008 @@ -124,6 +124,9 @@ //NEW IMPLEMENTATION by Alessio Stalla + /** + * A weak map associating each proxy instance with a "Lisp-this" object. + */ private static final Map proxyMap = new WeakHashMap(); public static class LispInvocationHandler implements InvocationHandler { Modified: branches/scripting/j/src/org/armedbear/lisp/Java.java ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/Java.java (original) +++ branches/scripting/j/src/org/armedbear/lisp/Java.java Mon Dec 15 03:31:04 2008 @@ -21,14 +21,18 @@ package org.armedbear.lisp; +import java.beans.BeanInfo; +import java.beans.IntrospectionException; +import java.beans.Introspector; +import java.beans.PropertyDescriptor; import java.lang.reflect.Array; import java.lang.reflect.Constructor; import java.lang.reflect.Field; import java.lang.reflect.InvocationTargetException; import java.lang.reflect.Method; import java.lang.reflect.Modifier; -import java.util.Map; import java.util.HashMap; +import java.util.Map; public final class Java extends Lisp { @@ -691,7 +695,53 @@ return makeLispObject(arg.javaInstance()); } }; - + + private static final Primitive JGET_PROPERTY_VALUE = + new Primitive("%jget-property-value", PACKAGE_JAVA, true, + "java-object property-name") { + + public LispObject execute(LispObject javaObject, LispObject propertyName) throws ConditionThrowable { + try { + Object obj = javaObject.javaInstance(); + PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName); + return new JavaObject(pd.getReadMethod().invoke(obj)); + } catch (Exception e) { + ConditionThrowable t = new ConditionThrowable("Exception in accessing property"); + t.initCause(e); + throw t; + } + } + }; + + private static final Primitive JSET_PROPERTY_VALUE = + new Primitive("%jset-property-value", PACKAGE_JAVA, true, + "java-object property-name value") { + + public LispObject execute(LispObject javaObject, LispObject propertyName, LispObject value) throws ConditionThrowable { + try { + Object obj = javaObject.javaInstance(); + PropertyDescriptor pd = getPropertyDescriptor(obj, propertyName); + pd.getWriteMethod().invoke(obj, value.javaInstance()); + return value; + } catch (Exception e) { + ConditionThrowable t = new ConditionThrowable("Exception in accessing property"); + t.initCause(e); + throw t; + } + } + }; + + private static PropertyDescriptor getPropertyDescriptor(Object obj, LispObject propertyName) throws ConditionThrowable, IntrospectionException { + String prop = ((AbstractString) propertyName).getStringValue(); + BeanInfo beanInfo = Introspector.getBeanInfo(obj.getClass()); + for(PropertyDescriptor pd : beanInfo.getPropertyDescriptors()) { + if(pd.getName().equals(prop)) { + return pd; + } + } + throw new ConditionThrowable("Property " + prop + " not found in " + obj); + } + private static Class classForName(String className) throws ConditionThrowable { try { Modified: branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp (original) +++ branches/scripting/j/src/org/armedbear/lisp/autoloads.lisp Mon Dec 15 03:31:04 2008 @@ -191,6 +191,8 @@ (autoload 'jmake-invocation-handler "java") (export 'jmake-proxy "JAVA") (autoload 'jmake-proxy "java") +(export 'jproperty-value "JAVA") +(autoload 'jproperty-value "java") (export 'jobject-class "JAVA") (autoload 'jobject-class "java") (export 'jclass-superclass "JAVA") Modified: branches/scripting/j/src/org/armedbear/lisp/java.lisp ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/java.lisp (original) +++ branches/scripting/j/src/org/armedbear/lisp/java.lisp Mon Dec 15 03:31:04 2008 @@ -278,4 +278,10 @@ (t (error "Unknown load-from for ~A" class-name))))) +(defun jproperty-value (obj prop) + (%jget-property-value obj prop)) + +(defun (setf jproperty-value) (value obj prop) + (%jset-property-value obj prop value)) + (provide "JAVA-EXTENSIONS") Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original) +++ branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Mon Dec 15 03:31:04 2008 @@ -328,10 +328,6 @@ return new AbclScriptEngineFactory(); } - public static String decoratedVariableName(String jvar) { - return jvar.toUpperCase(); - } - private static Object toJava(LispObject lispObject) throws ConditionThrowable { return lispObject.javaInstance(); } Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java (original) +++ branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngineFactory.java Mon Dec 15 03:31:04 2008 @@ -78,10 +78,10 @@ sb.append("(jcall \""); sb.append(method); sb.append("\" "); - sb.append(AbclScriptEngine.decoratedVariableName(obj)); + sb.append(obj); for(String arg : args) { sb.append(" "); - sb.append(AbclScriptEngine.decoratedVariableName(arg)); + sb.append(arg); } sb.append(")"); return sb.toString(); Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp (original) +++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Mon Dec 15 03:31:04 2008 @@ -86,4 +86,23 @@ (let ((*package* (find-package :abcl-script-user))) (eval `(compile nil (lambda () - ,@(read-from-string (concatenate 'string "(" code-string ")"))))))) \ No newline at end of file + ,@(read-from-string (concatenate 'string "(" code-string ")"))))))) + + +;;Java interface implementation + +(defvar *interface-implementation-map* (make-hash-table :test #'equal)) + +(defun find-java-interface-implementation (interface) + (gethash interface *interface-implementation-map*)) + +(defun register-java-interface-implementation (interface impl) + (setf (gethash interface *interface-implementation-map*) impl)) + +(defun remove-java-interface-implementation (interface) + (remhash interface *interface-implementation-map*)) + +(defun define-java-interface-implementation (interface implementation &optional lisp-this) + (register-java-interface-implementation + interface + (jmake-proxy interface implementation lisp-this))) \ No newline at end of file Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp (original) +++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp Mon Dec 15 03:31:04 2008 @@ -23,7 +23,8 @@ #:eval-compiled-script #:define-java-interface-implementation #:find-java-interface-implementation - #:implement-java-interface)) + #:register-java-interface-implementation + #:remove-java-interface-implementation)) (defpackage :abcl-script-user (:use :cl :ext :java :abcl-script)) \ No newline at end of file From astalla at common-lisp.net Mon Dec 15 22:11:01 2008 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 15 Dec 2008 22:11:01 +0000 Subject: [armedbear-cvs] r11451 - in branches/scripting/j: . src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Dec 15 22:11:00 2008 New Revision: 11451 Log: Compatibility with Java 5: using the ANT-based build, the JSR-223 support is excluded from the build. Also removed a @Override annotation that prevented compiling ABCL with Java 5. Modified: branches/scripting/j/build.xml branches/scripting/j/src/org/armedbear/lisp/JProxy.java Modified: branches/scripting/j/build.xml ============================================================================== --- branches/scripting/j/build.xml (original) +++ branches/scripting/j/build.xml Mon Dec 15 22:11:00 2008 @@ -20,6 +20,10 @@ + + + + Main Ant targets: abcl.compile @@ -100,8 +104,8 @@ - - + + @@ -110,7 +114,7 @@ - + @@ -118,15 +122,15 @@ - + - - + + @@ -198,13 +202,10 @@ - - - java.version: ${java.version} - + WARNING: Java version ${java.version} not recommended. Modified: branches/scripting/j/src/org/armedbear/lisp/JProxy.java ============================================================================== --- branches/scripting/j/src/org/armedbear/lisp/JProxy.java (original) +++ branches/scripting/j/src/org/armedbear/lisp/JProxy.java Mon Dec 15 22:11:00 2008 @@ -150,7 +150,6 @@ this.function = function; } - @Override public Object invoke(Object proxy, Method method, Object[] args) throws Throwable { if(hashCodeMethod.equals(method)) { return System.identityHashCode(proxy); From ehuelsmann at common-lisp.net Thu Dec 18 21:01:45 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 18 Dec 2008 21:01:45 +0000 Subject: [armedbear-cvs] r11452 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 18 21:01:44 2008 New Revision: 11452 Log: Introduce WITH-SAVED-COMPILER-POLICY macro to consistently save all policy variables. Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/j/src/org/armedbear/lisp/jvm.lisp Thu Dec 18 21:01:44 2008 @@ -62,6 +62,18 @@ (defmacro dformat (&rest ignored) (declare (ignore ignored))) + +(defmacro with-saved-compiler-policy (&body body) + "Saves compiler policy variables, restoring them after evaluating `body'." + `(let ((*speed* *speed*) + (*space* *space*) + (*safety* *safety*) + (*debug* *debug*) + (*explain* *explain*) + (*inline-declarations* *inline-declarations*)) + , at body)) + + (eval-when (:compile-toplevel :load-toplevel :execute) (defun generate-inline-expansion (block-name lambda-list body) (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) :test 'eq) @@ -785,11 +797,7 @@ (let ((variable (local-function-variable local-function))) (when variable (push variable *visible-variables*)))) - (let ((*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*) - (*inline-declarations* *inline-declarations*)) + (with-saved-compiler-policy (process-optimization-declarations (cddr form)) (list* (car form) local-functions (p1-body (cddr form)))))) @@ -5461,12 +5469,7 @@ (dolist (variable (block-free-specials block)) (push variable *visible-variables*)) ;; Body of LET/LET*. - (let ((*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*) - (*inline-declarations* *inline-declarations*)) + (with-saved-compiler-policy (process-optimization-declarations (cddr form)) (compile-progn-body (cddr form) target representation)) (when specialp @@ -5476,15 +5479,10 @@ (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)))) (defun p2-locally (form target representation) - (let ((*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*) - (*inline-declarations* *inline-declarations*) - (body (cdr form))) - (process-optimization-declarations body) - (compile-progn-body body target representation))) + (with-saved-compiler-policy + (let ((body (cdr form))) + (process-optimization-declarations body) + (compile-progn-body body target representation)))) (defknown find-tag (t) t) (defun find-tag (name) @@ -6030,13 +6028,10 @@ :lambda-list lambda-list))) (setf (compiland-class-file compiland) class-file) (with-class-file class-file - (let ((*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*)) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))) + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))))) ;; Verify that the class file is loadable. (let ((*load-truename* (pathname pathname))) (unless (ignore-errors (load-compiled-function pathname)) @@ -6067,13 +6062,10 @@ (unwind-protect (progn (with-class-file class-file - (let ((*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*)) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))) + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))))) (setf (local-function-class-file local-function) class-file) (setf (local-function-function local-function) (load-compiled-function pathname)) @@ -6104,13 +6096,10 @@ :lambda-list lambda-list))) (setf (compiland-class-file compiland) class-file) (with-class-file class-file - (let ((*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*)) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))) + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))))) ;; Verify that the class file is loadable. (let ((*load-truename* (pathname pathname))) (unless (ignore-errors (load-compiled-function pathname)) @@ -6139,13 +6128,10 @@ (unwind-protect (progn (with-class-file class-file - (let ((*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*)) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))) + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))))) (setf (local-function-class-file local-function) class-file) (let ((g (declare-object (load-compiled-function pathname)))) (emit 'getstatic *this-class* g +lisp-object+) @@ -6218,13 +6204,10 @@ (make-class-file :pathname (sys::next-classfile-name) :lambda-list lambda-list)) (with-class-file (compiland-class-file compiland) - (let ((*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*)) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))) + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))))) (let ((class-file (compiland-class-file compiland))) (emit 'getstatic *this-class* (declare-local-function (make-local-function :class-file class-file)) @@ -6237,13 +6220,10 @@ (unwind-protect (progn (with-class-file (compiland-class-file compiland) - (let ((*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*)) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland)))) + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))))) (emit 'getstatic *this-class* (declare-object (load-compiled-function pathname)) +lisp-object+)) @@ -10261,31 +10241,27 @@ (*closure-variables* nil) (*undefined-variables* nil) (*local-functions* nil) - (*current-compiland* compiland) - (*speed* *speed*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*) - (*inline-declarations* *inline-declarations*)) - ;; Pass 1. - (p1-compiland compiland) - (setf *closure-variables* - (remove-if-not #'variable-used-non-locally-p *all-variables*)) - (when *closure-variables* + (*current-compiland* compiland)) + (with-saved-compiler-policy + ;; Pass 1. + (p1-compiland compiland) (setf *closure-variables* - (remove-if #'variable-special-p *closure-variables*)) + (remove-if-not #'variable-used-non-locally-p *all-variables*)) (when *closure-variables* - (let ((i 0)) - (dolist (var (reverse *closure-variables*)) - (setf (variable-closure-index var) i) - (dformat t "var = ~S closure index = ~S~%" (variable-name var) - (variable-closure-index var)) - (incf i))))) - ;; Pass 2. - (with-class-file (compiland-class-file compiland) - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))) - (class-file-pathname (compiland-class-file compiland)))) + (setf *closure-variables* + (remove-if #'variable-special-p *closure-variables*)) + (when *closure-variables* + (let ((i 0)) + (dolist (var (reverse *closure-variables*)) + (setf (variable-closure-index var) i) + (dformat t "var = ~S closure index = ~S~%" (variable-name var) + (variable-closure-index var)) + (incf i))))) + ;; Pass 2. + (with-class-file (compiland-class-file compiland) + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland))) + (class-file-pathname (compiland-class-file compiland))))) (defvar *compiler-error-bailout*) @@ -10381,16 +10357,12 @@ (warnings-p t) (failure-p t)) (with-compilation-unit () - (let* ((*speed* *speed*) - (*space* *space*) - (*safety* *safety*) - (*debug* *debug*) - (*explain* *explain*) - (tempfile (make-temp-file))) - (unwind-protect - (setf compiled-function - (load-compiled-function (compile-defun name expr env tempfile))) - (delete-file tempfile))) + (with-saved-compiler-policy + (let* ((tempfile (make-temp-file))) + (unwind-protect + (setf compiled-function + (load-compiled-function (compile-defun name expr env tempfile))) + (delete-file tempfile)))) (when (and name (functionp compiled-function)) (sys::%set-lambda-name compiled-function name) (sys:set-call-count compiled-function (sys:call-count definition)) From ehuelsmann at common-lisp.net Fri Dec 19 19:46:26 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 19 Dec 2008 19:46:26 +0000 Subject: [armedbear-cvs] r11453 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 19 19:46:24 2008 New Revision: 11453 Log: Condense LAMBDA and NAMED-LAMBDA branches in p1-function main COND into a single one with conditions. Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/j/src/org/armedbear/lisp/jvm.lisp Fri Dec 19 19:46:24 2008 @@ -862,44 +862,31 @@ (defun p1-function (form) (let ((form (copy-tree form)) local-function) - (cond ((and (consp (cadr form)) (eq (caadr form) 'LAMBDA)) - (when *current-compiland* - (incf (compiland-children *current-compiland*))) - (let* ((*current-compiland* *current-compiland*) - (lambda-form (cadr form)) + (cond ((and (consp (cadr form)) + (or (eq (caadr form) 'LAMBDA) + (eq (caadr form) 'NAMED-LAMBDA))) + (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA)) + (named-lambda-form (when named-lambda-p + (cadr form))) + (name (when named-lambda-p + (cadr named-lambda-form))) + (lambda-form (if named-lambda-p + (cons 'LAMBDA (cddr named-lambda-form)) + (cadr form))) (lambda-list (cadr lambda-form)) (body (cddr lambda-form)) - (compiland (make-compiland :name (gensym "ANONYMOUS-LAMBDA-") + (compiland (make-compiland :name (if named-lambda-p + name (gensym "ANONYMOUS-LAMBDA-")) :lambda-expression lambda-form :parent *current-compiland*))) + (when *current-compiland* + (incf (compiland-children *current-compiland*))) (multiple-value-bind (body decls) (parse-body body) (setf (compiland-lambda-expression compiland) - `(lambda ,lambda-list , at decls , at body)) - (let ((*visible-variables* *visible-variables*) - (*current-compiland* compiland)) - (p1-compiland compiland))) - (list 'FUNCTION compiland))) - ((and (consp (cadr form)) (eq (caadr form) 'NAMED-LAMBDA)) - (when *current-compiland* - (incf (compiland-children *current-compiland*))) - (let* ((*current-compiland* *current-compiland*) -;; (lambda-form (cadr form)) - (named-lambda-form (cadr form)) - (name (cadr named-lambda-form)) - (lambda-form (cons 'LAMBDA (cddr named-lambda-form))) - (lambda-list (cadr lambda-form)) - (body (cddr lambda-form)) - (compiland (make-compiland :name name - :lambda-expression lambda-form - :parent *current-compiland*))) -;; (format t "p1-function named-lambda-form = ~S~%" named-lambda-form) -;; (format t "p1-function name = ~S~%" name) -;; (format t "p1-function lambda-form = ~S~%" lambda-form) - (multiple-value-bind (body decls) - (parse-body body) - (setf (compiland-lambda-expression compiland) - `(lambda ,lambda-list , at decls (block nil , at body))) + (if named-lambda-p + `(lambda ,lambda-list , at decls (block nil , at body)) + `(lambda ,lambda-list , at decls , at body))) (let ((*visible-variables* *visible-variables*) (*current-compiland* compiland)) (p1-compiland compiland))) @@ -3827,6 +3814,7 @@ (defknown process-args (t) t) (defun process-args (args) + "" (when args (let ((numargs (length args))) (let ((must-clear-values nil)) From ehuelsmann at common-lisp.net Fri Dec 19 20:57:53 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 19 Dec 2008 20:57:53 +0000 Subject: [armedbear-cvs] r11454 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 19 20:57:52 2008 New Revision: 11454 Log: Fix MACRO-FUNCTION.7. Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp Modified: trunk/j/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/precompiler.lisp (original) +++ trunk/j/src/org/armedbear/lisp/precompiler.lisp Fri Dec 19 20:57:52 2008 @@ -691,7 +691,9 @@ *compile-file-environment* (car definition) (make-macro (car definition) - (make-expander-for-macrolet definition)))) + (make-closure + (make-expander-for-macrolet definition) + NIL)))) (multiple-value-bind (body decls) (parse-body (cddr form) nil) `(locally , at decls ,@(mapcar #'precompile1 body))))) From ehuelsmann at common-lisp.net Sat Dec 20 14:09:44 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 20 Dec 2008 14:09:44 +0000 Subject: [armedbear-cvs] r11456 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 20 14:09:27 2008 New Revision: 11456 Log: Remove superfluous IN-PACKAGE. Move documentation from comment to document-position in DEFVAR and extend it. Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/jvm.lisp (original) +++ trunk/j/src/org/armedbear/lisp/jvm.lisp Sat Dec 20 14:09:27 2008 @@ -29,8 +29,6 @@ ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. -(in-package "EXTENSIONS") - (in-package "JVM") (export '(compile-defun *catch-errors* jvm-compile jvm-compile-package @@ -280,8 +278,8 @@ (t nil))) -;; True for local functions defined with FLET or LABELS. -(defvar *child-p* nil) +(defvar *child-p* nil + "True for local functions created by FLET, LABELS and (NAMED-)LAMBDA") (defknown find-variable (symbol list) t) (defun find-variable (name variables) From ehuelsmann at common-lisp.net Sat Dec 20 19:35:39 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 20 Dec 2008 19:35:39 +0000 Subject: [armedbear-cvs] r11457 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sat Dec 20 19:35:37 2008 New Revision: 11457 Log: Create separate project directories for ABCL and J. Added: trunk/abcl/ - copied from r11456, /trunk/j/ From ehuelsmann at common-lisp.net Sat Dec 20 19:37:17 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 20 Dec 2008 19:37:17 +0000 Subject: [armedbear-cvs] r11458 - trunk/j/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 20 19:37:16 2008 New Revision: 11458 Log: Remove ABCL from J. Removed: trunk/j/src/org/armedbear/lisp/ From ehuelsmann at common-lisp.net Sat Dec 20 19:44:21 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 20 Dec 2008 19:44:21 +0000 Subject: [armedbear-cvs] r11459 - in trunk/abcl: . doc src src/gnu src/jpty src/org/armedbear/j themes Message-ID: Author: ehuelsmann Date: Sat Dec 20 19:44:21 2008 New Revision: 11459 Log: Remove (most of) J from ABCL. Added: trunk/abcl/COPYING (props changed) - copied unchanged from r11458, /trunk/abcl/src/org/armedbear/lisp/LICENSE Removed: trunk/abcl/doc/FAQ.html trunk/abcl/doc/aliases.html trunk/abcl/doc/archives.html trunk/abcl/doc/autosave.html trunk/abcl/doc/building.html trunk/abcl/doc/columns.html trunk/abcl/doc/commands.html trunk/abcl/doc/compilation.html trunk/abcl/doc/contents.html trunk/abcl/doc/cvs.html trunk/abcl/doc/directories.html trunk/abcl/doc/extensions.html trunk/abcl/doc/imagebuffers.html trunk/abcl/doc/indentation.html trunk/abcl/doc/init.lisp.html trunk/abcl/doc/initialization.html trunk/abcl/doc/install.html trunk/abcl/doc/j.css trunk/abcl/doc/java.html trunk/abcl/doc/jdb.html trunk/abcl/doc/jdbcommands.html trunk/abcl/doc/keys.html trunk/abcl/doc/killring.html trunk/abcl/doc/lispmode.html trunk/abcl/doc/logging.html trunk/abcl/doc/mail.html trunk/abcl/doc/modes.html trunk/abcl/doc/preferences.html trunk/abcl/doc/regexp.html trunk/abcl/doc/sessions.html trunk/abcl/doc/statusbar.html trunk/abcl/doc/tags.html trunk/abcl/doc/terms.html trunk/abcl/doc/themes.html trunk/abcl/doc/xmlmode.html trunk/abcl/j.bat.in trunk/abcl/j.in trunk/abcl/src/Main.java trunk/abcl/src/Makefile.in trunk/abcl/src/SampleExtension.java trunk/abcl/src/gnu/ trunk/abcl/src/jpty/ trunk/abcl/src/manifest trunk/abcl/src/org/armedbear/j/ trunk/abcl/themes/ From ehuelsmann at common-lisp.net Sat Dec 20 20:07:28 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 20 Dec 2008 20:07:28 +0000 Subject: [armedbear-cvs] r11460 - public_html Message-ID: Author: ehuelsmann Date: Sat Dec 20 20:07:26 2008 New Revision: 11460 Log: Update website to reflect separation of ABCL. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Sat Dec 20 20:07:26 2008 @@ -65,7 +65,7 @@ out through anonymous access with the following command: 

 
-      $ svn co svn://common-lisp.net/project/armedbear/svn/trunk/j j
+      $ svn co svn://common-lisp.net/project/armedbear/svn/trunk/abcl abcl
From ehuelsmann at common-lisp.net Sat Dec 20 21:54:01 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 20 Dec 2008 21:54:01 +0000 Subject: [armedbear-cvs] r11461 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Dec 20 21:53:59 2008 New Revision: 11461 Log: Document some functions. 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 Sat Dec 20 21:53:59 2008 @@ -2643,7 +2643,11 @@ (defknown process-args (t) t) (defun process-args (args) - "" + "Compiles forms specified as function call arguments. + +The results are either accumulated on the stack or in an array +in order to call the relevant `execute' form. The function call +itself is *not* compiled by this function." (when args (let ((numargs (length args))) (let ((must-clear-values nil)) @@ -2750,6 +2754,10 @@ (emit-move-from-stack target representation)))) (defun compile-call (args) + "Compiles a function call. + +Depending on the `*speed*' and `*debug*' settings, a stack frame +is registered (or not)." (let ((numargs (length args))) (cond ((> *speed* *debug*) (process-args args) @@ -2879,6 +2887,10 @@ (defknown compile-local-function-call (t t t) t) (defun compile-local-function-call (form target representation) + "Compiles a call to a function marked as `*child-p*'; a local function. + +Functions this applies to can be FLET, LABELS, LAMBDA or NAMED-LAMBDA. +Note: DEFUN implies a named lambda." (let* ((compiland *current-compiland*) (op (car form)) (args (cdr form)) From vvoutilainen at common-lisp.net Sun Dec 21 11:46:58 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Dec 2008 11:46:58 +0000 Subject: [armedbear-cvs] r11462 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Dec 21 11:46:57 2008 New Revision: 11462 Log: Clean up generate-type-check-for-variable. 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 Dec 21 11:46:57 2008 @@ -479,26 +479,17 @@ (defknown generate-type-check-for-variable (t) t) (defun generate-type-check-for-variable (variable) - (let ((declared-type (variable-declared-type variable))) - (cond ((eq declared-type :none)) ; Nothing to do. - ((eq declared-type 'SYMBOL) - (generate-instanceof-type-check-for-variable variable 'SYMBOL)) - ((eq declared-type 'CHARACTER) - (generate-instanceof-type-check-for-variable variable 'CHARACTER)) - ((eq declared-type 'CONS) - (generate-instanceof-type-check-for-variable variable 'CONS)) - ((eq declared-type 'HASH-TABLE) - (generate-instanceof-type-check-for-variable variable 'HASH-TABLE)) - ((fixnum-type-p declared-type) - (generate-instanceof-type-check-for-variable variable 'FIXNUM)) - ((subtypep declared-type 'STRING) - (generate-instanceof-type-check-for-variable variable 'STRING)) - ((subtypep declared-type 'VECTOR) - (generate-instanceof-type-check-for-variable variable 'VECTOR)) - ((eq declared-type 'STREAM) - (generate-instanceof-type-check-for-variable variable 'STREAM)) - (t - nil)))) + (let* ((declared-type (variable-declared-type variable)) + (type-to-use + (if (eq declared-type :none) nil + (or + (when (fixnum-type-p declared-type) 'FIXNUM) + (find-if #'(lambda (type) (eq type declared-type)) + `(SYMBOL CHARACTER CONS HASH-TABLE STREAM)) + (find-if #'(lambda (type) (subtypep declared-type type)) + `(STRING VECTOR)))))) + (when type-to-use + (generate-instanceof-type-check-for-variable variable type-to-use)))) (defknown maybe-generate-type-check (t) t) (defun maybe-generate-type-check (variable) From vvoutilainen at common-lisp.net Sun Dec 21 16:12:49 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Dec 2008 16:12:49 +0000 Subject: [armedbear-cvs] r11463 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Dec 21 16:12:48 2008 New Revision: 11463 Log: Helper function for repeating parts in class file generation. 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 Dec 21 16:12:48 2008 @@ -4838,6 +4838,17 @@ (emit-push-nil) (emit-move-from-stack target))) +(defun do-write-class-file (class-file compiland) + (with-class-file class-file + (let ((*current-compiland* compiland)) + (with-saved-compiler-policy + (p2-compiland compiland) + (write-class-file (compiland-class-file compiland)))))) + +(defun set-compiland-and-write-class-file (class-file compiland) + (setf (compiland-class-file compiland) class-file) + (do-write-class-file class-file compiland)) + (defknown p2-flet-process-compiland (t) t) (defun p2-flet-process-compiland (local-function) (let* ((compiland (local-function-compiland local-function)) @@ -4846,12 +4857,7 @@ (let* ((pathname (sys::next-classfile-name)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (setf (compiland-class-file compiland) class-file) - (with-class-file class-file - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))))) + (set-compiland-and-write-class-file class-file compiland) ;; Verify that the class file is loadable. (let ((*load-truename* (pathname pathname))) (unless (ignore-errors (load-compiled-function pathname)) @@ -4878,14 +4884,9 @@ (let* ((pathname (make-temp-file)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (setf (compiland-class-file compiland) class-file) (unwind-protect (progn - (with-class-file class-file - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))))) + (set-compiland-and-write-class-file class-file compiland) (setf (local-function-class-file local-function) class-file) (setf (local-function-function local-function) (load-compiled-function pathname)) @@ -4914,12 +4915,7 @@ (let* ((pathname (sys::next-classfile-name)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (setf (compiland-class-file compiland) class-file) - (with-class-file class-file - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))))) + (set-compiland-and-write-class-file class-file compiland) ;; Verify that the class file is loadable. (let ((*load-truename* (pathname pathname))) (unless (ignore-errors (load-compiled-function pathname)) @@ -4944,14 +4940,9 @@ (let* ((pathname (make-temp-file)) (class-file (make-class-file :pathname pathname :lambda-list lambda-list))) - (setf (compiland-class-file compiland) class-file) (unwind-protect (progn - (with-class-file class-file - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))))) + (set-compiland-and-write-class-file class-file compiland) (setf (local-function-class-file local-function) class-file) (let ((g (declare-object (load-compiled-function pathname)))) (emit 'getstatic *this-class* g +lisp-object+) @@ -5023,12 +5014,8 @@ (setf (compiland-class-file compiland) (make-class-file :pathname (sys::next-classfile-name) :lambda-list lambda-list)) - (with-class-file (compiland-class-file compiland) - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))))) (let ((class-file (compiland-class-file compiland))) + (do-write-class-file class-file compiland) (emit 'getstatic *this-class* (declare-local-function (make-local-function :class-file class-file)) +lisp-object+))) @@ -5039,11 +5026,7 @@ :lambda-list lambda-list)) (unwind-protect (progn - (with-class-file (compiland-class-file compiland) - (let ((*current-compiland* compiland)) - (with-saved-compiler-policy - (p2-compiland compiland) - (write-class-file (compiland-class-file compiland))))) + (do-write-class-file (compiland-class-file compiland) compiland) (emit 'getstatic *this-class* (declare-object (load-compiled-function pathname)) +lisp-object+)) From vvoutilainen at common-lisp.net Sun Dec 21 17:13:27 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Dec 2008 17:13:27 +0000 Subject: [armedbear-cvs] r11464 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Dec 21 17:13:27 2008 New Revision: 11464 Log: Rename do-write-class-file to compile-and-write-to-file. 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 Dec 21 17:13:27 2008 @@ -4838,7 +4838,7 @@ (emit-push-nil) (emit-move-from-stack target))) -(defun do-write-class-file (class-file compiland) +(defun compile-and-write-to-file (class-file compiland) (with-class-file class-file (let ((*current-compiland* compiland)) (with-saved-compiler-policy @@ -4847,7 +4847,7 @@ (defun set-compiland-and-write-class-file (class-file compiland) (setf (compiland-class-file compiland) class-file) - (do-write-class-file class-file compiland)) + (compile-and-write-to-file class-file compiland)) (defknown p2-flet-process-compiland (t) t) (defun p2-flet-process-compiland (local-function) @@ -5015,7 +5015,7 @@ (make-class-file :pathname (sys::next-classfile-name) :lambda-list lambda-list)) (let ((class-file (compiland-class-file compiland))) - (do-write-class-file class-file compiland) + (compile-and-write-to-file class-file compiland) (emit 'getstatic *this-class* (declare-local-function (make-local-function :class-file class-file)) +lisp-object+))) @@ -5026,7 +5026,7 @@ :lambda-list lambda-list)) (unwind-protect (progn - (do-write-class-file (compiland-class-file compiland) compiland) + (compile-and-write-to-file (compiland-class-file compiland) compiland) (emit 'getstatic *this-class* (declare-object (load-compiled-function pathname)) +lisp-object+)) From ehuelsmann at common-lisp.net Sun Dec 21 22:16:30 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 21 Dec 2008 22:16:30 +0000 Subject: [armedbear-cvs] r11465 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Dec 21 22:16:29 2008 New Revision: 11465 Log: Make clear difference between calling the template evaluator or evaluating the object. (Relates to ClosureTemplateFunction.) Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Sun Dec 21 22:16:29 2008 @@ -33,42 +33,62 @@ package org.armedbear.lisp; -public abstract class ClosureTemplateFunction extends Closure +public class ClosureTemplateFunction extends Closure + implements Cloneable { + + public LispObject[] ctx; + public ClosureTemplateFunction(LispObject lambdaList) throws ConditionThrowable { super(list2(Symbol.LAMBDA, lambdaList), null); } + public ClosureTemplateFunction setContext(LispObject[] context) + { + ctx = context; + return this; + } + + public ClosureTemplateFunction dup() + throws CloneNotSupportedException + { + return (ClosureTemplateFunction)super.clone(); + } + + + + // execute methods have the semantic meaning + // "evaluate this object" public final LispObject execute() throws ConditionThrowable { - return notImplemented(); + return _execute(ctx); } public final LispObject execute(LispObject arg) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx); } public final LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second); } public final LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second, third); } public final LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second, third, fourth); } public final LispObject execute(LispObject first, LispObject second, @@ -76,7 +96,7 @@ LispObject fifth) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second, third, fourth, fifth); } public final LispObject execute(LispObject first, LispObject second, @@ -84,7 +104,7 @@ LispObject fifth, LispObject sixth) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second, third, fourth, fifth, sixth); } public final LispObject execute(LispObject first, LispObject second, @@ -93,7 +113,7 @@ LispObject seventh) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second, third, fourth, fifth, sixth, seventh); } public final LispObject execute(LispObject first, LispObject second, @@ -102,7 +122,14 @@ LispObject seventh, LispObject eighth) throws ConditionThrowable { - return notImplemented(); + return _execute(ctx, first, second, third, fourth, fifth, + sixth, seventh, eighth); + } + + public final LispObject execute(LispObject[] args) + throws ConditionThrowable + { + return _execute(ctx, args); } private final LispObject notImplemented() throws ConditionThrowable @@ -110,35 +137,39 @@ return error(new WrongNumberOfArgumentsException(this)); } + + // _execute methods have the semantic meaning + // "evaluate this template with these values" + // Zero args. - public LispObject execute(LispObject[] context) throws ConditionThrowable + public LispObject _execute(LispObject[] context) throws ConditionThrowable { LispObject[] args = new LispObject[0]; - return execute(context, args); + return _execute(context, args); } // One arg. - public LispObject execute(LispObject[] context, LispObject first) + public LispObject _execute(LispObject[] context, LispObject first) throws ConditionThrowable { LispObject[] args = new LispObject[1]; args[0] = first; - return execute(context, args); + return _execute(context, args); } // Two args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second) throws ConditionThrowable { LispObject[] args = new LispObject[2]; args[0] = first; args[1] = second; - return execute(context, args); + return _execute(context, args); } // Three args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second, LispObject third) throws ConditionThrowable { @@ -146,11 +177,11 @@ args[0] = first; args[1] = second; args[2] = third; - return execute(context, args); + return _execute(context, args); } // Four args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -160,11 +191,11 @@ args[1] = second; args[2] = third; args[3] = fourth; - return execute(context, args); + return _execute(context, args); } // Five args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) throws ConditionThrowable @@ -175,11 +206,11 @@ args[2] = third; args[3] = fourth; args[4] = fifth; - return execute(context, args); + return _execute(context, args); } // Six args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -192,11 +223,11 @@ args[3] = fourth; args[4] = fifth; args[5] = sixth; - return execute(context, args); + return _execute(context, args); } // Seven args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) @@ -210,11 +241,11 @@ args[4] = fifth; args[5] = sixth; args[6] = seventh; - return execute(context, args); + return _execute(context, args); } // Eight args. - public LispObject execute(LispObject[] context, LispObject first, + public LispObject _execute(LispObject[] context, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, @@ -230,11 +261,11 @@ args[5] = sixth; args[6] = seventh; args[7] = eighth; - return execute(context, args); + return _execute(context, args); } // Arg array. - public LispObject execute(LispObject[] context, LispObject[] args) + public LispObject _execute(LispObject[] context, LispObject[] args) throws ConditionThrowable { return notImplemented(); 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 Dec 21 22:16:29 2008 @@ -53,32 +53,32 @@ public LispObject execute() throws ConditionThrowable { - return ctf.execute(context); + return ctf._execute(context); } public LispObject execute(LispObject arg) throws ConditionThrowable { - return ctf.execute(context, arg); + return ctf._execute(context, arg); } public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { - return ctf.execute(context, first, second); + return ctf._execute(context, first, second); } public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { - return ctf.execute(context, first, second, third); + return ctf._execute(context, first, second, third); } public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable { - return ctf.execute(context, first, second, third, fourth); + return ctf._execute(context, first, second, third, fourth); } public LispObject execute(LispObject first, LispObject second, @@ -86,7 +86,7 @@ LispObject fifth) throws ConditionThrowable { - return ctf.execute(context, first, second, third, fourth, fifth); + return ctf._execute(context, first, second, third, fourth, fifth); } public LispObject execute(LispObject first, LispObject second, @@ -94,7 +94,7 @@ LispObject fifth, LispObject sixth) throws ConditionThrowable { - return ctf.execute(context, first, second, third, fourth, fifth, sixth); + return ctf._execute(context, first, second, third, fourth, fifth, sixth); } public LispObject execute(LispObject first, LispObject second, @@ -103,7 +103,7 @@ LispObject seventh) throws ConditionThrowable { - return ctf.execute(context, first, second, third, fourth, fifth, sixth, + return ctf._execute(context, first, second, third, fourth, fifth, sixth, seventh); } @@ -113,12 +113,12 @@ LispObject seventh, LispObject eighth) throws ConditionThrowable { - return ctf.execute(context, first, second, third, fourth, fifth, sixth, + return ctf._execute(context, first, second, third, fourth, fifth, sixth, seventh, eighth); } public LispObject execute(LispObject[] args) throws ConditionThrowable { - return ctf.execute(context, args); + return ctf._execute(context, args); } } 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 Dec 21 22:16:29 2008 @@ -8939,7 +8939,14 @@ super) (*child-p* (if *closure-variables* - +lisp-ctf-class+ + (progn + (setf execute-method-name + (setf (method-name execute-method) "_execute")) + (setf (method-name-index execute-method) + (pool-name (method-name execute-method))) + (setf (method-descriptor-index execute-method) + (pool-name (method-descriptor execute-method))) + +lisp-ctf-class+) (if *hairy-arglist-p* +lisp-compiled-function-class+ +lisp-primitive-class+))) @@ -9251,4 +9258,4 @@ (initialize-p2-handlers) -(provide "COMPILER-PASS2") \ No newline at end of file +(provide "COMPILER-PASS2") From vvoutilainen at common-lisp.net Sun Dec 21 23:55:42 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 21 Dec 2008 23:55:42 +0000 Subject: [armedbear-cvs] r11467 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun Dec 21 23:55:41 2008 New Revision: 11467 Log: generate-type-check-for-value is very similar to generate-type-check-for-variable, clean up generate-type-check-for-value before combining the functions. 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 Dec 21 23:55:41 2008 @@ -7926,22 +7926,15 @@ (declaim (ftype (function (t) t) generate-type-check-for-value)) (defun generate-type-check-for-value (declared-type) - (cond ((eq declared-type 'SYMBOL) - (generate-instanceof-type-check-for-value 'SYMBOL)) - ((eq declared-type 'CHARACTER) - (generate-instanceof-type-check-for-value 'CHARACTER)) - ((eq declared-type 'CONS) - (generate-instanceof-type-check-for-value 'CONS)) - ((eq declared-type 'HASH-TABLE) - (generate-instanceof-type-check-for-value 'HASH-TABLE)) - ((fixnum-type-p declared-type) - (generate-instanceof-type-check-for-value 'FIXNUM)) - ((subtypep declared-type 'STRING) - (generate-instanceof-type-check-for-value 'STRING)) - ((subtypep declared-type 'VECTOR) - (generate-instanceof-type-check-for-value 'VECTOR)) - (t - nil))) + (let* ((type-to-use + (or + (when (fixnum-type-p declared-type) 'FIXNUM) + (find-if #'(lambda (type) (eq type declared-type)) + `(SYMBOL CHARACTER CONS HASH-TABLE STREAM)) + (find-if #'(lambda (type) (subtypep declared-type type)) + `(STRING VECTOR))))) + (when type-to-use + (generate-instanceof-type-check-for-value type-to-use)))) (defun p2-the (form target representation) (let ((type-form (second form)) From vvoutilainen at common-lisp.net Mon Dec 22 00:28:22 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 22 Dec 2008 00:28:22 +0000 Subject: [armedbear-cvs] r11468 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Dec 22 00:28:22 2008 New Revision: 11468 Log: Combine the shared functionality of generate-type-check-for-variable and generate-type-check-for-value. 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 Mon Dec 22 00:28:22 2008 @@ -477,17 +477,20 @@ (label LABEL1)) t) +(defun find-type-for-type-check (declared-type) + (if (eq declared-type :none) nil + (or + (when (fixnum-type-p declared-type) 'FIXNUM) + (find-if #'(lambda (type) (eq type declared-type)) + `(SYMBOL CHARACTER CONS HASH-TABLE STREAM)) + (find-if #'(lambda (type) (subtypep declared-type type)) + `(STRING VECTOR))))) + + (defknown generate-type-check-for-variable (t) t) (defun generate-type-check-for-variable (variable) - (let* ((declared-type (variable-declared-type variable)) - (type-to-use - (if (eq declared-type :none) nil - (or - (when (fixnum-type-p declared-type) 'FIXNUM) - (find-if #'(lambda (type) (eq type declared-type)) - `(SYMBOL CHARACTER CONS HASH-TABLE STREAM)) - (find-if #'(lambda (type) (subtypep declared-type type)) - `(STRING VECTOR)))))) + (let ((type-to-use + (find-type-for-type-check (variable-declared-type variable)))) (when type-to-use (generate-instanceof-type-check-for-variable variable type-to-use)))) @@ -7926,13 +7929,7 @@ (declaim (ftype (function (t) t) generate-type-check-for-value)) (defun generate-type-check-for-value (declared-type) - (let* ((type-to-use - (or - (when (fixnum-type-p declared-type) 'FIXNUM) - (find-if #'(lambda (type) (eq type declared-type)) - `(SYMBOL CHARACTER CONS HASH-TABLE STREAM)) - (find-if #'(lambda (type) (subtypep declared-type type)) - `(STRING VECTOR))))) + (let ((type-to-use (find-type-for-type-check declared-type))) (when type-to-use (generate-instanceof-type-check-for-value type-to-use)))) From vvoutilainen at common-lisp.net Mon Dec 22 12:15:23 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 22 Dec 2008 12:15:23 +0000 Subject: [armedbear-cvs] r11469 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Dec 22 12:15:22 2008 New Revision: 11469 Log: Combine ifne instruction generation into a helper function for p2-eql. 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 Mon Dec 22 12:15:22 2008 @@ -2388,6 +2388,20 @@ (emit-move-from-stack target representation)) t) +(defun emit-ifne-for-eql (representation instruction-type) + (emit-invokevirtual +lisp-object-class+ "eql" instruction-type "Z") + (case representation + (:boolean) + (t + (let ((label1 (gensym)) + (label2 (gensym))) + (emit 'ifne `,label1) + (emit-push-nil) + (emit 'goto `,label2) + (emit 'label `,label1) + (emit-push-t) + (emit 'label `,label2))))) + (defknown p2-eql (t t t) t) (defun p2-eql (form target representation) (aver (or (null representation) (eq representation :boolean))) @@ -2413,65 +2427,21 @@ ((fixnum-type-p type2) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) - (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") - (case representation - (:boolean) - (t - (let ((label1 (gensym)) - (label2 (gensym))) - (emit 'ifne `,label1) - (emit-push-nil) - (emit 'goto `,label2) - (emit 'label `,label1) - (emit-push-t) - (emit 'label `,label2))))) + (emit-ifne-for-eql representation '("I"))) ((fixnum-type-p type1) (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") - (case representation - (:boolean) - (t - (let ((label1 (gensym)) - (label2 (gensym))) - (emit 'ifne `,label1) - (emit-push-nil) - (emit 'goto `,label2) - (emit 'label `,label1) - (emit-push-t) - (emit 'label `,label2))))) + (emit-ifne-for-eql representation '("I"))) ((eq type2 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :char) - (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") - (case representation - (:boolean) - (t - (let ((label1 (gensym)) - (label2 (gensym))) - (emit 'ifne `,label1) - (emit-push-nil) - (emit 'goto `,label2) - (emit 'label `,label1) - (emit-push-t) - (emit 'label `,label2))))) + (emit-ifne-for-eql representation '("C"))) ((eq type1 'CHARACTER) (compile-forms-and-maybe-emit-clear-values arg1 'stack :char arg2 'stack nil) (emit 'swap) - (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z") - (case representation - (:boolean) - (t - (let ((label1 (gensym)) - (label2 (gensym))) - (emit 'ifne `,label1) - (emit-push-nil) - (emit 'goto `,label2) - (emit 'label `,label1) - (emit-push-t) - (emit 'label `,label2))))) + (emit-ifne-for-eql representation '("C"))) (t (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) From vvoutilainen at common-lisp.net Mon Dec 22 13:50:26 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Mon, 22 Dec 2008 13:50:26 +0000 Subject: [armedbear-cvs] r11470 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Mon Dec 22 13:50:25 2008 New Revision: 11470 Log: Remove unnecessary backquote-comma from emit-ifne-for-eql. 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 Mon Dec 22 13:50:25 2008 @@ -2395,12 +2395,12 @@ (t (let ((label1 (gensym)) (label2 (gensym))) - (emit 'ifne `,label1) + (emit 'ifne label1) (emit-push-nil) - (emit 'goto `,label2) - (emit 'label `,label1) + (emit 'goto label2) + (emit 'label label1) (emit-push-t) - (emit 'label `,label2))))) + (emit 'label label2))))) (defknown p2-eql (t t t) t) (defun p2-eql (form target representation) From ehuelsmann at common-lisp.net Mon Dec 22 18:33:18 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 22 Dec 2008 18:33:18 +0000 Subject: [armedbear-cvs] r11471 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Dec 22 18:33:18 2008 New Revision: 11471 Log: Follow up to r11465: pass 'arg' to _execute() [making sure we call the right _execute()]. Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Mon Dec 22 18:33:18 2008 @@ -68,7 +68,7 @@ public final LispObject execute(LispObject arg) throws ConditionThrowable { - return _execute(ctx); + return _execute(ctx, arg); } public final LispObject execute(LispObject first, LispObject second) From ehuelsmann at common-lisp.net Mon Dec 22 20:13:12 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 22 Dec 2008 20:13:12 +0000 Subject: [armedbear-cvs] r11472 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Dec 22 20:13:11 2008 New Revision: 11472 Log: Eliminate the need for CompiledClosure: duplicate ClosureTemplateFunction and set its ctx field. Note: This commit is in preparation of fixing DEFUN.6 and DEFUN.7. 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 Mon Dec 22 20:13:11 2008 @@ -191,6 +191,7 @@ (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") +(defconstant +lisp-ctf+ "Lorg/armedbear/lisp/ClosureTemplateFunction;") (defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") @@ -2844,6 +2845,15 @@ (emit 'aload register) (emit 'aastore)))) + +(defun emit-dup-ctf-and-set-context (compiland) + (emit 'checkcast +lisp-ctf-class+) + (emit-invokevirtual +lisp-ctf-class+ "dup" nil +lisp-ctf+) + (emit 'aload (compiland-closure-register compiland)) + (emit-invokevirtual +lisp-ctf-class+ "setContext" + (list +lisp-object-array+) + +lisp-ctf+)) + (defknown compile-local-function-call (t t t) t) (defun compile-local-function-call (form target representation) "Compiles a call to a function marked as `*child-p*'; a local function. @@ -2874,11 +2884,7 @@ (declare-object (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* - (emit 'checkcast +lisp-ctf-class+) - (emit 'aload (compiland-closure-register compiland)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+))))) + (emit-dup-ctf-and-set-context compiland))))) (let ((must-clear-values nil)) (declare (type boolean must-clear-values)) (cond ((> (length args) call-registers-limit) @@ -4783,13 +4789,7 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) - (emit 'checkcast +lisp-ctf-class+) - (emit 'aload (compiland-closure-register parent)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+))) + (emit-dup-ctf-and-set-context parent))) (dformat t "p2-flet-process-compiland var-set ~S~%" (variable-name (local-function-variable local-function))) (emit 'var-set (local-function-variable local-function))))) @@ -4809,13 +4809,7 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) - (emit 'checkcast +lisp-ctf-class+) - (emit 'aload (compiland-closure-register parent)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+))) + (emit-dup-ctf-and-set-context parent))) (emit 'var-set (local-function-variable local-function))))) (delete-file pathname))))))) @@ -4839,13 +4833,7 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) - (emit 'checkcast +lisp-ctf-class+) - (emit 'aload (compiland-closure-register parent)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+))) + (emit-dup-ctf-and-set-context parent))) (emit 'var-set (local-function-variable local-function))))) @@ -4862,13 +4850,7 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (dformat t "(compiland-closure-register parent) = ~S~%" - (compiland-closure-register parent)) - (emit 'checkcast +lisp-ctf-class+) - (emit 'aload (compiland-closure-register parent)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+))) + (emit-dup-ctf-and-set-context parent))) (emit 'var-set (local-function-variable local-function)))) (delete-file pathname))))))) @@ -4946,11 +4928,9 @@ (delete-file pathname))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) - (emit 'aload (compiland-closure-register *current-compiland*)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+) - (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure + (emit-dup-ctf-and-set-context *current-compiland*) + ; Stack: cloned template function + ) (t (aver nil))) ;; Shouldn't happen. (emit-move-from-stack target))) @@ -4977,11 +4957,7 @@ (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when (compiland-closure-register *current-compiland*) - (emit 'checkcast +lisp-ctf-class+) - (emit 'aload (compiland-closure-register *current-compiland*)) - (emit-invokestatic +lisp-class+ "makeCompiledClosure" - (list +lisp-object+ +lisp-object-array+) - +lisp-object+))))) + (emit-dup-ctf-and-set-context *current-compiland*))))) (emit-move-from-stack target)) ((inline-ok name) (emit 'getstatic *this-class* From ehuelsmann at common-lisp.net Mon Dec 22 20:58:47 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 22 Dec 2008 20:58:47 +0000 Subject: [armedbear-cvs] r11473 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Dec 22 20:58:47 2008 New Revision: 11473 Log: Set missing svn:eol-style and svn:keywords properties. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (props changed) trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (props changed) From ehuelsmann at common-lisp.net Wed Dec 24 21:45:05 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 24 Dec 2008 21:45:05 +0000 Subject: [armedbear-cvs] r11474 - public_html Message-ID: Author: ehuelsmann Date: Wed Dec 24 21:45:03 2008 New Revision: 11474 Log: Add reference to the examples created by Ville on the integration between ABCL and Java. Suggested by: Brian Otter Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Wed Dec 24 21:45:03 2008 @@ -43,6 +43,18 @@ The latest version is 0.12.0, released December 14, 2008. + +

+ Examples +

+
+
+ In the source repository there are + examples + on how to integrate the Lisp environment with your Java code, + showing you how to call back and forth between the two.
+
+

Download

From ehuelsmann at common-lisp.net Thu Dec 25 09:35:20 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Dec 2008 09:35:20 +0000 Subject: [armedbear-cvs] r11475 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 25 09:35:19 2008 New Revision: 11475 Log: Cleanup: remove dead code, empty statements and add @Override annotations. Modified: trunk/abcl/src/org/armedbear/lisp/Package.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 Thu Dec 25 09:35:19 2008 @@ -70,16 +70,19 @@ lispName = new SimpleString(name); } + @Override public LispObject typeOf() { return Symbol.PACKAGE; } + @Override public LispObject classOf() { return BuiltInClass.PACKAGE; } + @Override public LispObject getDescription() { if (name != null) { @@ -91,6 +94,7 @@ return new SimpleString("PACKAGE"); } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.PACKAGE) @@ -110,6 +114,7 @@ return lispName != null ? lispName : NIL; } + @Override public final LispObject getPropertyList() { if (propertyList == null) @@ -117,6 +122,7 @@ return propertyList; } + @Override public final void setPropertyList(LispObject obj) { if (obj == null) @@ -263,22 +269,6 @@ } } - private synchronized Symbol addSymbol(SimpleString name) - { - Symbol symbol = new Symbol(name, this); - try { - if (this == PACKAGE_KEYWORD) { - symbol.initializeConstant(symbol); - externalSymbols.put(name, symbol); - } else - internalSymbols.put(name, symbol); - } - catch (Throwable t) { - Debug.trace(t); // FIXME - } - return symbol; - } - private synchronized Symbol addSymbol(SimpleString name, int hash) { Symbol symbol = new Symbol(name, hash, this); @@ -507,7 +497,7 @@ if (sym != null && sym != symbol) { if (pkg.shadowingSymbols != null && pkg.shadowingSymbols.get(symbolName) == sym) { - ; // OK. + // OK. } else { FastStringBuffer sb = new FastStringBuffer("The symbol "); sb.append(sym.getQualifiedName()); @@ -789,7 +779,7 @@ LispObject list = NIL; List symbols = internalSymbols.getSymbols(); for (int i = symbols.size(); i-- > 0;) - list = new Cons((Symbol)symbols.get(i), list);; + list = new Cons((Symbol)symbols.get(i), list); return list; } @@ -798,7 +788,7 @@ LispObject list = NIL; List symbols = externalSymbols.getSymbols(); for (int i = symbols.size(); i-- > 0;) - list = new Cons((Symbol)symbols.get(i), list);; + list = new Cons((Symbol)symbols.get(i), list); return list; } @@ -858,6 +848,7 @@ return array; } + @Override public String writeToString() throws ConditionThrowable { if (_PRINT_FASL_.symbolValue() != NIL && name != null) { From ehuelsmann at common-lisp.net Thu Dec 25 09:37:48 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Dec 2008 09:37:48 +0000 Subject: [armedbear-cvs] r11476 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 25 09:37:47 2008 New Revision: 11476 Log: Cleanup: make 2 newly added functions 'final'. Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Thu Dec 25 09:37:47 2008 @@ -45,13 +45,13 @@ super(list2(Symbol.LAMBDA, lambdaList), null); } - public ClosureTemplateFunction setContext(LispObject[] context) + final public ClosureTemplateFunction setContext(LispObject[] context) { ctx = context; return this; } - public ClosureTemplateFunction dup() + final public ClosureTemplateFunction dup() throws CloneNotSupportedException { return (ClosureTemplateFunction)super.clone(); From ehuelsmann at common-lisp.net Thu Dec 25 09:40:06 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Dec 2008 09:40:06 +0000 Subject: [armedbear-cvs] r11477 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 25 09:40:05 2008 New Revision: 11477 Log: Cleanup: remove empty statements and add @Override annotations. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Interpreter.java Thu Dec 25 09:40:05 2008 @@ -446,7 +446,7 @@ thread.backtrace(); } catch (Throwable t) { - ; + } } @@ -481,6 +481,7 @@ interpreter = null; } + @Override protected void finalize() throws Throwable { System.err.println("Interpreter.finalize"); @@ -489,6 +490,7 @@ private static final Primitive _DEBUGGER_HOOK_FUNCTION = new Primitive("%debugger-hook-function", PACKAGE_SYS, false) { + @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { From ehuelsmann at common-lisp.net Thu Dec 25 11:46:10 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Dec 2008 11:46:10 +0000 Subject: [armedbear-cvs] r11478 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 25 11:46:10 2008 New Revision: 11478 Log: Cleanup: remove dead code (including a redefinition of 'equals' which is the same as its super definition); add @Override annotations. Modified: trunk/abcl/src/org/armedbear/lisp/Function.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Operator.java trunk/abcl/src/org/armedbear/lisp/SocketStream.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/socket_stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Function.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Function.java Thu Dec 25 11:46:10 2008 @@ -136,16 +136,19 @@ setLambdaList(lambdaList); } + @Override public LispObject typeOf() { return Symbol.FUNCTION; } + @Override public LispObject classOf() { return BuiltInClass.FUNCTION; } + @Override public LispObject typep(LispObject typeSpecifier) throws ConditionThrowable { if (typeSpecifier == Symbol.FUNCTION) @@ -157,6 +160,7 @@ return super.typep(typeSpecifier); } + @Override public final LispObject getPropertyList() { if (propertyList == null) @@ -164,6 +168,7 @@ return propertyList; } + @Override public final void setPropertyList(LispObject obj) { if (obj == null) @@ -177,22 +182,26 @@ new JavaObject(bytes)); } + @Override public LispObject execute() throws ConditionThrowable { return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -200,6 +209,7 @@ return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -207,6 +217,7 @@ return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) @@ -215,6 +226,7 @@ return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -223,6 +235,7 @@ return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, @@ -232,6 +245,7 @@ return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, @@ -241,11 +255,13 @@ return error(new WrongNumberOfArgumentsException(this)); } + @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { return error(new WrongNumberOfArgumentsException(this)); } + @Override public String writeToString() throws ConditionThrowable { LispObject name = getLambdaName(); @@ -290,17 +306,20 @@ error(new WrongNumberOfArgumentsException(this)); } + @Override // Profiling. public final int getCallCount() { return callCount; } + @Override public void setCallCount(int n) { callCount = n; } + @Override public final void incrementCallCount() { ++callCount; Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Thu Dec 25 11:46:10 2008 @@ -1933,6 +1933,7 @@ public static final Primitive REMEMBER = new Primitive("remember", PACKAGE_SYS, true) { + @Override public LispObject execute(LispObject key, LispObject value) throws ConditionThrowable { @@ -2479,6 +2480,7 @@ public static final LispObject UNBOUND_VALUE = new LispObject() { + @Override public String writeToString() { return "#"; @@ -2487,6 +2489,7 @@ public static final LispObject NULL_VALUE = new LispObject() { + @Override public String writeToString() { return "null"; Modified: trunk/abcl/src/org/armedbear/lisp/Operator.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Operator.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Operator.java Thu Dec 25 11:46:10 2008 @@ -59,6 +59,7 @@ lambdaList = obj; } + @Override public LispObject getParts() throws ConditionThrowable { LispObject result = NIL; Modified: trunk/abcl/src/org/armedbear/lisp/SocketStream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SocketStream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/SocketStream.java Thu Dec 25 11:46:10 2008 @@ -45,16 +45,19 @@ this.socket = socket; } + @Override public LispObject typeOf() { return Symbol.SOCKET_STREAM; } + @Override public LispObject classOf() { return BuiltInClass.SOCKET_STREAM; } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.SOCKET_STREAM) @@ -64,6 +67,7 @@ return super.typep(type); } + @Override public LispObject close(LispObject abort) throws ConditionThrowable { try { @@ -75,6 +79,7 @@ } } + @Override public String toString() { return unreadableString("SOCKET-STREAM"); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Thu Dec 25 11:46:10 2008 @@ -95,6 +95,7 @@ this.pkg = pkg; } + @Override public LispObject typeOf() { if (pkg == PACKAGE_KEYWORD) @@ -104,11 +105,13 @@ return Symbol.SYMBOL; } + @Override public LispObject classOf() { return BuiltInClass.SYMBOL; } + @Override public LispObject getDescription() throws ConditionThrowable { final LispThread thread = LispThread.currentThread(); @@ -137,6 +140,7 @@ } } + @Override public LispObject getParts() throws ConditionThrowable { LispObject parts = NIL; @@ -150,6 +154,7 @@ return parts.nreverse(); } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.SYMBOL) @@ -163,16 +168,19 @@ return super.typep(type); } + @Override public final LispObject SYMBOLP() { return T; } + @Override public boolean constantp() { return (flags & FLAG_CONSTANT) != 0; } + @Override public final LispObject STRING() { return name; @@ -188,11 +196,13 @@ pkg = obj; } + @Override public final boolean isSpecialOperator() { return (function instanceof SpecialOperator); } + @Override public final boolean isSpecialVariable() { return (flags & FLAG_SPECIAL) != 0; @@ -274,6 +284,7 @@ } // Raw accessor. + @Override public LispObject getSymbolValue() { return value; @@ -326,11 +337,13 @@ return value; } + @Override public LispObject getSymbolFunction() { return function; } + @Override public final LispObject getSymbolFunctionOrDie() throws ConditionThrowable { if (function == null) @@ -359,6 +372,7 @@ this.function = obj; } + @Override public final LispObject getPropertyList() { if (propertyList == null) @@ -366,6 +380,7 @@ return propertyList; } + @Override public final void setPropertyList(LispObject obj) { if (obj == null) @@ -373,6 +388,7 @@ propertyList = obj; } + @Override public String writeToString() throws ConditionThrowable { final String n = name.getStringValue(); @@ -685,6 +701,7 @@ return sb.toString(); } + @Override public final int sxhash() { int h = hash; @@ -696,11 +713,7 @@ return h; } - public final boolean equals(Object obj) - { - return this == obj; - } - + @Override public LispObject execute() throws ConditionThrowable { try @@ -713,6 +726,7 @@ } } + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { try @@ -725,6 +739,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { @@ -738,6 +753,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -752,6 +768,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) throws ConditionThrowable @@ -766,6 +783,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) @@ -781,6 +799,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) @@ -797,6 +816,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, @@ -816,6 +836,7 @@ } } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, @@ -835,6 +856,7 @@ } } + @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { try @@ -850,15 +872,6 @@ } } - private final LispObject signalNPE(NullPointerException e) - throws ConditionThrowable - { - if (function == null) - return error(new UndefinedFunction(this)); - Debug.trace(e); - return error(new LispError("Null pointer exception")); - } - private final LispObject handleNPE(NullPointerException e, LispObject args) throws ConditionThrowable { @@ -869,6 +882,7 @@ return error(new LispError("Null pointer exception")); } + @Override public void incrementCallCount() { if (function != null) 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 Thu Dec 25 11:46:10 2008 @@ -43,6 +43,7 @@ super("%socket-stream", PACKAGE_SYS, false, "socket element-type external-format"); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { From ehuelsmann at common-lisp.net Thu Dec 25 13:58:02 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 25 Dec 2008 13:58:02 +0000 Subject: [armedbear-cvs] r11479 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Dec 25 13:58:01 2008 New Revision: 11479 Log: Fix compiled TAGBODY failures which were broken by the fixes to macro expansion. 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 Thu Dec 25 13:58:01 2008 @@ -959,7 +959,20 @@ ((null body) (cons 'TAGBODY (nreverse result))) (if (atom (car body)) (push (car body) result) - (push (precompile1 (car body)) result)))) + (push (let* ((first-form (car body)) + (expanded (precompile1 first-form))) + (if (and (symbolp expanded) + (neq expanded first-form)) + ;; Workaround: + ;; Since our expansion/compilation order + ;; is out of sync with the definition of + ;; TAGBODY (which requires the compiler + ;; to look for tags before expanding), + ;; we need to disguise anything which might + ;; look like a tag. We do this by wrapping + ;; it in a PROGN form. + (list 'PROGN expanded) + expanded)) result)))) (defun precompile-eval-when (form) (list* 'EVAL-WHEN (cadr form) (mapcar #'precompile1 (cddr form)))) From ehuelsmann at common-lisp.net Fri Dec 26 10:14:12 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 26 Dec 2008 10:14:12 +0000 Subject: [armedbear-cvs] r11480 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 26 10:14:11 2008 New Revision: 11480 Log: Revert r11472: somehow macro-expansion was influenced by it (badly). Note: This commit should come back, but in modified form. 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 Fri Dec 26 10:14:11 2008 @@ -191,7 +191,6 @@ (defconstant +lisp-return-class+ "org/armedbear/lisp/Return") (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") -(defconstant +lisp-ctf+ "Lorg/armedbear/lisp/ClosureTemplateFunction;") (defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure") (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") @@ -2845,15 +2844,6 @@ (emit 'aload register) (emit 'aastore)))) - -(defun emit-dup-ctf-and-set-context (compiland) - (emit 'checkcast +lisp-ctf-class+) - (emit-invokevirtual +lisp-ctf-class+ "dup" nil +lisp-ctf+) - (emit 'aload (compiland-closure-register compiland)) - (emit-invokevirtual +lisp-ctf-class+ "setContext" - (list +lisp-object-array+) - +lisp-ctf+)) - (defknown compile-local-function-call (t t t) t) (defun compile-local-function-call (form target representation) "Compiles a call to a function marked as `*child-p*'; a local function. @@ -2884,7 +2874,11 @@ (declare-object (local-function-function local-function))))) (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when *closure-variables* - (emit-dup-ctf-and-set-context compiland))))) + (emit 'checkcast +lisp-ctf-class+) + (emit 'aload (compiland-closure-register compiland)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))))) (let ((must-clear-values nil)) (declare (type boolean must-clear-values)) (cond ((> (length args) call-registers-limit) @@ -4789,7 +4783,13 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (emit-dup-ctf-and-set-context parent))) + (dformat t "(compiland-closure-register parent) = ~S~%" + (compiland-closure-register parent)) + (emit 'checkcast +lisp-ctf-class+) + (emit 'aload (compiland-closure-register parent)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))) (dformat t "p2-flet-process-compiland var-set ~S~%" (variable-name (local-function-variable local-function))) (emit 'var-set (local-function-variable local-function))))) @@ -4809,7 +4809,13 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (emit-dup-ctf-and-set-context parent))) + (dformat t "(compiland-closure-register parent) = ~S~%" + (compiland-closure-register parent)) + (emit 'checkcast +lisp-ctf-class+) + (emit 'aload (compiland-closure-register parent)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))) (emit 'var-set (local-function-variable local-function))))) (delete-file pathname))))))) @@ -4833,7 +4839,13 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (emit-dup-ctf-and-set-context parent))) + (dformat t "(compiland-closure-register parent) = ~S~%" + (compiland-closure-register parent)) + (emit 'checkcast +lisp-ctf-class+) + (emit 'aload (compiland-closure-register parent)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))) (emit 'var-set (local-function-variable local-function))))) @@ -4850,7 +4862,13 @@ (let ((parent (compiland-parent compiland))) (when (compiland-closure-register parent) - (emit-dup-ctf-and-set-context parent))) + (dformat t "(compiland-closure-register parent) = ~S~%" + (compiland-closure-register parent)) + (emit 'checkcast +lisp-ctf-class+) + (emit 'aload (compiland-closure-register parent)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))) (emit 'var-set (local-function-variable local-function)))) (delete-file pathname))))))) @@ -4928,9 +4946,11 @@ (delete-file pathname))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) - (emit-dup-ctf-and-set-context *current-compiland*) - ; Stack: cloned template function - ) + (emit 'aload (compiland-closure-register *current-compiland*)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+) + (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure (t (aver nil))) ;; Shouldn't happen. (emit-move-from-stack target))) @@ -4957,7 +4977,11 @@ (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function (when (compiland-closure-register *current-compiland*) - (emit-dup-ctf-and-set-context *current-compiland*))))) + (emit 'checkcast +lisp-ctf-class+) + (emit 'aload (compiland-closure-register *current-compiland*)) + (emit-invokestatic +lisp-class+ "makeCompiledClosure" + (list +lisp-object+ +lisp-object-array+) + +lisp-object+))))) (emit-move-from-stack target)) ((inline-ok name) (emit 'getstatic *this-class* From ehuelsmann at common-lisp.net Fri Dec 26 13:53:48 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 26 Dec 2008 13:53:48 +0000 Subject: [armedbear-cvs] r11481 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 26 13:53:47 2008 New Revision: 11481 Log: Change FASL version number because of changes to the object structure (_execute() instead of execute()). 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 Dec 26 13:53:47 2008 @@ -340,7 +340,7 @@ // ### *fasl-version* // internal symbol private static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, new Fixnum(28)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, new Fixnum(29)); // ### *fasl-anonymous-package* // internal symbol From ehuelsmann at common-lisp.net Fri Dec 26 16:06:07 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 26 Dec 2008 16:06:07 +0000 Subject: [armedbear-cvs] r11482 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Dec 26 16:06:07 2008 New Revision: 11482 Log: Followup to r11467: STREAM wasn't in the original list of types. Found by: mevenson 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 Fri Dec 26 16:06:07 2008 @@ -482,9 +482,9 @@ (or (when (fixnum-type-p declared-type) 'FIXNUM) (find-if #'(lambda (type) (eq type declared-type)) - `(SYMBOL CHARACTER CONS HASH-TABLE STREAM)) + '(SYMBOL CHARACTER CONS HASH-TABLE)) (find-if #'(lambda (type) (subtypep declared-type type)) - `(STRING VECTOR))))) + '(STRING VECTOR))))) (defknown generate-type-check-for-variable (t) t) From mevenson at common-lisp.net Fri Dec 26 22:53:13 2008 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 26 Dec 2008 22:53:13 +0000 Subject: [armedbear-cvs] r11483 - in trunk/abcl: . nbproject nbproject/configs Message-ID: Author: mevenson Date: Fri Dec 26 22:53:12 2008 New Revision: 11483 Log: Integrate build with Netbeans 6.x. Added: trunk/abcl/nbproject/ trunk/abcl/nbproject/build-impl.xml trunk/abcl/nbproject/configs/ trunk/abcl/nbproject/configs/J.properties trunk/abcl/nbproject/genfiles.properties trunk/abcl/nbproject/project.properties trunk/abcl/nbproject/project.xml trunk/abcl/netbeans-build.xml Added: trunk/abcl/nbproject/build-impl.xml ============================================================================== --- (empty file) +++ trunk/abcl/nbproject/build-impl.xml Fri Dec 26 22:53:12 2008 @@ -0,0 +1,630 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must set src.doc.dir + Must set src.themes.dir + Must set src.dir + Must set build.dir + Must set dist.dir + Must set build.classes.dir + Must set dist.javadoc.dir + Must set build.test.classes.dir + Must set build.test.results.dir + Must set build.classes.excludes + Must set dist.jar + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must set javac.includes + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must select some files in the IDE or set javac.includes + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + To run this application from the command line without Ant, try: + + + + + + + java -cp "${run.classpath.with.dist.jar}" ${main.class} + + + + + + + + + + + + + + + + + + + + + + + To run this application from the command line without Ant, try: + + java -jar "${dist.jar.resolved}" + + + + + + + + + + + + + + + + + + + Must select one file in the IDE or set run.class + + + + + + + + + + + + + + + + + + + + Must select one file in the IDE or set debug.class + + + + + Must set fix.includes + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Must select some files in the IDE or set javac.includes + + + + + + + + + + + + + + + + + + Some tests failed; see details above. + + + + + + + + + Must select some files in the IDE or set test.includes + + + + Some tests failed; see details above. + + + + + Must select one file in the IDE or set test.class + + + + + + + + + + + + + + + + + + + + + + + + + + + Must select one file in the IDE or set applet.url + + + + + + + + + Must select one file in the IDE or set applet.url + + + + + + + + + + + + + + + + + + + Added: trunk/abcl/nbproject/configs/J.properties ============================================================================== --- (empty file) +++ trunk/abcl/nbproject/configs/J.properties Fri Dec 26 22:53:12 2008 @@ -0,0 +1 @@ +main.class=Main Added: trunk/abcl/nbproject/genfiles.properties ============================================================================== --- (empty file) +++ trunk/abcl/nbproject/genfiles.properties Fri Dec 26 22:53:12 2008 @@ -0,0 +1,11 @@ +build.xml.data.CRC32=71623fcd +build.xml.script.CRC32=33676845 +build.xml.stylesheet.CRC32=be360661 +# This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml. +# Do not edit this file. You may delete it but then the IDE will never regenerate such files for you. +nbproject/build-impl.xml.data.CRC32=14c5a06e +nbproject/build-impl.xml.script.CRC32=fe8c9181 +nbproject/build-impl.xml.stylesheet.CRC32=487672f9 +nbproject/profiler-build-impl.xml.data.CRC32=71623fcd +nbproject/profiler-build-impl.xml.script.CRC32=abda56ed +nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf Added: trunk/abcl/nbproject/project.properties ============================================================================== --- (empty file) +++ trunk/abcl/nbproject/project.properties Fri Dec 26 22:53:12 2008 @@ -0,0 +1,68 @@ +application.title=abcl +application.vendor= +build.classes.dir=${build.dir}/classes +build.classes.excludes=**/*.java,**/*.form +# This directory is removed when the project is cleaned: +build.dir=build +build.generated.dir=${build.dir}/generated +# Only compile against the classpath explicitly listed here: +build.sysclasspath=ignore +build.test.classes.dir=${build.dir}/test/classes +build.test.results.dir=${build.dir}/test/results +debug.classpath=\ + ${run.classpath} +debug.test.classpath=\ + ${run.test.classpath} +# This directory is removed when the project is cleaned: +dist.dir=dist +dist.jar=${dist.dir}/abcl.jar +dist.javadoc.dir=${dist.dir}/javadoc +excludes= +file.reference.abcl-src=src +includes=org/armedbear/lisp/*.lisp,org/armedbear/lisp/*.java +jar.compress=true +javac.classpath= +# Space-separated list of extra javac options +javac.compilerargs= +javac.deprecation=false +javac.source=1.5 +javac.target=1.5 +javac.test.classpath=\ + ${javac.classpath}:\ + ${build.classes.dir}:\ + ${libs.junit.classpath}:\ + ${libs.junit_4.classpath} +javadoc.additionalparam= +javadoc.author=false +javadoc.encoding=${source.encoding} +javadoc.noindex=false +javadoc.nonavbar=false +javadoc.notree=false +javadoc.private=false +javadoc.splitindex=true +javadoc.use=true +javadoc.version=false +javadoc.windowtitle= +jnlp.codebase.type=local +jnlp.codebase.url=file:/Users/evenson/work/abcl/dist/ +jnlp.enabled=false +jnlp.offline-allowed=false +jnlp.signed=false +main.class=org.armedbear.lisp.Main +manifest.file=manifest.mf +meta.inf.dir=${src.dir}/META-INF +platform.active=default_platform +run.classpath=\ + ${javac.classpath}:\ + ${build.classes.dir} +# Space-separated list of JVM arguments used when running the project +# (you may also define separate properties like run-sys-prop.name=value instead of -Dname=value +# or test-sys-prop.name=value to set system properties for unit tests): +run.jvmargs= +run.test.classpath=\ + ${javac.test.classpath}:\ + ${build.test.classes.dir} +source.encoding=UTF-8 +src.dir=${file.reference.abcl-src} +src.doc.dir=doc +src.themes.dir=themes Added: trunk/abcl/nbproject/project.xml ============================================================================== --- (empty file) +++ trunk/abcl/nbproject/project.xml Fri Dec 26 22:53:12 2008 @@ -0,0 +1,16 @@ + + + org.netbeans.modules.java.j2seproject + + + abcl + 1.6.5 + + + + + + + + + Added: trunk/abcl/netbeans-build.xml ============================================================================== --- (empty file) +++ trunk/abcl/netbeans-build.xml Fri Dec 26 22:53:12 2008 @@ -0,0 +1,26 @@ + + + + + + + + build.classes.dir: ${build.classes.dir} + + + + + + + + + + + + + + From mevenson at common-lisp.net Fri Dec 26 23:12:35 2008 From: mevenson at common-lisp.net (Mark Evenson) Date: Fri, 26 Dec 2008 23:12:35 +0000 Subject: [armedbear-cvs] r11484 - trunk/abcl/nbproject Message-ID: Author: mevenson Date: Fri Dec 26 23:12:35 2008 New Revision: 11484 Log: Removed obsolete references to 'j' artifacts in Netbeans build. 'abcl' should open in any Netbeans 6.x release. Modified: trunk/abcl/nbproject/build-impl.xml trunk/abcl/nbproject/genfiles.properties trunk/abcl/nbproject/project.properties trunk/abcl/nbproject/project.xml Modified: trunk/abcl/nbproject/build-impl.xml ============================================================================== --- trunk/abcl/nbproject/build-impl.xml (original) +++ trunk/abcl/nbproject/build-impl.xml Fri Dec 26 23:12:35 2008 @@ -68,8 +68,6 @@ - - @@ -124,8 +122,6 @@ - Must set src.doc.dir - Must set src.themes.dir Must set src.dir Must set build.dir Must set dist.dir @@ -147,7 +143,7 @@ - + @@ -166,7 +162,7 @@ - + @@ -215,13 +211,13 @@ - + - + @@ -252,6 +248,12 @@ + + + + + + @@ -261,7 +263,7 @@ - + @@ -308,6 +310,13 @@ =================== --> + + + + + + + @@ -321,8 +330,6 @@ - - @@ -330,7 +337,7 @@ - + @@ -338,13 +345,13 @@ Must select some files in the IDE or set javac.includes - + - + Java example instructions. Modified: trunk/abcl/examples/abcl/README Modified: trunk/abcl/examples/abcl/README ============================================================================== --- trunk/abcl/examples/abcl/README (original) +++ trunk/abcl/examples/abcl/README Tue Dec 30 15:10:17 2008 @@ -1,24 +1,33 @@ -Building and running instructions -================================= +ABCL Examples Building and Running Instructions +=============================================== -by Blake McBride - -In general, to compile a Java class file (like Main.java for example) -use: - - javac -cp ../../../abcl.jar Main.java - -where the "../../../" represents the path to your abcl.jar file. +code by Ville Voutilainen +instructions by Blake McBride +updated by Mark Evenson + +In general, to compile a Java class file (like Main.java for example +in the 'java_exception_in_lisp' subdirectory) use: + + cmd$ cd java_exception_in_lisp + cmd$ javac -cp ../../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. This compiles the Java source file "Main.java" into a JVM runtime or class file named "Main.class". To run the example (Main.class for example) from a Unix-like OS use: - java -cp ../../../abcl.jar:. Main + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main or in Windows use: - java -cp ../../../abcl.jar;. Main + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main -where "Main" is the initial class to run in your Java program. \ No newline at end of file +where "Main" is the initial class to run in your Java program. From vvoutilainen at common-lisp.net Tue Dec 30 15:36:46 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 30 Dec 2008 15:36:46 +0000 Subject: [armedbear-cvs] r11514 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Dec 30 15:36:46 2008 New Revision: 11514 Log: CompiledClosure should delegate to CTF.execute, not CTF._execute. Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java 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 Tue Dec 30 15:36:46 2008 @@ -54,20 +54,20 @@ @Override public LispObject execute() throws ConditionThrowable { - return ctf._execute(context); + return ctf.execute(); } @Override public LispObject execute(LispObject arg) throws ConditionThrowable { - return ctf._execute(context, arg); + return ctf.execute(arg); } @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { - return ctf._execute(context, first, second); + return ctf.execute(first, second); } @Override @@ -75,7 +75,7 @@ LispObject third) throws ConditionThrowable { - return ctf._execute(context, first, second, third); + return ctf.execute(first, second, third); } @Override @@ -83,7 +83,7 @@ LispObject third, LispObject fourth) throws ConditionThrowable { - return ctf._execute(context, first, second, third, fourth); + return ctf.execute(first, second, third, fourth); } @Override @@ -92,7 +92,7 @@ LispObject fifth) throws ConditionThrowable { - return ctf._execute(context, first, second, third, fourth, fifth); + return ctf.execute(first, second, third, fourth, fifth); } @Override @@ -101,7 +101,7 @@ LispObject fifth, LispObject sixth) throws ConditionThrowable { - return ctf._execute(context, first, second, third, fourth, fifth, sixth); + return ctf.execute(first, second, third, fourth, fifth, sixth); } @Override @@ -111,7 +111,7 @@ LispObject seventh) throws ConditionThrowable { - return ctf._execute(context, first, second, third, fourth, fifth, sixth, + return ctf.execute(first, second, third, fourth, fifth, sixth, seventh); } @@ -122,13 +122,13 @@ LispObject seventh, LispObject eighth) throws ConditionThrowable { - return ctf._execute(context, first, second, third, fourth, fifth, sixth, + return ctf.execute(first, second, third, fourth, fifth, sixth, seventh, eighth); } @Override public LispObject execute(LispObject[] args) throws ConditionThrowable { - return ctf._execute(context, args); + return ctf.execute(args); } } From mevenson at common-lisp.net Tue Dec 30 15:56:13 2008 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 30 Dec 2008 15:56:13 +0000 Subject: [armedbear-cvs] r11515 - trunk/abcl Message-ID: Author: mevenson Date: Tue Dec 30 15:56:12 2008 New Revision: 11515 Log: Remove references to building 'j' in the 'abcl' build.xml. To build 'j', one needs additional sources and resources that [are best found in the 'j' branch][j]. The best way to build 'j', is via using the [version of build.xml before the great-ant-refactoring][j-build.xml]. An older version of this file can be obtained via the proper digging through the svn:common-lisp.net repository. [j]: svn://common-lisp.net/project/armedbear/svn/trunk/j [j-build.xml]: http://abcl-dynamic-install.googlecode.com/svn/trunk/abcl/j-build.xml Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Tue Dec 30 15:56:12 2008 @@ -17,8 +17,6 @@ value="${basedir}/dist"/> - Main Ant targets: @@ -32,18 +30,13 @@ -- create source distributions in ${dist.dir} abcl.clean -- remove ABCL intermediate files - Corresponding targets for J exist, but currently aren't as well tested. - + Corresponding targets for J have been removed. - - @@ -67,10 +60,6 @@ - - - - Building ABCL version: ${abcl.version} + + + + Build-Version: ${build.version} - abcl.hostname: ${abcl.hostname} - - - - - - + - - + + + + + + + + + @@ -124,39 +117,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -169,17 +129,12 @@ Compiled ABCL with java version: ${java.version} - - - - @@ -223,15 +178,6 @@ file="${build.classes.dir}/org/armedbear/lisp/build"/> - - - - - - - @@ -250,7 +196,6 @@ - @@ -355,37 +300,6 @@ - - - - - - - - - - - - -
- - -
- - - - - - - - - - - - - @@ -411,64 +325,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - From ehuelsmann at common-lisp.net Tue Dec 30 20:23:46 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 30 Dec 2008 20:23:46 +0000 Subject: [armedbear-cvs] r11516 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 30 20:23:45 2008 New Revision: 11516 Log: Documentation of variable-info fields. Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp 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 Tue Dec 30 20:23:45 2008 @@ -236,15 +236,17 @@ name initform temp-register - special-p (declared-type :none) (derived-type :none) ignore-p ignorable-p representation - register ; register number or NIL - index - closure-index + special-p ; indicates whether a variable is special + register ; register number for a local variable + index ; index number for a variable in the argument array + closure-index ; index number for a variable in the closure context array + ;; a variable can be either special-p *or* have a register *or* + ;; have an index *or a closure-index reserved-register (reads 0 :type fixnum) (writes 0 :type fixnum) From ehuelsmann at common-lisp.net Tue Dec 30 20:31:33 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 30 Dec 2008 20:31:33 +0000 Subject: [armedbear-cvs] r11517 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 30 20:31:30 2008 New Revision: 11517 Log: Replace Java type indicator with pre-existing constant with the same purpose. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Dec 30 20:31:30 2008 @@ -1098,7 +1098,7 @@ (inst 'aload *thread*) (inst 'aconst_null) (inst 'putfield (list +lisp-thread-class+ "_values" - "[Lorg/armedbear/lisp/LispObject;"))))) + +lisp-object-array+))))) (dolist (instruction instructions) (vector-push-extend (resolve-instruction instruction) vector)))) (t @@ -3709,14 +3709,14 @@ (compile-form first-subform result-register nil) ;; Save multiple values returned by first subform. (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) (astore values-register) (dolist (subform subforms) (compile-form subform nil nil)) ;; Restore multiple values returned by first subform. (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") + (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) ;; Result. (aload result-register) (fix-boxing representation nil) @@ -3873,7 +3873,7 @@ (compile-form (third form) result-register nil) ;; Store values from values form in values register. (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) (emit-move-from-stack values-register) ;; Did we get just one value? (aload values-register) @@ -8114,7 +8114,7 @@ (label BEGIN-PROTECTED-RANGE) (compile-form protected-form result-register nil) (emit-push-current-thread) - (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") + (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+) (astore values-register) (label END-PROTECTED-RANGE)) (emit 'jsr CLEANUP) @@ -8136,7 +8136,7 @@ ;; Restore multiple values returned by protected form. (emit-push-current-thread) (aload values-register) - (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;") + (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+) ;; Result. (aload result-register) (emit-move-from-stack target) From ehuelsmann at common-lisp.net Tue Dec 30 20:42:57 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 30 Dec 2008 20:42:57 +0000 Subject: [armedbear-cvs] r11518 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Dec 30 20:42:57 2008 New Revision: 11518 Log: Eliminate dead code. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Dec 30 20:42:57 2008 @@ -1213,9 +1213,6 @@ (setf *code* nil) (dolist (instruction code) (case (instruction-opcode instruction) - (206 ; VAR-REF - ;; obsolete - (aver nil)) (207 ; VAR-SET (let ((variable (car (instruction-args instruction)))) (aver (variable-p variable)) Modified: trunk/abcl/src/org/armedbear/lisp/opcodes.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/opcodes.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/opcodes.lisp Tue Dec 30 20:42:57 2008 @@ -258,7 +258,7 @@ ;; (define-opcode push-value 203 nil 1) ;; (define-opcode store-value 204 nil -1) (define-opcode clear-values 205 0 0) -(define-opcode var-ref 206 0 0) +;;(define-opcode var-ref 206 0 0) (define-opcode var-set 207 0 0) (defparameter *last-opcode* 207) From vvoutilainen at common-lisp.net Tue Dec 30 21:48:35 2008 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Tue, 30 Dec 2008 21:48:35 +0000 Subject: [armedbear-cvs] r11519 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Tue Dec 30 21:48:34 2008 New Revision: 11519 Log: Remove code repetition in the beginning of p2-compiland. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Dec 30 21:48:34 2008 @@ -8466,40 +8466,34 @@ (when (memq '&REST args) (unless (or (memq '&OPTIONAL args) (memq '&KEY args)) (let ((arg-count (length args))) - (cond ((and (= arg-count 2) (eq (%car args) '&REST)) - (setf *using-arg-array* nil) - (setf *hairy-arglist-p* nil) - (setf descriptor (get-descriptor (lisp-object-arg-types 1) - +lisp-object+)) - (setf (compiland-kind compiland) :internal) - (setf super "org/armedbear/lisp/Primitive0R") - (setf args (cdr args)) - (setf execute-method-name "_execute") - (setf execute-method (make-method :name execute-method-name - :descriptor descriptor))) - ((and (= arg-count 3) (eq (%cadr args) '&REST)) - (setf *using-arg-array* nil) - (setf *hairy-arglist-p* nil) - (setf descriptor (get-descriptor (lisp-object-arg-types 2) - +lisp-object+)) - (setf (compiland-kind compiland) :internal) - (setf super "org/armedbear/lisp/Primitive1R") - (setf args (list (first args) (third args))) - (setf execute-method-name "_execute") - (setf execute-method (make-method :name execute-method-name - :descriptor descriptor))) - ((and (= arg-count 4) (eq (%caddr args) '&REST)) - (setf *using-arg-array* nil) - (setf *hairy-arglist-p* nil) - (setf descriptor (get-descriptor (list +lisp-object+ +lisp-object+ +lisp-object+) - +lisp-object+)) - (setf (compiland-kind compiland) :internal) - (setf super "org/armedbear/lisp/Primitive2R") - (setf args (list (first args) (second args) (fourth args))) - (setf execute-method-name "_execute") - (setf execute-method (make-method :name execute-method-name - :descriptor descriptor))) - ))))) + (when + (cond ((and (= arg-count 2) (eq (%car args) '&REST)) + (setf descriptor (get-descriptor + (lisp-object-arg-types 1) + +lisp-object+) + super "org/armedbear/lisp/Primitive0R" + args (cdr args))) + ((and (= arg-count 3) (eq (%cadr args) '&REST)) + (setf descriptor (get-descriptor + (lisp-object-arg-types 2) + +lisp-object+) + super "org/armedbear/lisp/Primitive1R" + args (list (first args) (third args)))) + ((and (= arg-count 4) (eq (%caddr args) '&REST)) + (setf descriptor (get-descriptor + (list +lisp-object+ + +lisp-object+ +lisp-object+) + +lisp-object+) + super "org/armedbear/lisp/Primitive2R" + args (list (first args) + (second args) (fourth args))))) + (setf *using-arg-array* nil + *hairy-arglist-p* nil + (compiland-kind compiland) :internal + execute-method-name "_execute" + execute-method (make-method + :name execute-method-name + :descriptor descriptor))))))) (dolist (var (compiland-arg-vars compiland)) (push var *visible-variables*)) From ehuelsmann at common-lisp.net Sun Dec 7 23:24:34 2008 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 07 Dec 2008 23:24:34 -0000 Subject: [armedbear-cvs] r11434 - in trunk/j: . src/org/armedbear/lisp src/org/armedbear/lisp/util Message-ID: Author: ehuelsmann Date: Sun Dec 7 23:24:31 2008 New Revision: 11434 Log: Merge open-external-format branch back to trunk. Added: trunk/j/src/org/armedbear/lisp/util/ - copied from r11432, /branches/open-external-format/src/org/armedbear/lisp/util/ Modified: trunk/j/build.xml trunk/j/src/org/armedbear/lisp/FileStream.java trunk/j/src/org/armedbear/lisp/Stream.java trunk/j/src/org/armedbear/lisp/StringInputStream.java trunk/j/src/org/armedbear/lisp/StringOutputStream.java trunk/j/src/org/armedbear/lisp/open.lisp trunk/j/src/org/armedbear/lisp/socket.lisp trunk/j/src/org/armedbear/lisp/socket_stream.java Modified: trunk/j/build.xml ============================================================================== --- trunk/j/build.xml (original) +++ trunk/j/build.xml Sun Dec 7 23:24:31 2008 @@ -100,6 +100,7 @@ + @@ -117,6 +118,7 @@ + Modified: trunk/j/src/org/armedbear/lisp/FileStream.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/FileStream.java (original) +++ trunk/j/src/org/armedbear/lisp/FileStream.java Sun Dec 7 23:24:31 2008 @@ -2,6 +2,7 @@ * FileStream.java * * Copyright (C) 2004-2006 Peter Graves + * Copyright (C) 2008 Hideo at Yokohama * $Id$ * * This program is free software; you can redistribute it and/or @@ -34,32 +35,39 @@ package org.armedbear.lisp; import java.io.File; +import java.io.InputStream; +import java.io.OutputStream; +import java.io.Reader; +import java.io.Writer; import java.io.FileNotFoundException; import java.io.IOException; import java.io.RandomAccessFile; +import org.armedbear.lisp.util.RandomAccessCharacterFile; public final class FileStream extends Stream { - private static final int BUFSIZE = 4096; - - private final RandomAccessFile raf; - private final RandomAccessFile in; - private final RandomAccessFile out; + private final RandomAccessCharacterFile racf; private final Pathname pathname; private final int bytesPerUnit; - private final byte[] inputBuffer; - private final byte[] outputBuffer; - - private long inputBufferFilePosition; - private int inputBufferOffset; - private int inputBufferCount; - private int outputBufferOffset; public FileStream(Pathname pathname, String namestring, LispObject elementType, LispObject direction, - LispObject ifExists) + LispObject ifExists, LispObject format) throws IOException { + /* externalFormat is a LispObject of which the first char is a + * name of a character encoding (such as :UTF-8 or :ISO-8859-1), used + * by ABCL as a string designator, unless the name is :CODE-PAGE. + * A real string is (thus) also allowed. + * + * Then, a property list follows with 3 possible keys: + * :ID (values: code page numbers supported by MS-DOS/IBM-DOS/MS-Windows + * :EOL-STYLE (values: :CR / :LF / :CRLF [none means native]) + * :LITTLE-ENDIAN (values: NIL / T) + * + * These definitions have been taken from FLEXI-STREAMS: + * http://www.weitz.de/flexi-streams/#make-external-format + */ final File file = new File(namestring); String mode = null; if (direction == Keyword.INPUT) { @@ -73,10 +81,10 @@ isInputStream = true; isOutputStream = true; } + Debug.assertTrue(mode != null); - raf = new RandomAccessFile(file, mode); - in = isInputStream ? raf : null; - out = isOutputStream ? raf : null; + RandomAccessFile raf = new RandomAccessFile(file, mode); + // ifExists is ignored unless we have an output stream. if (isOutputStream) { final long length = file.isFile() ? file.length() : 0; @@ -89,11 +97,23 @@ raf.setLength(0); } } + setExternalFormat(format); + + // don't touch raf directly after passing it to racf. + // the state will become inconsistent if you do that. + racf = new RandomAccessCharacterFile(raf, encoding); + this.pathname = pathname; this.elementType = elementType; if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { isCharacterStream = true; bytesPerUnit = 1; + if (isInputStream) { + initAsCharacterInputStream(racf.getReader()); + } + if (isOutputStream) { + initAsCharacterOutputStream(racf.getWriter()); + } } else { isBinaryStream = true; int width; @@ -104,19 +124,13 @@ width = 8; } bytesPerUnit = width / 8; + if (isInputStream) { + initAsBinaryInputStream(racf.getInputStream()); + } + if (isOutputStream) { + initAsBinaryOutputStream(racf.getOutputStream()); + } } - if (isBinaryStream && isInputStream && !isOutputStream && bytesPerUnit == 1) - inputBuffer = new byte[BUFSIZE]; - else if (isCharacterStream && isInputStream && !isOutputStream) - inputBuffer = new byte[BUFSIZE]; - else - inputBuffer = null; - if (isBinaryStream && isOutputStream && !isInputStream && bytesPerUnit == 1) - outputBuffer = new byte[BUFSIZE]; - else if (isCharacterStream && isOutputStream && !isInputStream) - outputBuffer = new byte[BUFSIZE]; - else - outputBuffer = null; } @Override @@ -147,28 +161,12 @@ } @Override - public LispObject listen() throws ConditionThrowable - { - try { - return in.getFilePointer() < in.length() ? T : NIL; - } - catch (NullPointerException e) { - streamNotInputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - // Not reached. - return NIL; - } - - @Override public LispObject fileLength() throws ConditionThrowable { final long length; if (isOpen()) { try { - length = raf.length(); + length = racf.length(); } catch (IOException e) { error(new StreamError(this, e)); @@ -191,116 +189,10 @@ } @Override - public LispObject readLine(boolean eofError, LispObject eofValue) - throws ConditionThrowable - { - if (inputBuffer != null) { - final LispThread thread = LispThread.currentThread(); - final FastStringBuffer sb = new FastStringBuffer(); - while (true) { - int n = _readChar(); - if (n < 0) { - // End of file. - if (sb.length() == 0) { - if (eofError) - return error(new EndOfFile(this)); - return thread.setValues(eofValue, T); - } - return thread.setValues(new SimpleString(sb), T); - } - char c = (char) n; - if (c == '\n') - return thread.setValues(new SimpleString(sb), NIL); - else - sb.append(c); - } - } else - return super.readLine(eofError, eofValue); - } - - // Returns -1 at end of file. - @Override - protected int _readChar() throws ConditionThrowable - { - try { - int c = _readByte(); - if (Utilities.isPlatformWindows) { - if (c == '\r') { - int c2 = _readByte(); - if (c2 == '\n') { - ++lineNumber; - return c2; - } - // '\r' was not followed by '\n' - if (inputBuffer != null && inputBufferOffset > 0) { - --inputBufferOffset; - } else { - clearInputBuffer(); - long pos = in.getFilePointer(); - if (pos > 0) - in.seek(pos - 1); - } - } - return c; - } - if (c == '\n') { - ++lineNumber; - return c; - } - return c; - } - catch (NullPointerException e) { - streamNotInputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - // Not reached. - return -1; - } - - @Override protected void _unreadChar(int n) throws ConditionThrowable { - if (inputBuffer != null && inputBufferOffset > 0) { - --inputBufferOffset; - if (n != '\n') - return; - --lineNumber; - if (!Utilities.isPlatformWindows) - return; - // Check for preceding '\r'. - if (inputBufferOffset > 0) { - if (inputBuffer[--inputBufferOffset] != '\r') - ++inputBufferOffset; - return; - } - // We can't go back far enough in the buffered input. Reset and - // fall through... - ++inputBufferOffset; - } try { - long pos; - if (inputBuffer != null && inputBufferFilePosition >= 0) - pos = inputBufferFilePosition + inputBufferOffset; - else - pos = in.getFilePointer(); - clearInputBuffer(); - if (pos > 0) - in.seek(pos - 1); - if (Utilities.isPlatformWindows && n == '\n') { - // Check for preceding '\r'. - pos = in.getFilePointer(); - if (pos > 0) { - in.seek(pos - 1); - n = in.read(); - if (n == '\r') - in.seek(pos - 1); - } - } - } - catch (NullPointerException e) { - streamNotInputStream(); + racf.unreadChar((char)n); } catch (IOException e) { error(new StreamError(this, e)); @@ -314,141 +206,14 @@ } @Override - public void _writeChar(char c) throws ConditionThrowable - { - if (c == '\n') { - if (Utilities.isPlatformWindows) - _writeByte((byte)'\r'); - _writeByte((byte)c); - charPos = 0; - } else { - _writeByte((byte)c); - ++charPos; - } - } - - @Override - public void _writeChars(char[] chars, int start, int end) - throws ConditionThrowable - { - if (Utilities.isPlatformWindows) { - for (int i = start; i < end; i++) { - char c = chars[i]; - if (c == '\n') { - _writeByte((byte)'\r'); - _writeByte((byte)c); - charPos = 0; - } else { - _writeByte((byte)c); - ++charPos; - } - } - } else { - // We're not on Windows, so no newline conversion is necessary. - for (int i = start; i < end; i++) { - char c = chars[i]; - _writeByte((byte)c); - if (c == '\n') - charPos = 0; - else - ++charPos; - } - } - } - - @Override - public void _writeString(String s) throws ConditionThrowable - { - final int length = s.length(); - if (Utilities.isPlatformWindows) { - for (int i = 0; i < length; i++) { - char c = s.charAt(i); - if (c == '\n') { - _writeByte((byte)'\r'); - _writeByte((byte)c); - charPos = 0; - } else { - _writeByte((byte)c); - ++charPos; - } - } - } else { - // We're not on Windows, so no newline conversion is necessary. - for (int i = 0; i < length; i++) { - char c = s.charAt(i); - _writeByte((byte)c); - if (c == '\n') - charPos = 0; - else - ++charPos; - } - } - } - - @Override - public void _writeLine(String s) throws ConditionThrowable - { - _writeString(s); - if (Utilities.isPlatformWindows) - _writeByte((byte)'\r'); - _writeByte((byte)'\n'); - charPos = 0; - } - - // Reads an 8-bit byte. - @Override - public int _readByte() throws ConditionThrowable - { - if (inputBuffer != null) - return readByteFromBuffer(); - try { - return in.read(); // Reads an 8-bit byte. - } - catch (NullPointerException e) { - streamNotInputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - // Not reached. - return -1; - } - - // Writes an 8-bit byte. - @Override - public void _writeByte(int n) throws ConditionThrowable - { - if (outputBuffer != null) { - writeByteToBuffer((byte)n); - } else { - try { - out.write((byte)n); // Writes an 8-bit byte. - } - catch (NullPointerException e) { - streamNotOutputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - } - - @Override - public void _finishOutput() throws ConditionThrowable - { - if (outputBuffer != null) - flushOutputBuffer(); - } - - @Override public void _clearInput() throws ConditionThrowable { try { - in.seek(in.length()); - clearInputBuffer(); - } - catch (NullPointerException e) { - streamNotInputStream(); + if (isInputStream) { + racf.position(racf.length()); + } else { + streamNotInputStream(); + } } catch (IOException e) { error(new StreamError(this, e)); @@ -458,14 +223,8 @@ @Override protected long _getFilePosition() throws ConditionThrowable { - if (inputBuffer != null) { - if (inputBufferFilePosition >= 0) - return inputBufferFilePosition + inputBufferOffset; - } - if (outputBuffer != null) - flushOutputBuffer(); try { - long pos = raf.getFilePointer(); + long pos = racf.position(); return pos / bytesPerUnit; } catch (IOException e) { @@ -478,21 +237,17 @@ @Override protected boolean _setFilePosition(LispObject arg) throws ConditionThrowable { - if (outputBuffer != null) - flushOutputBuffer(); - if (inputBuffer != null) - clearInputBuffer(); try { long pos; if (arg == Keyword.START) pos = 0; else if (arg == Keyword.END) - pos = raf.length(); + pos = racf.length(); else { long n = Fixnum.getValue(arg); // FIXME arg might be a bignum pos = n * bytesPerUnit; } - raf.seek(pos); + racf.position(pos); } catch (IOException e) { error(new StreamError(this, e)); @@ -503,10 +258,8 @@ @Override public void _close() throws ConditionThrowable { - if (outputBuffer != null) - flushOutputBuffer(); try { - raf.close(); + racf.close(); setOpen(false); } catch (IOException e) { @@ -514,76 +267,21 @@ } } - private int readByteFromBuffer() throws ConditionThrowable - { - if (inputBufferOffset >= inputBufferCount) { - fillInputBuffer(); - if (inputBufferCount < 0) - return -1; - } - return inputBuffer[inputBufferOffset++] & 0xff; - } - - private void fillInputBuffer() throws ConditionThrowable - { - try { - inputBufferFilePosition = in.getFilePointer(); - inputBufferOffset = 0; - inputBufferCount = in.read(inputBuffer, 0, BUFSIZE); - } - catch (NullPointerException e) { - streamNotInputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - - private void clearInputBuffer() - { - inputBufferFilePosition = -1; - inputBufferOffset = 0; - inputBufferCount = 0; - } - - private void writeByteToBuffer(byte b) throws ConditionThrowable - { - if (outputBufferOffset == BUFSIZE) - flushOutputBuffer(); - outputBuffer[outputBufferOffset++] = b; - } - - private void flushOutputBuffer() throws ConditionThrowable - { - if (outputBufferOffset > 0) { - try { - out.write(outputBuffer, 0, outputBufferOffset); - outputBufferOffset = 0; - } - catch (NullPointerException e) { - streamNotOutputStream(); - } - catch (IOException e) { - error(new StreamError(this, e)); - } - } - } - @Override public String writeToString() throws ConditionThrowable { return unreadableString(Symbol.FILE_STREAM); } - // ### make-file-stream pathname namestring element-type direction if-exists => stream + // ### make-file-stream pathname namestring element-type direction if-exists external-format => stream private static final Primitive MAKE_FILE_STREAM = new Primitive("make-file-stream", PACKAGE_SYS, true, - "pathname namestring element-type direction if-exists") + "pathname namestring element-type direction if-exists external-format") { @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, - LispObject fifth) + LispObject fifth, LispObject sixth) throws ConditionThrowable { final Pathname pathname; @@ -603,12 +301,15 @@ LispObject elementType = third; LispObject direction = fourth; LispObject ifExists = fifth; + LispObject externalFormat = sixth; + if (direction != Keyword.INPUT && direction != Keyword.OUTPUT && direction != Keyword.IO) error(new LispError("Direction must be :INPUT, :OUTPUT, or :IO.")); try { return new FileStream(pathname, namestring.getStringValue(), - elementType, direction, ifExists); + elementType, direction, ifExists, + externalFormat); } catch (FileNotFoundException e) { return NIL; Modified: trunk/j/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/Stream.java (original) +++ trunk/j/src/org/armedbear/lisp/Stream.java Sun Dec 7 23:24:31 2008 @@ -43,6 +43,7 @@ import java.io.OutputStreamWriter; import java.io.PrintWriter; import java.io.PushbackReader; +import java.io.Reader; import java.io.StringWriter; import java.io.Writer; import java.math.BigInteger; @@ -62,11 +63,12 @@ protected boolean isCharacterStream; protected boolean isBinaryStream; + private boolean pastEnd = false; private boolean interactive; private boolean open = true; - + // Character input. - private PushbackReader reader; + protected PushbackReader reader; protected int offset; protected int lineNumber; @@ -79,29 +81,63 @@ * required when calling FRESH-LINE */ protected int charPos; - + + public enum EolStyle { + RAW, + CR, + CRLF, + LF + } + + static final protected Symbol keywordDefault = Packages.internKeyword("DEFAULT"); + + static final private Symbol keywordCodePage = Packages.internKeyword("CODE-PAGE"); + static final private Symbol keywordID = Packages.internKeyword("ID"); + + static final private Symbol keywordEolStyle = Packages.internKeyword("EOL-STYLE"); + static final private Symbol keywordCR = Packages.internKeyword("CR"); + static final private Symbol keywordLF = Packages.internKeyword("LF"); + static final private Symbol keywordCRLF = Packages.internKeyword("CRLF"); + static final private Symbol keywordRAW = Packages.internKeyword("RAW"); + + public final static EolStyle platformEolStyle = Utilities.isPlatformWindows ? EolStyle.CRLF : EolStyle.LF; + + protected EolStyle eolStyle = platformEolStyle; + protected char eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + protected LispObject externalFormat = LispObject.NIL; + protected String encoding = null; + protected char lastChar = 0; + // Binary input. - private BufferedInputStream in; + private InputStream in; // Binary output. - private BufferedOutputStream out; + private OutputStream out; protected Stream() { } - // Input stream constructors. public Stream(InputStream inputStream, LispObject elementType) + { + this(inputStream, elementType, keywordDefault); + } + + + // Input stream constructors. + public Stream(InputStream inputStream, LispObject elementType, LispObject format) { this.elementType = elementType; + setExternalFormat(format); if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - isCharacterStream = true; InputStreamReader inputStreamReader; try { inputStreamReader = - new InputStreamReader(inputStream, "ISO-8859-1"); + (encoding == null) ? + new InputStreamReader(inputStream) + : new InputStreamReader(inputStream, encoding); } catch (java.io.UnsupportedEncodingException e) { @@ -109,16 +145,14 @@ inputStreamReader = new InputStreamReader(inputStream); } - reader = new PushbackReader(new BufferedReader(inputStreamReader), - 2); + initAsCharacterInputStream(new BufferedReader(inputStreamReader)); } else { isBinaryStream = true; - in = new BufferedInputStream(inputStream); + InputStream stream = new BufferedInputStream(inputStream); + initAsBinaryInputStream(stream); } - isInputStream = true; - isOutputStream = false; } public Stream(InputStream inputStream, LispObject elementType, boolean interactive) @@ -127,30 +161,37 @@ setInteractive(interactive); } - // Output stream constructors. public Stream(OutputStream outputStream, LispObject elementType) + { + this(outputStream, elementType, keywordDefault); + } + + // Output stream constructors. + public Stream(OutputStream outputStream, LispObject elementType, LispObject format) { this.elementType = elementType; + setExternalFormat(format); if (elementType == Symbol.CHARACTER || elementType == Symbol.BASE_CHAR) { - isCharacterStream = true; + Writer w; try { - writer = new OutputStreamWriter(outputStream, "ISO-8859-1"); + w = (encoding == null) ? + new OutputStreamWriter(outputStream) + : new OutputStreamWriter(outputStream, encoding); } catch (java.io.UnsupportedEncodingException e) { Debug.trace(e); - writer = new OutputStreamWriter(outputStream); + w = new OutputStreamWriter(outputStream); } + initAsCharacterOutputStream(w); } else { - isBinaryStream = true; - out = new BufferedOutputStream(outputStream); + OutputStream stream = new BufferedOutputStream(outputStream); + initAsBinaryOutputStream(stream); } - isInputStream = false; - isOutputStream = true; } public Stream(OutputStream outputStream, LispObject elementType, @@ -160,6 +201,35 @@ setInteractive(interactive); } + protected void initAsCharacterInputStream(Reader reader) + { + if (! (reader instanceof PushbackReader)) + this.reader = new PushbackReader(reader, 5); + else + this.reader = (PushbackReader)reader; + + isInputStream = true; + isCharacterStream = true; + } + + protected void initAsBinaryInputStream(InputStream in) { + this.in = in; + isInputStream = true; + isBinaryStream = true; + } + + protected void initAsCharacterOutputStream(Writer writer) { + this.writer = writer; + isOutputStream = true; + isCharacterStream = true; + } + + protected void initAsBinaryOutputStream(OutputStream out) { + this.out = out; + isOutputStream = true; + isBinaryStream = true; + } + public boolean isInputStream() throws ConditionThrowable { return isInputStream; @@ -200,6 +270,76 @@ interactive = b; } + public LispObject getExternalFormat() { + return externalFormat; + } + + public String getEncoding() { + return encoding; + } + + public void setExternalFormat(LispObject format) { + if (format == keywordDefault) { + encoding = null; + eolStyle = platformEolStyle; + eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + externalFormat = format; + return; + } + + try { + LispObject enc; + boolean encIsCp = false; + + if (format instanceof Cons) { + // meaning a non-empty list + enc = format.car(); + + if (enc == keywordCodePage) { + encIsCp = true; + + enc = LispObject.getf(format.cdr(), keywordID, null); + } + + LispObject eol = LispObject.getf(format.cdr(), keywordEolStyle, keywordRAW); + if (eol == keywordCR) + eolStyle = EolStyle.CR; + else if (eol == keywordLF) + eolStyle = EolStyle.LF; + else if (eol == keywordCRLF) + eolStyle = EolStyle.CRLF; + else if (eol != keywordRAW) + //###FIXME: raise an error + ; + + } else + enc = format; + + if (enc.numberp()) + encoding = enc.toString(); + else if (enc instanceof AbstractString) + encoding = enc.getStringValue(); + else if (enc == keywordDefault) + // This allows the user to use the encoding determined by + // Java to be the default for the current environment + // while still being able to set other stream options + // (e.g. :EOL-STYLE) + encoding = null; + else if (enc instanceof Symbol) + encoding = ((Symbol)enc).getName(); + else + //###FIXME: raise an error! + ; + + if (encIsCp) + encoding = "Cp" + encoding; + } + catch (ConditionThrowable ct) { } + + eolChar = (eolStyle == EolStyle.CR) ? '\r' : '\n'; + externalFormat = format; + } + public boolean isOpen() { return open; @@ -1603,7 +1743,19 @@ public LispObject listen() throws ConditionThrowable { - return _charReady() ? T : NIL; + if (pastEnd) + return NIL; + + if (! _charReady()) + return NIL; + + int n = _readChar(); + if (n < 0) + return NIL; + + _unreadChar(n); + + return T; } public LispObject fileLength() throws ConditionThrowable @@ -1651,17 +1803,32 @@ */ protected int _readChar() throws ConditionThrowable { + if (pastEnd) + return -1; + try { int n = reader.read(); + + if (n < 0) { + pastEnd = true; + return -1; + } + ++offset; - if (n == '\r') - { - if (interactive && Utilities.isPlatformWindows) - return _readChar(); - } - if (n == '\n') + if (eolStyle == EolStyle.CRLF && n == '\r') { + n = _readChar(); + if (n != '\n') { + _unreadChar(n); + return '\r'; + } + } + + if (n == eolChar) { ++lineNumber; + return '\n'; + } + return n; } catch (NullPointerException e) @@ -1688,7 +1855,8 @@ { reader.unread(n); --offset; - if (n == '\n') + pastEnd = false; + if (n == eolChar) --lineNumber; } catch (NullPointerException e) @@ -1736,14 +1904,19 @@ { try { - writer.write(c); - if (c == '\n') - { - writer.flush(); - charPos = 0; - } - else + 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) { @@ -1769,7 +1942,18 @@ { 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;) { @@ -1777,19 +1961,19 @@ { index = i; break; - } - } + } + } if (index < 0) { // No newline. charPos += (end - start); - } + } else { charPos = end - (index + 1); - writer.flush(); - } - } + writer.flush(); + } + } catch (NullPointerException e) { if (writer == null) @@ -1813,15 +1997,7 @@ { try { - writer.write(s); - int index = s.lastIndexOf('\n'); - if (index < 0) - charPos += s.length(); - else - { - charPos = s.length() - (index + 1); - writer.flush(); - } + _writeChars(s.toCharArray(), 0, s.length()); } catch (NullPointerException e) { @@ -1830,10 +2006,6 @@ else throw e; } - catch (IOException e) - { - error(new StreamError(this, e)); - } } /** Writes a string to the underlying stream, appending @@ -1846,20 +2018,14 @@ { try { - writer.write(s); - writer.write('\n'); - writer.flush(); - charPos = 0; + _writeString(s); + _writeChar('\n'); } catch (NullPointerException e) { // writer is null streamNotCharacterOutputStream(); } - catch (IOException e) - { - error(new StreamError(this, e)); - } } // Reads an 8-bit byte. @@ -1872,7 +2038,11 @@ { try { - return in.read(); // Reads an 8-bit byte. + int n = in.read(); + if (n < 0) + pastEnd = true; + + return n; // Reads an 8-bit byte. } catch (IOException e) { @@ -1933,15 +2103,20 @@ { if (reader != null) { - while (_charReady()) - _readChar(); + int c = 0; + while (_charReady() && (c >= 0)) + c = _readChar(); } else if (in != null) { try { + int n = 0; while (in.available() > 0) - in.read(); + n = in.read(); + + if (n < 0) + pastEnd = true; } catch (IOException e) { @@ -2006,6 +2181,7 @@ { writer.write(sw.toString()); writer.write('\n'); + lastChar = '\n'; writer.flush(); charPos = 0; } Modified: trunk/j/src/org/armedbear/lisp/StringInputStream.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/StringInputStream.java (original) +++ trunk/j/src/org/armedbear/lisp/StringInputStream.java Sun Dec 7 23:24:31 2008 @@ -33,12 +33,13 @@ package org.armedbear.lisp; +import java.io.StringReader; + public final class StringInputStream extends Stream { - final String s; - final int start; - final int end; - + private final StringReader stringReader; + private final int start; + public StringInputStream(String s) { this(s, 0, s.length()); @@ -52,26 +53,28 @@ public StringInputStream(String s, int start, int end) { elementType = Symbol.CHARACTER; - isInputStream = true; - isOutputStream = false; - isCharacterStream = true; - isBinaryStream = false; - this.s = s; + setExternalFormat(keywordDefault); + eolStyle = EolStyle.RAW; + this.start = start; - this.end = end; - offset = start; + + stringReader = new StringReader(s.substring(start, end)); + initAsCharacterInputStream(stringReader); } + @Override public LispObject typeOf() { return Symbol.STRING_INPUT_STREAM; } + @Override public LispObject classOf() { return BuiltInClass.STRING_INPUT_STREAM; } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.STRING_INPUT_STREAM) @@ -85,57 +88,29 @@ return super.typep(type); } - public LispObject close(LispObject abort) throws ConditionThrowable - { - setOpen(false); - return T; - } - - public LispObject listen() - { - return offset < end ? T : NIL; - } - - protected int _readChar() - { - if (offset >= end) - return -1; - int n = s.charAt(offset); - ++offset; - if (n == '\n') - ++lineNumber; - return n; - } - - protected void _unreadChar(int n) - { - if (offset > start) { - --offset; - if (n == '\n') - --lineNumber; - } - } - - protected boolean _charReady() - { - return true; - } - + @Override public String toString() { return unreadableString("STRING-INPUT-STREAM"); } + @Override + public int getOffset() { + return start + super.getOffset(); + } + // ### make-string-input-stream // make-string-input-stream string &optional start end => string-stream private static final Primitive MAKE_STRING_INPUT_STREAM = new Primitive("make-string-input-stream", "string &optional start end") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { return new StringInputStream(arg.getStringValue()); } + @Override public LispObject execute(LispObject first, LispObject second) throws ConditionThrowable { @@ -144,6 +119,7 @@ return new StringInputStream(s, start); } + @Override public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable @@ -161,6 +137,7 @@ private static final Primitive STRING_INPUT_STREAM_CURRENT = new Primitive("string-input-stream-current", PACKAGE_EXT, true, "stream") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { if (arg instanceof StringInputStream) Modified: trunk/j/src/org/armedbear/lisp/StringOutputStream.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/StringOutputStream.java (original) +++ trunk/j/src/org/armedbear/lisp/StringOutputStream.java Sun Dec 7 23:24:31 2008 @@ -47,23 +47,23 @@ private StringOutputStream(LispObject elementType) { this.elementType = elementType; - isInputStream = false; - isOutputStream = true; - isCharacterStream = true; - isBinaryStream = false; - setWriter(stringWriter = new StringWriter()); + this.eolStyle = EolStyle.RAW; + initAsCharacterOutputStream(stringWriter = new StringWriter()); } + @Override public LispObject typeOf() { return Symbol.STRING_OUTPUT_STREAM; } + @Override public LispObject classOf() { return BuiltInClass.STRING_OUTPUT_STREAM; } + @Override public LispObject typep(LispObject type) throws ConditionThrowable { if (type == Symbol.STRING_OUTPUT_STREAM) @@ -77,45 +77,12 @@ return super.typep(type); } - public void _writeChar(char c) throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeChar(c); - } - - public void _writeChars(char[] chars, int start, int end) - throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeChars(chars, start, end); - } - - public void _writeString(String s) throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeString(s); - } - - public void _writeLine(String s) throws ConditionThrowable - { - if (elementType == NIL) - writeError(); - super._writeLine(s); - } - - private void writeError() throws ConditionThrowable - { - error(new TypeError("Attempt to write to a string output stream of element type NIL.")); - } - + @Override protected long _getFilePosition() throws ConditionThrowable { if (elementType == NIL) return 0; - return stringWriter.toString().length(); + return stringWriter.getBuffer().length(); } public LispObject getString() throws ConditionThrowable @@ -128,6 +95,7 @@ return s; } + @Override public String toString() { return unreadableString("STRING-OUTPUT-STREAM"); @@ -139,6 +107,7 @@ new Primitive("%make-string-output-stream", PACKAGE_SYS, false, "element-type") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { return new StringOutputStream(arg); @@ -150,6 +119,7 @@ private static final Primitive GET_OUTPUT_STREAM_STRING = new Primitive("get-output-stream-string", "string-output-stream") { + @Override public LispObject execute(LispObject arg) throws ConditionThrowable { try { Modified: trunk/j/src/org/armedbear/lisp/open.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/open.lisp (original) +++ trunk/j/src/org/armedbear/lisp/open.lisp Sun Dec 7 23:24:31 2008 @@ -106,7 +106,7 @@ (if-exists nil if-exists-given) (if-does-not-exist nil if-does-not-exist-given) (external-format :default)) - (declare (ignore external-format)) ; FIXME +; (declare (ignore external-format)) ; FIXME (setf element-type (case element-type ((character base-char) 'character) @@ -143,7 +143,7 @@ :pathname pathname :format-control "The file ~S does not exist." :format-arguments (list namestring))))) - (make-file-stream pathname namestring element-type :input nil)) + (make-file-stream pathname namestring element-type :input nil external-format)) (:probe (case if-does-not-exist (:error @@ -157,7 +157,8 @@ ;; this abstract pathname if and only if a file with this name does ;; not yet exist." See java.io.File.createNewFile(). (create-new-file namestring))) - (let ((stream (make-file-stream pathname namestring element-type :input nil))) + (let ((stream (make-file-stream pathname namestring element-type + :input nil external-format))) (when stream (close stream)) stream)) @@ -204,7 +205,8 @@ (error 'simple-error :format-control "Option not supported: ~S." :format-arguments (list if-exists)))) - (let ((stream (make-file-stream pathname namestring element-type direction if-exists))) + (let ((stream (make-file-stream pathname namestring element-type + direction if-exists external-format))) (unless stream (error 'file-error :pathname pathname Modified: trunk/j/src/org/armedbear/lisp/socket.lisp ============================================================================== --- trunk/j/src/org/armedbear/lisp/socket.lisp (original) +++ trunk/j/src/org/armedbear/lisp/socket.lisp Sun Dec 7 23:24:31 2008 @@ -31,15 +31,16 @@ (in-package "SYSTEM") -(defun get-socket-stream (socket &key (element-type 'character)) - ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER." +(defun get-socket-stream (socket &key (element-type 'character) (external-format :default)) + ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. +EXTERNAL-FORMAT must be of the same format as specified for OPEN." (cond ((eq element-type 'character)) ((equal element-type '(unsigned-byte 8))) (t (error 'simple-type-error :format-control ":ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8)."))) - (%socket-stream socket element-type)) + (%socket-stream socket element-type external-format)) (defun make-socket (host port) (%make-socket host port)) Modified: trunk/j/src/org/armedbear/lisp/socket_stream.java ============================================================================== --- trunk/j/src/org/armedbear/lisp/socket_stream.java (original) +++ trunk/j/src/org/armedbear/lisp/socket_stream.java Sun Dec 7 23:24:31 2008 @@ -40,19 +40,19 @@ { private socket_stream() { - super("%socket-stream", PACKAGE_SYS, false, "socket element-type"); + super("%socket-stream", PACKAGE_SYS, false, "socket element-type external-format"); } - public LispObject execute(LispObject first, LispObject second) + public LispObject execute(LispObject first, LispObject second, LispObject third) throws ConditionThrowable { Socket socket = (Socket) ((JavaObject)first).getObject(); LispObject elementType = second; // Checked by caller. try { Stream in = - new Stream(socket.getInputStream(), elementType); + new Stream(socket.getInputStream(), elementType, third); Stream out = - new Stream(socket.getOutputStream(), elementType); + new Stream(socket.getOutputStream(), elementType, third); return new SocketStream(socket, in, out); } catch (Exception e) {