From mevenson at common-lisp.net Sat May 1 07:37:21 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 01 May 2010 03:37:21 -0400 Subject: [armedbear-cvs] r12641 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 1 03:37:20 2010 New Revision: 12641 Log: Fix recursion bug in constructing Pathnames from "file" scheme URLs. Found by Alan Ruttenberg. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat May 1 03:37:20 2010 @@ -345,7 +345,7 @@ } String scheme = url.getProtocol(); if (scheme.equals("file")) { - Pathname p = new Pathname(s); + Pathname p = new Pathname(url.getFile()); this.host = p.host; this.device = p.device; this.directory = p.directory; From mevenson at common-lisp.net Sat May 1 13:17:31 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 01 May 2010 09:17:31 -0400 Subject: [armedbear-cvs] r12642 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 1 09:17:30 2010 New Revision: 12642 Log: Enable ASDF2 to work under Windows. Under Windows, allow Pathname TYPE components to end with ".lnk" allowing ASDF2 to use Windows shortcut code. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sat May 1 09:17:30 2010 @@ -680,10 +680,13 @@ sb.append('.'); if (type instanceof AbstractString) { String t = type.getStringValue(); - if (t.indexOf('.') >= 0) { - Debug.assertTrue(namestring == null); - return null; - } + // Allow Windows shortcuts to include TYPE + if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) { + if (t.indexOf('.') >= 0) { + Debug.assertTrue(namestring == null); + return null; + } + } sb.append(t); } else if (type == Keyword.WILD) { sb.append('*'); From mevenson at common-lisp.net Sat May 1 14:24:57 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 01 May 2010 10:24:57 -0400 Subject: [armedbear-cvs] r12643 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 1 10:24:57 2010 New Revision: 12643 Log: Under Windows, properly reference jars on other drive letters. Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java Modified: trunk/abcl/src/org/armedbear/lisp/ZipCache.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ZipCache.java (original) +++ trunk/abcl/src/org/armedbear/lisp/ZipCache.java Sat May 1 10:24:57 2010 @@ -182,7 +182,15 @@ } else { if (url.getProtocol().equals("file")) { entry = new Entry(); - File f = new File(url.getPath()); + String path = url.getPath(); + + if (Utilities.isPlatformWindows) { + String authority = url.getAuthority(); + if (authority != null) { + path = authority + path; + } + } + File f = new File(path); entry.lastModified = f.lastModified(); try { entry.file = new ZipFile(f); From mevenson at common-lisp.net Sat May 1 17:45:50 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 01 May 2010 13:45:50 -0400 Subject: [armedbear-cvs] r12644 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 1 13:45:49 2010 New Revision: 12644 Log: Fix for loading ASDF systems from jar files under win32. Changed synthetic '/:jar:file:/' path into the hopefully never used '/___jar___file___root___/' string which doesn't turn out to be a relative pathname under Windows (thanks to Carlos Ungil). Add Windows drive letter to output translation path to allow identically named jars on different drives to be handled. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Sat May 1 13:45:49 2010 @@ -2516,7 +2516,7 @@ #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; If we want to enable the user cache by default, here would be the place: @@ -2706,14 +2706,20 @@ #+abcl (defun translate-jar-pathname (source wildcard) (declare (ignore wildcard)) - (let ((root (apply-output-translations - (concatenate 'string - "/:jar:file/" - (namestring (first (pathname-device - source)))))) - (entry (make-pathname :directory (pathname-directory source) - :name (pathname-name source) - :type (pathname-type source)))) + (let* ((p (first (pathname-device source))) + (r (concatenate 'string + (if (and (find :windows *features*) + (not (null (pathname-device p)))) + (format nil "~A/" (pathname-device p)) + "") + (namestring (make-pathname :directory (pathname-directory p) + :name (pathname-name p) + :type (pathname-type p))))) + (root (apply-output-translations + (format nil "/___jar___file___root___/~A" r))) + (entry (make-pathname :directory (pathname-directory source) + :name (pathname-name source) + :type (pathname-type source)))) (concatenate 'string (namestring root) (namestring entry)))) ;;;; ----------------------------------------------------------------- From ehuelsmann at common-lisp.net Sat May 1 20:21:51 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 May 2010 16:21:51 -0400 Subject: [armedbear-cvs] r12645 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 1 16:21:50 2010 New Revision: 12645 Log: Fix #93: Empty VALUES set in the reader treated as NIL. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sat May 1 16:21:50 2010 @@ -657,18 +657,26 @@ // normal token beginning with '.' _unreadChar(nextChar); } + + thread._values = null; LispObject obj = processChar(c, rt); if (obj == null) { // A comment. continue; } - if (first == null) { - first = new Cons(obj); - last = first; - } else { - Cons newCons = new Cons(obj); - last.cdr = newCons; - last = newCons; + + if (! (obj == NIL && thread._values != null + && thread._values.length == 0)) { + // Don't add the return value NIL to the list + // if the _values array indicates no values have been returned + if (first == null) { + first = new Cons(obj); + last = first; + } else { + Cons newCons = new Cons(obj); + last.cdr = newCons; + last = newCons; + } } } } catch (IOException e) { @@ -1439,8 +1447,14 @@ char c = flushWhitespace(rt); if (c == delimiter) break; + + thread._values = null; LispObject obj = processChar(c, rt); - if (obj != null) + if (obj != null && + ! (obj == NIL && thread._values != null + && thread._values.length == 0)) + // Don't add 'obj' to the list, if _values indicates + // no values have been returned result = new Cons(obj, result); } if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) From ehuelsmann at common-lisp.net Sat May 1 21:43:30 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 01 May 2010 17:43:30 -0400 Subject: [armedbear-cvs] r12646 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 1 17:43:28 2010 New Revision: 12646 Log: Re #93: Instead of fixing just readList and readDelimitedList, document the protocol for processChar and fix that. Also, remove a pattern from LispReader.java (return null) which can't be used by Lisp functions. This commit fixes a much broader range of cases of the symptom reported in #93. Modified: trunk/abcl/src/org/armedbear/lisp/LispReader.java trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/LispReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispReader.java Sat May 1 17:43:28 2010 @@ -46,19 +46,19 @@ public LispObject execute(Stream stream, char ignored) { - try + try { while (true) { int n = stream._readChar(); if (n < 0) - return null; + return LispThread.currentThread().setValues(); if (n == '\n') - return null; + return LispThread.currentThread().setValues(); } } catch (java.io.IOException e) { - return null; + return LispThread.currentThread().setValues(); } } }; @@ -328,7 +328,7 @@ { stream.skipBalancedComment(); - return null; + return LispThread.currentThread().setValues(); } }; Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sat May 1 17:43:28 2010 @@ -481,7 +481,7 @@ char c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) continue; - LispObject result = processChar(c, rt); + LispObject result = processChar(thread, c, rt); if (result != null) return result; } @@ -497,15 +497,36 @@ } } - private final LispObject processChar(char c, Readtable rt) - + /** Dispatch macro function if 'c' has one associated, + * read a token otherwise. + * + * When the macro function returns zero values, this function + * returns null or the token or returned value otherwise. + */ + private final LispObject processChar(LispThread thread, + char c, Readtable rt) { final LispObject handler = rt.getReaderMacroFunction(c); - if (handler instanceof ReaderMacroFunction) - return ((ReaderMacroFunction)handler).execute(this, c); - if (handler != null && handler != NIL) - return handler.execute(this, LispCharacter.getInstance(c)); - return readToken(c, rt); + LispObject value; + + if (handler instanceof ReaderMacroFunction) { + thread._values = null; + value = ((ReaderMacroFunction)handler).execute(this, c); + } + else if (handler != null && handler != NIL) { + thread._values = null; + value = handler.execute(this, LispCharacter.getInstance(c)); + } + else + return readToken(c, rt); + + // If we're looking at zero return values, set 'value' to null + if (value == NIL) { + LispObject[] values = thread._values; + if (values != null && values.length == 0) + value = null; + } + return value; } public LispObject readPathname(ReadtableAccessor rta) { @@ -658,25 +679,18 @@ _unreadChar(nextChar); } - thread._values = null; - LispObject obj = processChar(c, rt); - if (obj == null) { - // A comment. + LispObject obj = processChar(thread, c, rt); + if (obj == null) continue; - } - if (! (obj == NIL && thread._values != null - && thread._values.length == 0)) { - // Don't add the return value NIL to the list - // if the _values array indicates no values have been returned - if (first == null) { - first = new Cons(obj); - last = first; - } else { - Cons newCons = new Cons(obj); - last.cdr = newCons; - last = newCons; - } + + if (first == null) { + first = new Cons(obj); + last = first; + } else { + Cons newCons = new Cons(obj); + last.cdr = newCons; + last = newCons; } } } catch (IOException e) { @@ -1448,13 +1462,8 @@ if (c == delimiter) break; - thread._values = null; - LispObject obj = processChar(c, rt); - if (obj != null && - ! (obj == NIL && thread._values != null - && thread._values.length == 0)) - // Don't add 'obj' to the list, if _values indicates - // no values have been returned + LispObject obj = processChar(thread, c, rt); + if (obj != null) result = new Cons(obj, result); } if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) From ehuelsmann at common-lisp.net Sun May 2 17:39:41 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 02 May 2010 13:39:41 -0400 Subject: [armedbear-cvs] r12647 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun May 2 13:39:40 2010 New Revision: 12647 Log: Don't warn about Java 1.6.0_20 being an inappropriate version. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sun May 2 13:39:40 2010 @@ -143,7 +143,7 @@ - + From ehuelsmann at common-lisp.net Sun May 2 18:30:48 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 02 May 2010 14:30:48 -0400 Subject: [armedbear-cvs] r12648 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 2 14:30:47 2010 New Revision: 12648 Log: Add (and use) more wrappers for the lisp ERROR function, using different return types: ierror returns an int, etc. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun May 2 14:30:47 2010 @@ -351,19 +351,44 @@ public static final LispObject error(LispObject condition) - { pushJavaStackFrames(); return Symbol.ERROR.execute(condition); } - public static final LispObject error(LispObject condition, LispObject message) + public static final int ierror(LispObject condition) + { + error(condition); + return 0; // Not reached + } + public static final String serror(LispObject condition) + { + error(condition); + return ""; // Not reached + } + + + public static final LispObject error(LispObject condition, LispObject message) { pushJavaStackFrames(); return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message); } + public static final int ierror(LispObject condition, LispObject message) + { + error(condition, message); + return 0; // Not reached + } + + public static final String serror(LispObject condition, LispObject message) + { + error(condition, message); + return ""; // Not reached + } + + + public static final LispObject type_error(LispObject datum, LispObject expectedType) Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sun May 2 14:30:47 2010 @@ -604,20 +604,16 @@ { while (true) { int n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return error(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { // Single escape. n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return error(new EndOfFile(this)); + sb.append((char)n); // ### BUG: Codepoint conversion continue; } @@ -970,20 +966,16 @@ try { while (true) { int n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return serror(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion byte syntaxType = rt.getSyntaxType(c); if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return serror(new EndOfFile(this)); + sb.append((char)n); // ### BUG: Codepoint conversion continue; } @@ -992,7 +984,7 @@ sb.append(c); } } catch (IOException e) { - error(new StreamError(this, e)); + return serror(new StreamError(this, e)); } return sb.toString(); } @@ -1136,9 +1128,9 @@ } if (n < 0) { error(new EndOfFile(this)); - // Not reached. - return flags; + return null; // Not reached } + sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion flags = new BitSet(1); flags.set(0); @@ -1252,22 +1244,19 @@ final LispObject readBaseObject = Symbol.READ_BASE.symbolValue(thread); if (readBaseObject instanceof Fixnum) { readBase = ((Fixnum)readBaseObject).value; - } else { + } else // The value of *READ-BASE* is not a Fixnum. - error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); - // Not reached. - return 10; - } - if (readBase < 2 || readBase > 36) { - error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); - // Not reached. - return 10; - } + return ierror(new LispError("The value of *READ-BASE* is not " + + "of type '(INTEGER 2 36).")); + + if (readBase < 2 || readBase > 36) + return ierror(new LispError("The value of *READ-BASE* is not " + + "of type '(INTEGER 2 36).")); + return readBase; } private final LispObject makeNumber(String token, int length, int radix) - { if (length == 0) return null; @@ -1436,11 +1425,9 @@ try { while (true) { int n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return 0; - } + if (n < 0) + return (char)ierror(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion if (!rt.isWhitespace(c)) return c; @@ -1862,9 +1849,7 @@ return n; // Reads an 8-bit byte. } catch (IOException e) { - error(new StreamError(this, e)); - // Not reached. - return -1; + return ierror(new StreamError(this, e)); } } From ehuelsmann at common-lisp.net Sun May 2 18:51:38 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 02 May 2010 14:51:38 -0400 Subject: [armedbear-cvs] r12649 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 2 14:51:35 2010 New Revision: 12649 Log: Re #79: Add *FASL-UNINTERNED-SYMBOLS* variable to Load.java and save its value in AutoloadedFunctionProxy, just like *FASL-ANONYMOUS-PACKAGE*. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sun May 2 14:51:35 2010 @@ -51,6 +51,7 @@ { AUTOLOADING_CACHE, // allow loading local preloaded functions Load._FASL_ANONYMOUS_PACKAGE_, // package for uninterned symbols + Load._FASL_UNINTERNED_SYMBOLS_, // vector of uninterned symbols Symbol._PACKAGE_, // current package Symbol.LOAD_TRUENAME // LOAD-TIME-VALUE depends on this }; Modified: 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 Sun May 2 14:51:35 2010 @@ -379,6 +379,17 @@ public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); + // ### *fasl-uninterned-symbols* + // internal symbol + /** + * This variable gets bound to NIL upon loading a FASL, but + * gets set to a vector of symbols as one of the first actions + * by the FASL itself. + * + */ + public static final Symbol _FASL_UNINTERNED_SYMBOLS_ = + internSpecial("*FASL-UNINTERNED-SYMBOLS*", PACKAGE_SYS, NIL); + // ### init-fasl &key version private static final Primitive INIT_FASL = new init_fasl(); private static class init_fasl extends Primitive { @@ -394,6 +405,7 @@ // OK final LispThread thread = LispThread.currentThread(); thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, NIL); + thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL); thread.bindSpecial(_SOURCE_, NIL); return faslLoadStream(thread); } @@ -409,8 +421,8 @@ boolean print, boolean auto) { - return loadFileFromStream(pathname == null ? NIL : pathname, - truename == null ? NIL : truename, + return loadFileFromStream(pathname == null ? NIL : pathname, + truename == null ? NIL : truename, in, verbose, print, auto, false); } From ehuelsmann at common-lisp.net Sun May 2 19:58:58 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 02 May 2010 15:58:58 -0400 Subject: [armedbear-cvs] r12650 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 2 15:58:56 2010 New Revision: 12650 Log: Fix #79: Equally named -but different- uninterned symbols coalesced into one in FASLs. This commit removes the *FASL-ANONYMOUS-PACKAGE*: it's replaced by *FASL-UNINTERNED-SYMBOLS* and a dispatch macro function which resolves symbols by index instead of by name. Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java trunk/abcl/src/org/armedbear/lisp/FaslReader.java trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java trunk/abcl/src/org/armedbear/lisp/Load.java trunk/abcl/src/org/armedbear/lisp/compile-file.lisp trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Modified: trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Sun May 2 15:58:56 2010 @@ -50,7 +50,6 @@ new Symbol[] { AUTOLOADING_CACHE, // allow loading local preloaded functions - Load._FASL_ANONYMOUS_PACKAGE_, // package for uninterned symbols Load._FASL_UNINTERNED_SYMBOLS_, // vector of uninterned symbols Symbol._PACKAGE_, // current package Symbol.LOAD_TRUENAME // LOAD-TIME-VALUE depends on this Modified: trunk/abcl/src/org/armedbear/lisp/FaslReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslReader.java Sun May 2 15:58:56 2010 @@ -141,12 +141,7 @@ { LispThread thread = LispThread.currentThread(); - Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance()); - LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread); - Debug.assertTrue(pkg != NIL); - symbol = ((Package)pkg).intern(symbol.getName()); - symbol.setPackage(NIL); - return symbol; + return stream.readSymbol(FaslReadtable.getInstance()); } }; @@ -277,10 +272,41 @@ { @Override public LispObject execute(Stream stream, char c, int n) - { return stream.readCharacterLiteral(FaslReadtable.getInstance(), LispThread.currentThread()); } }; + + // ### fasl-sharp-question-mark + public static final DispatchMacroFunction FASL_SHARP_QUESTION_MARK = + new DispatchMacroFunction("fasl-sharp-question-mark", PACKAGE_SYS, + false, "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + { + LispThread thread = LispThread.currentThread(); + LispObject uninternedSymbols = + Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(thread); + + if (! (uninternedSymbols instanceof Cons)) // it must be a vector + return uninternedSymbols.AREF(n); + + // During normal loading, we won't get to this bit, however, + // with eval-when processing, we may need to fall back to + // *FASL-UNINTERNED-SYMBOLS* being an alist structure + LispObject label = LispInteger.getInstance(n); + while (uninternedSymbols != NIL) + { + LispObject item = uninternedSymbols.car(); + if (label.eql(item.cdr())) + return item.car(); + + uninternedSymbols = uninternedSymbols.cdr(); + } + return error(new LispError("No entry for uninterned symbol.")); + } + }; + } Modified: trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslReadtable.java Sun May 2 15:58:56 2010 @@ -100,6 +100,7 @@ dtfunctions[10] = LispReader.SHARP_ILLEGAL; // newline, linefeed dtfunctions[12] = LispReader.SHARP_ILLEGAL; // page dtfunctions[13] = LispReader.SHARP_ILLEGAL; // return + dtfunctions['?'] = FaslReader.FASL_SHARP_QUESTION_MARK; dispatchTables.constants['#'] = dt; readtableCase = Keyword.UPCASE; Modified: 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 Sun May 2 15:58:56 2010 @@ -361,7 +361,7 @@ // ### *fasl-version* // internal symbol static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(35)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(36)); // ### *fasl-external-format* // internal symbol @@ -369,16 +369,6 @@ internConstant("*FASL-EXTERNAL-FORMAT*", PACKAGE_SYS, new SimpleString("UTF-8")); - // ### *fasl-anonymous-package* - // internal symbol - /** - * This variable gets bound to a package with no name in which the - * reader can intern its uninterned symbols. - * - */ - public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = - internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); - // ### *fasl-uninterned-symbols* // internal symbol /** @@ -404,7 +394,6 @@ if (second.eql(_FASL_VERSION_.getSymbolValue())) { // OK final LispThread thread = LispThread.currentThread(); - thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, NIL); thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL); thread.bindSpecial(_SOURCE_, NIL); return faslLoadStream(thread); @@ -595,7 +584,6 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); LispObject result = NIL; try { - thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package()); thread.bindSpecial(AUTOLOADING_CACHE, AutoloadedFunctionProxy.makePreloadingContext()); in.setExternalFormat(_FASL_EXTERNAL_FORMAT_.symbolValue(thread)); Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun May 2 15:58:56 2010 @@ -69,13 +69,13 @@ (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile) - (if (> *safety* 0) + (if (> *safety* 0) (and classfile (let ((*load-truename* *output-file-pathname*)) (report-error (load-compiled-function classfile)))) t)) - + (declaim (ftype (function (t) t) process-defconstant)) (defun process-defconstant (form) ;; "If a DEFCONSTANT form appears as a top level form, the compiler @@ -514,7 +514,8 @@ (*class-number* 0) (namestring (namestring *compile-file-truename*)) (start (get-internal-real-time)) - elapsed) + elapsed + *fasl-uninterned-symbols*) (when *compile-verbose* (format t "; Compiling ~A ...~%" namestring)) (with-compilation-unit () @@ -527,7 +528,6 @@ (*package* *package*) (jvm::*functions-defined-in-current-file* '()) (*fbound-names* '()) - (*fasl-anonymous-package* (%make-package)) (*fasl-stream* out) *forms-for-output*) (jvm::with-saved-compiler-policy @@ -565,19 +565,32 @@ ;; write header (write "; -*- Mode: Lisp -*-" :escape nil :stream out) (%stream-terpri out) - (let ((*package* (find-package '#:cl)) - (count-sym (gensym))) + (let ((*package* (find-package '#:cl))) (write (list 'init-fasl :version *fasl-version*) :stream out) (%stream-terpri out) (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) - (dump-form `(dotimes (,count-sym ,*class-number*) - (function-preload - (%format nil "~A-~D.cls" - ,(substitute #\_ #\. (pathname-name output-file)) - (1+ ,count-sym)))) out) + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car + (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out)) + (%stream-terpri out) + ;; we work with a fixed variable name here to work around the + ;; lack of availability of the circle reader in the fasl reader + ;; but it's a toplevel form anyway + (write `(dotimes (i ,*class-number*) + (function-preload + (%format nil "~A-~D.cls" + ,(substitute #\_ #\. (pathname-name output-file)) + (1+ i)))) + :stream out + :circle t) (%stream-terpri out)) 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 May 2 15:58:56 2010 @@ -8760,7 +8760,6 @@ (*visible-variables* nil) (*local-functions* nil) (*pathnames-generator* (constantly nil)) - (sys::*fasl-anonymous-package* (sys::%make-package)) environment) (unless (and (consp definition) (eq (car definition) 'LAMBDA)) (let ((function definition)) Modified: trunk/abcl/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/dump-form.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/dump-form.lisp Sun May 2 15:58:56 2010 @@ -103,6 +103,16 @@ (standard-object-p object) (java:java-object-p object)) (dump-instance object stream)) + ((and (symbolp object) ;; uninterned symbol + (null (symbol-package object))) + (let ((index (cdr (assoc object *fasl-uninterned-symbols*)))) + (unless index + (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1))) + (setq *fasl-uninterned-symbols* + (acons object index *fasl-uninterned-symbols*))) + (write-string "#" stream) + (write index :stream stream) + (write-string "?" stream))) (t (%stream-output-object object stream)))) From ehuelsmann at common-lisp.net Sun May 2 20:52:39 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 02 May 2010 16:52:39 -0400 Subject: [armedbear-cvs] r12651 - trunk/abcl Message-ID: Author: ehuelsmann Date: Sun May 2 16:52:36 2010 New Revision: 12651 Log: More CHANGES updates. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sun May 2 16:52:36 2010 @@ -15,20 +15,22 @@ * [svn r12620] Use interpreted function in FASL when compilation fails -* [svn r12616] Pathname functions work with URLs and JARs +* [ticket 95] Pathname functions work with URLs and JARs * Many small speed improvements (by marking functions 'final') -* Threads started through MAKE-THREAD now have a thread-termination - restart available in their debugger +* [ticket #91] Threads started through MAKE-THREAD now have a + thread-termination restart available in their debugger * [svn r12634] THREADS:THREAD-JOIN implemented +* [svn r12638] Experimental feature to allow insertion of byte code + in compiled Lisp functions Fixes ----- -* [svn r12639] Inlining of READ-LINE broken when the return value +* [ticket 89] Inlining of READ-LINE broken when the return value is unused * [svn r12636] Java class verification error when compiling PROGV @@ -41,7 +43,25 @@ * [ticket #92] Codepoints between #xD800 and #xDFFF are incorrectly returned as characters from CODE-CHAR +* [ticket #93] Reader doesn't handle zero returned values from + macro functions correctly +* [ticket #79] Different, yet similarly named, uninterned symbols + are incorrectly coalesced into the same object in a fasl. + +* [ticket #86] No restarts available to kill a thread, if none + bound by user code + +* [svn r12586] Increased function dispatch speed by eliminating + FIND-CLASS calls (replacing them by constant references) + +Other +----- + +* [svn r12581] LispCharacter() constructors made private, in favor + of getInstance() for better re-use of pre-constructed characters + +* [svn r12583] JAVA-CLASS reimplemented in Lisp Version 0.19 From mevenson at common-lisp.net Mon May 3 13:43:01 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 03 May 2010 09:43:01 -0400 Subject: [armedbear-cvs] r12652 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 3 09:43:00 2010 New Revision: 12652 Log: Use '/' as directory path separator for URL-PATHNAME and JAR-PATHNAME. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon May 3 09:43:00 2010 @@ -740,8 +740,8 @@ // the namestring." 19.2.2.2.3.1 if (directory != NIL) { final char separatorChar; - if (device instanceof Cons) { - separatorChar = '/'; // Jar file. + if (isJar() || isURL()) { + separatorChar = '/'; } else { separatorChar = File.separatorChar; } From mevenson at common-lisp.net Wed May 5 05:32:54 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 05 May 2010 01:32:54 -0400 Subject: [armedbear-cvs] r12653 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed May 5 01:32:52 2010 New Revision: 12653 Log: Fix MERGE-PATHNAMES for URL-PATHNAME under Windows. If the Pathname is a URL-PATHNAME, do not include the defaulted DEVICE. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Wed May 5 01:32:52 2010 @@ -1795,7 +1795,9 @@ if (pathname.device != NIL) { // XXX if device represent JARs we want to merge result.device = p.device; } else { - result.device = d.device; + if (!p.isURL()) { + result.device = d.device; + } } if (pathname.isJar()) { From mevenson at common-lisp.net Thu May 6 07:11:49 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 06 May 2010 03:11:49 -0400 Subject: [armedbear-cvs] r12654 - trunk/abcl/test/lisp/abcl Message-ID: Author: mevenson Date: Thu May 6 03:11:48 2010 New Revision: 12654 Log: Fix JAR-PATHNAME tests. Use explicit version in LOAD of jar via http URL to account for changes in FASL versions. Mark JAR-PATHNAME.MERGE-PATHNAMES.5 as expected failure under win32, as it includes the DEVICE a merged pathname (as it should). Use pathname for JAR-PATHNAME.TRANSLATE.1 instead of namestring. Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp Modified: trunk/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- trunk/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ trunk/abcl/test/lisp/abcl/jar-pathname.lisp Thu May 6 03:11:48 2010 @@ -124,48 +124,53 @@ ;;; wrapped in PROGN for easy disabling without a network connection ;;; XXX come up with a better abstraction +(defvar *url-jar-pathname-base* + "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20100505a.jar!/") + +(defmacro load-url-relative (path) + `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) + (progn (deftest jar-pathname.load.11 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo") + (load-url-relative "foo") t) (deftest jar-pathname.load.12 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar") + (load-url-relative "bar") t) (deftest jar-pathname.load.13 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar.abcl") + (load-url-relative "bar.abcl") t) (deftest jar-pathname.load.14 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek") + (load-url-relative "eek") t) (deftest jar-pathname.load.15 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek.lisp") + (load-url-relative "eek.lisp") t) (deftest jar-pathname.load.16 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/foo") + (load-url-relative "a/b/foo") t) (deftest jar-pathname.load.17 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar") + (load-url-relative "a/b/bar") t) (deftest jar-pathname.load.18 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar.abcl") + (load-url-relative "a/b/bar.abcl") t) (deftest jar-pathname.load.19 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek") + (load-url-relative "a/b/eek") t) (deftest jar-pathname.load.20 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp") + (load-url-relative "a/b/eek.lisp") t)) - (deftest jar-pathname.probe-file.1 (with-jar-file-init (probe-file "jar:file:baz.jar!/eek.lisp")) @@ -215,6 +220,11 @@ "jar:file:baz.jar!/foo" "/a/b/c") #p"jar:file:/a/b/baz.jar!/foo") + +;;; Under win32, we get the device in the merged path +#+windows +(push 'jar-pathname.merge-pathnames.5 *expected-failures*) + (deftest jar-pathname.merge-pathnames.5 (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp") #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp") @@ -332,11 +342,10 @@ nil) (deftest jar-pathname.translate.1 - (namestring - (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" - "jar:file:/**/*.jar!/**/*.*" - "/foo/**/*.*")) - "/foo/d/e/f.lisp") + (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" + "jar:file:/**/*.jar!/**/*.*" + "/foo/**/*.*") + #p"/foo/d/e/f.lisp") From mevenson at common-lisp.net Thu May 6 20:15:22 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 06 May 2010 16:15:22 -0400 Subject: [armedbear-cvs] r12655 - in trunk/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 6 16:15:20 2010 New Revision: 12655 Log: Update to ASDF 1.719 as recommended by ASDF developers. Modified: trunk/abcl/doc/asdf/asdf.texinfo trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/doc/asdf/asdf.texinfo ============================================================================== --- trunk/abcl/doc/asdf/asdf.texinfo (original) +++ trunk/abcl/doc/asdf/asdf.texinfo Thu May 6 16:15:20 2010 @@ -32,6 +32,9 @@ This manual describes ASDF, a system definition facility for Common Lisp programs and libraries. +You can find the latest version of this manual at + at url{http://common-lisp.net/project/asdf/asdf.html}. + ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. @@ -167,12 +170,12 @@ the ASDF internals and how to extend ASDF. @emph{Nota Bene}: -We are preparing for a release of ASDF 2, +We are preparing for a release of ASDF 2, hopefully for May 2010, which will have version 2.000 and later. -Current releases, in the 1.600 series and beyond, +Current releases, in the 1.700 series and beyond, should be considered as release candidates. We're still working on polishing the code and documentation. - at ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. + at xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. @node Loading ASDF, Configuring ASDF, Introduction, Top @@ -238,7 +241,7 @@ then you're using an old version of ASDF (from before 1.635). If it returns @code{NIL} then ASDF is not installed. -If you are running a version older than 1.678, +If you are running a version older than 1.711, we recommend that you load a newer ASDF using the method below. @@ -532,7 +535,7 @@ each in subtly different and incompatible ways: ASDF-Binary-Locations, cl-launch, common-lisp-controller. ASDF-Binary-Locations is now not needed anymore and should not be used. -cl-launch 3.0 and common-lisp-controller 7.1 have been updated +cl-launch 2.900 and common-lisp-controller 7.1 have been updated to just delegate this functionality to ASDF. @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top @@ -549,7 +552,7 @@ (asdf:load-system :@var{foo}) @end example -On some implementations (namely, SBCL and Clozure CL), +On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL), ASDF hooks into the @code{CL:REQUIRE} facility and you can just use: @@ -1316,11 +1319,11 @@ @code{defsystem} grammar subsection, which doesn't provide any obvious way to specify required features. Furthermore, in 2009, discussions on the - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} suggested that the specification of required features may be broken, and that no one may have been using them for a while. Please contact the - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} if you are interested in getting this features feature fixed.} Traditionally defsystem users have used reader conditionals @@ -1671,7 +1674,7 @@ where output file caches are located. Mentions of XDG variables refer to that document. - at uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} + at url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} This specification allows the user to specify some environment variables to customize how applications behave to his preferences. @@ -2463,7 +2466,7 @@ There is also a STABLE version, which is earlier than release. You may get the ASDF source repository using git: - at kbd{git clone http://common-lisp.net/project/asdf/asdf.git} + at kbd{git clone git://common-lisp.net/projects/asdf/asdf.git} You will find the above referenced tags in this repository. You can also browse the repository on @@ -2472,7 +2475,7 @@ Discussion of ASDF development is conducted on the mailing list @kbd{asdf-devel@@common-lisp.net}. - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} @node FAQ, TODO list, Getting the latest version, Top @@ -2484,7 +2487,7 @@ ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. If you're unsure about whether something is a bug, of for general discussion, -use the @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} +use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} @section ``What has changed between ASDF 1 and ASDF 2?'' @@ -2496,7 +2499,7 @@ While the code and documentation are essentially complete we are still working on polishing them before release. -Releases in the 1.600 series and beyond +Releases in the 1.700 series and beyond should be considered as release candidates. For all practical purposes, ASDF 2 refers to releases later than 1.656, @@ -2513,12 +2516,14 @@ we recommend that you should upgrade to ASDF 2 or its latest release candidate. - at subsection ASDF can portably name files inside systems and components + at subsection ASDF can portably name files in subdirectories Common Lisp namestrings are not portable, except maybe for logical pathnamestrings, -that themselves require a lot of setup that is itself ultimately non-portable. -The only portable ways to refer to pathnames inside systems and components +that themselves have various limitations and require a lot of setup +that is itself ultimately non-portable. + +In ASDF 1, the only portable ways to refer to pathnames inside systems and components were very awkward, using @code{#.(make-pathname ...)} and @code{#.(merge-pathnames ...)}. Even the above were themselves were inadequate in the general case @@ -2534,6 +2539,7 @@ @xref{The defsystem grammar,,Pathname specifiers}. + @subsection Output translations A popular feature added to ASDF was output pathname translation: @@ -2571,13 +2577,24 @@ with sensible defaults, adequate configuration languages, and a coherent set of configuration files and hooks. +We believe it's a vast improvement because it decouples +application distribution from library distribution. +The application writer can avoid thinking where the libraries are, +and the library distributor (dpkg, clbuild, advanced user, etc.) +can configure them once and for every application. +Yet settings can be easily overridden where needed, +so whoever needs control has exactly as much as required. + At the same time, ASDF 2 remains compatible with the old magic you may have in your build scripts +(using @code{*central-registry*} and + at code{*system-definition-search-functions*}) to tailor the ASDF configuration to your build automation needs, and also allows for new magic, simpler and more powerful magic. @xref{Controlling where ASDF searches for systems}. + @subsection Usual operations are made easier to the user In ASDF 1, you had to use the awkward syntax @@ -2592,23 +2609,43 @@ @subsection Many bugs have been fixed -These issues and many others have been fixed, -including the following: +The following issues and many others have been fixed: -Dependencies were not correctly propagated -across submodules within a system. + at itemize + at item +The infamous TRAVERSE function has been revamped significantly, +with many bugs squashed. +In particular, dependencies were not correctly propagated +across submodules within a system but now are. +The :version and :feature features and +the :force (system1 .. systemN) feature have been fixed. + at item +Performance has been notably improved for large systems +(say with thousands of components) by using +hash-tables instead of linear search, +and linear-time list accumulation +instead of quadratic-time recursive appends. + + at item Many features used to not be portable, especially where pathnames were involved. +Windows support was notably quirky because of such non-portability. -The internal test suite used to massively fail -in many implementations. + at item +The internal test suite used to massively fail on many implementations. +While still incomplete, it now fully passes +on all implementations supported by the test suite. -Support was broken for some implementations (notably ABCL). + at item +Support was lacking for some implementations. +ABCL was notably wholly broken. +ECL extensions were not integrated in the ASDF release. + at item The documentation was grossly out of date. -ECL extensions were not integrated in the ASDF release. + at end itemize @subsection ASDF itself is versioned @@ -2623,9 +2660,10 @@ With ASDF 2, we provide a new stable set of working features that everyone can rely on from now on. Use @code{#+asdf2} to detect presence of ASDF 2, - at code{(asdf:version-satisfies (asdf:asdf-version) "1.678")} + at code{(asdf:version-satisfies (asdf:asdf-version) "1.711")} to check the availability of a version no earlier than required. + @subsection ASDF can be upgraded When an old version of ASDF was loaded, @@ -2667,6 +2705,64 @@ the practical consequence of which will mean faster convergence towards the latest version for everyone. + + at subsection Pitfalls of ASDF 2 + +The main pitfalls in upgrading to ASDF 2 seem to be related +to the output translation mechanism. + + at itemize + + at item +Output translations is enabled by default. This may surprise some users, +most of them in pleasant way (we hope), a few of them in an unpleasant way. +It is trivial to disable output translations. + at xref{FAQ,,``How can I wholly disable the compiler output cache?''}. + + at item +Some systems in the large have been known not to play well with output translations. +They were relatively easy to fix. +Once again, it is also easy to disable output translations, +or to override its configuration. + + at item +The new ASDF output translations are incompatible with ASDF-Binary-Locations. +They replace A-B-L, and there is compatibility mode to emulate +your previous A-B-L configuration. +See @code{asdf:enable-asdf-binary-locations-compatibility} in + at pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. +But thou shall not load ABL on top of ASDF 2. + + at end itemize + +Other issues include the following: + + at itemize + + at item +There is a slight performance bug, notably on SBCL, +when initially searching for @file{asd} files, +the implicit @code{(directory "/configured/path/**/*.asd")} +for every configured path @code{(:tree "/configured/path/")} +in your @code{source-registry} configuration can cause a slight pause. +Try to @code{(time (asdf:initialize-source-registry))} +to see how bad it is or isn't on your system. +If you insist on not having this pause, +you can avoid the pause by overriding the default source-registry configuration +and not use any deep @code{:tree} entry but only @code{:directory} entries +or shallow @code{:tree} entries. +Or you can fix your implementation to not be quite that slow +when recursing through directories. + + at item +On Windows, only LispWorks supports proper default configuration pathnames +based on the Windows registry. +Other implementations make do. +Windows support is largely untested, so please help report and fix bugs. + + at end itemize + + @section Issues with installing the proper version of ASDF @subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?'' @@ -2690,25 +2786,59 @@ If there are any issues with the current release, it's a bug that you should report upstream and that we will fix ASAP. -As to how to include ASDF, we recommend that -if you do have a few magic systems in your implementation path, -that are specially treated in @code{wrapping-source-registry}, -like SBCL does. -In this case, we explicitly ask you to @emph{NOT} distribute - at file{asdf.asd} together with your implementation's ASDF, -least you separate it from the other systems in this path, -or otherwise rename the system and its @file{asd} file -to e.g. @code{asdf-sbcl} and @file{asdf-sbcl.asd}. +As to how to include ASDF, we recommend the following: + + at itemize + at item +If ASDF isn't installed yet, then @code{(require :asdf)} +should load the version of ASDF that is bundled with your system. +You may have it load some other version configured by the user, +if you allow such configuration. + + at item +If your system provides a mechanism to hook into @code{CL:REQUIRE}, +then it would be nice to add ASDF to this hook the same way that +ABCL, CCL, CMUCL, ECL and SBCL do it. + + at item +You may, like SBCL, have ASDF be implicitly used to require systems +that are bundled with your Lisp distribution. +If you do have a few magic systems that come with your implementation +in a precompiled way such that one should only use the binary version +that goes with your distribution, like SBCL does, +then you should add them in the beginning of @code{wrapping-source-registry}. + + at item +If you have magic systems as above, like SBCL does, +then we explicitly ask you to @emph{NOT} distribute + at file{asdf.asd} as part of those magic systems. +You should still include the file @file{asdf.lisp} in your source distribution +and precompile it in your binary distribution, +but @file{asdf.asd} if included at all, +should be secluded from the magic systems, +in a separate file hierarchy, +or you may otherwise rename the system and its file to e.g. + at code{asdf-ecl} and @file{asdf-ecl.asd}, or + at code{sb-asdf} and @file{sb-asdf.asd}. +Indeed, if you made @file{asdf.asd} a magic system, +then users would no longer be able to upgrade ASDF using ASDF itself +to some version of their preference that +they maintain independently from your Lisp distribution. + at item If you do not have any such magic systems, or have other non-magic systems that you want to bundle with your implementation, then you may add them to the @code{default-source-registry}, and you are welcome to include @file{asdf.asd} amongst them. -Please send upstream any patches you make to ASDF itself, + at item +Please send us upstream any patches you make to ASDF itself, so we can merge them back in for the benefit of your users when they upgrade to the upstream version. + at end itemize + + @section Issues with configuring ASDF @@ -2772,9 +2902,9 @@ The test operation, however, is largely left to the system definer to specify. @code{test-op} has been a topic of considerable discussion on the - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, and on the - at uref{https://launchpad.net/asdf,launchpad bug-tracker}. + at url{https://launchpad.net/asdf,launchpad bug-tracker}. Here are some guidelines: Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Thu May 6 16:15:20 2010 @@ -49,225 +49,286 @@ (cl:in-package :cl-user) -(declaim (optimize (speed 2) (debug 2) (safety 3))) +(declaim (optimize (speed 2) (debug 2) (safety 3)) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) -#+ecl (require 'cmp) +#+ecl (require :cmp) ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more at the end of the file. +#+gcl +(eval-when (:compile-toplevel :load-toplevel) + (defpackage :asdf-utilities (:use :cl)) + (defpackage :asdf (:use :cl :asdf-utilities))) + (eval-when (:load-toplevel :compile-toplevel :execute) + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) (let* ((asdf-version - ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace - (subseq "VERSION:1.679" (1+ (length "VERSION")))) - #+allegro (excl::*autoload-package-name-alist* nil) + ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:1.719" (1+ (length "VERSION")))) (existing-asdf (find-package :asdf)) - (versym '#:*asdf-version*) - (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf))) - (redefined-functions - '(#:perform #:explain #:output-files #:operation-done-p + (vername '#:*asdf-version*) + (versym (and existing-asdf + (find-symbol (string vername) existing-asdf))) + (existing-version (and versym (boundp versym) (symbol-value versym))) + (already-there (equal asdf-version existing-version))) + (unless (and existing-asdf already-there) + #-gcl + (when existing-asdf + (format *error-output* + "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" + existing-version asdf-version)) + (labels + ((rename-away (package) + (loop :with name = (package-name package) + :for i :from 1 :for new = (format nil "~A.~D" name i) + :unless (find-package new) :do + (rename-package-name package name new))) + (rename-package-name (package old new) + (let* ((old-names (cons (package-name package) + (package-nicknames package))) + (new-names (subst new old old-names :test 'equal)) + (new-name (car new-names)) + (new-nicknames (cdr new-names))) + (rename-package package new-name new-nicknames))) + (ensure-exists (name nicknames use) + (let* ((previous + (remove-duplicates + (remove-if + #'null + (mapcar #'find-package (cons name nicknames))) + :from-end t))) + (cond + (previous + ;; do away with packages with conflicting (nick)names + (map () #'rename-away (cdr previous)) + ;; reuse previous package with same name + (let ((p (car previous))) + (rename-package p name nicknames) + (ensure-use p use) + p)) + (t + (make-package name :nicknames nicknames :use use))))) + (find-sym (symbol package) + (find-symbol (string symbol) package)) + (intern* (symbol package) + (intern (string symbol) package)) + (remove-symbol (symbol package) + (let ((sym (find-sym symbol package))) + (when sym + (unexport sym package) + (unintern sym package)))) + (ensure-unintern (package symbols) + (dolist (sym symbols) (remove-symbol sym package))) + (ensure-shadow (package symbols) + (shadow symbols package)) + (ensure-use (package use) + (dolist (used (reverse use)) + (do-external-symbols (sym used) + (unless (eq sym (find-sym sym package)) + (remove-symbol sym package))) + (use-package used package))) + (ensure-fmakunbound (package symbols) + (loop :for name :in symbols + :for sym = (find-sym name package) + :when sym :do (fmakunbound sym))) + (ensure-export (package export) + (let ((syms (loop :for x :in export :collect + (intern* x package)))) + (do-external-symbols (sym package) + (unless (member sym syms) + (remove-symbol sym package))) + (dolist (sym syms) + (export sym package)))) + (ensure-package (name &key nicknames use unintern fmakunbound shadow export) + (let ((p (ensure-exists name nicknames use))) + (ensure-unintern p unintern) + (ensure-shadow p shadow) + (ensure-export p export) + (ensure-fmakunbound p fmakunbound) + p))) + (macrolet + ((pkgdcl (name &key nicknames use export + redefined-functions unintern fmakunbound shadow) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',(append #-(or gcl ecl) redefined-functions + unintern) + :fmakunbound ',(append #+(or gcl ecl) redefined-functions + fmakunbound)))) + (pkgdcl + :asdf-utilities + :nicknames (#:asdf-extensions) + :use (#:common-lisp) + :unintern (#:split #:make-collector) + :export + (#:absolute-pathname-p + #:aif + #:appendf + #:asdf-message + #:coerce-name + #:directory-pathname-p + #:ends-with + #:ensure-directory-pathname + #:getenv + #:get-uid + #:length=n-p + #:merge-pathnames* + #:pathname-directory-pathname + #:read-file-forms + #:remove-keys + #:remove-keyword + #:resolve-symlinks + #:split-string + #:component-name-to-pathname-components + #:split-name-type + #:system-registered-p + #:truenamize + #:while-collecting)) + (pkgdcl + :asdf + :use (:common-lisp :asdf-utilities) + :redefined-functions + (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname - #:system-source-file))) - (unless (equal asdf-version existing-version) - (labels ((rename-away (package) - (loop :with name = (package-name package) - :for i :from 1 :for new = (format nil "~A.~D" name i) - :unless (find-package new) :do - (rename-package-name package name new))) - (rename-package-name (package old new) - (let* ((old-names (cons (package-name package) (package-nicknames package))) - (new-names (subst new old old-names :test 'equal)) - (new-name (car new-names)) - (new-nicknames (cdr new-names))) - (rename-package package new-name new-nicknames))) - (ensure-exists (name nicknames use) - (let* ((previous - (remove-duplicates - (remove-if - #'null - (mapcar #'find-package (cons name nicknames))) - :from-end t))) - (cond - (previous - (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names - (let ((p (car previous))) ;; previous package with same name - (rename-package p name nicknames) - (ensure-use p use) - p)) - (t - (make-package name :nicknames nicknames :use use))))) - (find-sym (symbol package) - (find-symbol (string symbol) package)) - (remove-symbol (symbol package) - (let ((sym (find-sym symbol package))) - (when sym - (unexport sym package) - (unintern sym package)))) - (ensure-unintern (package symbols) - (dolist (sym symbols) (remove-symbol sym package))) - (ensure-shadow (package symbols) - (shadow symbols package)) - (ensure-use (package use) - (dolist (used (reverse use)) - (do-external-symbols (sym used) - (unless (eq sym (find-sym sym package)) - (remove-symbol sym package))) - (use-package used package))) - (ensure-fmakunbound (package symbols) - (loop :for name :in symbols - :for sym = (find-sym name package) - :when sym :do (fmakunbound sym))) - (ensure-export (package export) - (let ((syms (loop :for x :in export :collect - (intern (string x) package)))) - (do-external-symbols (sym package) - (unless (member sym syms) - (remove-symbol sym package))) - (dolist (sym syms) - (export sym package)))) - (ensure-package (name &key nicknames use unintern fmakunbound shadow export) - (let ((p (ensure-exists name nicknames use))) - (ensure-unintern p unintern) - (ensure-shadow p shadow) - (ensure-export p export) - (ensure-fmakunbound p fmakunbound) - p))) - (ensure-package - ':asdf-utilities - :nicknames '(#:asdf-extensions) - :use '(#:common-lisp) - :unintern '(#:split #:make-collector) - :export - '(#:absolute-pathname-p - #:aif - #:appendf - #:asdf-message - #:coerce-name - #:directory-pathname-p - #:ends-with - #:ensure-directory-pathname - #:getenv - #:get-uid - #:length=n-p - #:merge-pathnames* - #:pathname-directory-pathname - #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname - #:read-file-forms - #:remove-keys - #:remove-keyword - #:resolve-symlinks - #:split-string - #:component-name-to-pathname-components - #:split-name-type - #:system-registered-p - #:truenamize - #:while-collecting)) - (ensure-package - ':asdf - :use '(:common-lisp :asdf-utilities) - :unintern `(#-ecl , at redefined-functions - #:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector) - :fmakunbound `(#+ecl , at redefined-functions - #:system-source-file - #:component-relative-pathname #:system-relative-pathname - #:process-source-registry - #:inherit-source-registry #:process-source-registry-directive) - :export - '(#:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies - - #:input-files #:output-files #:perform ; operation methods - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - - #:component-depends-on - - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - #:system-licence - #:system-source-file - #:system-source-directory - #:system-relative-pathname - #:map-systems - - #:operation-on-warnings - #:operation-on-failure - ;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*resolve-symlinks* - - #:asdf-version - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-name - #:error-pathname - #:load-system-definition-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-component-of-version - #:missing-dependency - #:missing-dependency-of-version - #:circular-dependency ; errors - #:duplicate-names - - #:try-recompiling - #:retry - #:accept ; restarts - #:coerce-entry-to-directory - #:remove-entry-from-registry - - #:initialize-output-translations - #:disable-output-translations - #:clear-output-translations - #:ensure-output-translations - #:apply-output-translations - #:compile-file-pathname* - #:enable-asdf-binary-locations-compatibility - - #:*default-source-registries* - #:initialize-source-registry - #:compute-source-registry - #:clear-source-registry - #:ensure-source-registry - #:process-source-registry)) - (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version)))))) - -(in-package #:asdf) + #:system-source-file #:operate #:find-component) + :unintern + (#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector) + :fmakunbound + (#:system-source-file + #:component-relative-pathname #:system-relative-pathname + #:process-source-registry + #:inherit-source-registry #:process-source-registry-directive) + :export + (#:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:compile-system #:load-system #:test-system + #:compile-op #:load-op #:load-source-op + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + #:version-satisfies + + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:module-components-by-name ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:map-systems + + #:operation-on-warnings + #:operation-on-failure + ;;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*asdf-verbose* + + #:asdf-version + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names + + #:try-recompiling + #:retry + #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry + + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file-pathname* + #:enable-asdf-binary-locations-compatibility + + #:*default-source-registries* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry))) + (let* ((version (intern* vername :asdf)) + (upvar (intern* '#:*upgraded-p* :asdf)) + (upval0 (and (boundp upvar) (symbol-value upvar))) + (upval1 (if existing-version (cons existing-version upval0) upval0))) + (eval `(progn + (defparameter ,version ,asdf-version) + (defparameter ,upvar ',upval1)))))))) + +(in-package :asdf) + +;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 +#+gcl +(eval-when (:compile-toplevel :load-toplevel) + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil)) +(when *upgraded-p* + #+ecl + (when (find-class 'compile-op nil) + (defmethod update-instance-for-redefined-class :after + ((c compile-op) added deleted plist &key) + (declare (ignore added deleted)) + (let ((system-p (getf plist 'system-p))) + (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when (member 'components-by-name added) + (compute-module-components-by-name m)))))) ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters @@ -275,7 +336,7 @@ (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -289,6 +350,8 @@ (defvar *verbose-out* nil) +(defvar *asdf-verbose* t) + (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) @@ -301,21 +364,6 @@ (setf excl:*warn-on-nested-reader-conditionals* nil))) ;;;; ------------------------------------------------------------------------- -;;;; Cleanups before hot-upgrade. -;;;; Things to do in case we're upgrading from a previous version of ASDF. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS -;;;; for each of the classes we define that has changed incompatibly. -(eval-when (:compile-toplevel :load-toplevel :execute) - #+ecl - (when (find-class 'compile-op nil) - (defmethod update-instance-for-redefined-class :after - ((c compile-op) added deleted plist &key) - (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist)) - (let ((system-p (getf plist 'system-p))) - (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))) - -;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. (defgeneric perform-with-restarts (operation component)) @@ -324,6 +372,7 @@ (defgeneric explain (operation component)) (defgeneric output-files (operation component)) (defgeneric input-files (operation component)) +(defgeneric component-operation-time (operation component)) (defgeneric system-source-file (system) (:documentation "Return the source file in which system is defined.")) @@ -347,10 +396,9 @@ (defgeneric version-satisfies (component version)) -(defgeneric find-component (module name &optional version) - (:documentation "Finds the component with name NAME present in the -MODULE module; if MODULE is nil, then the component is assumed to be a -system.")) +(defgeneric find-component (base path) + (:documentation "Finds the component with PATH starting from BASE module; +if BASE is nil, then the component is assumed to be a system.")) (defgeneric source-file-type (component system)) @@ -365,7 +413,7 @@ This value stored will be a cons cell, the first element of which is a computed key, so not interesting. The CDR wil be the DATA value stored by VISIT-COMPONENT; recover -it as \(cdr \(component-visited-p op c\)\). +it as (cdr (component-visited-p op c)). In the current form of ASDF, the DATA value retrieved is effectively a boolean, indicating whether some operations are to be performed in order to do OPERATION X COMPONENT. If the @@ -421,21 +469,13 @@ (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) - (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) , at body - (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars)))))) + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) -(defun pathname-sans-name+type (pathname) - "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, -and NIL NAME and TYPE components. -Issue: doesn't override the VERSION component. - -Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead." - (make-pathname :name nil :type nil :defaults pathname)) - (defun pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" @@ -462,7 +502,7 @@ (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) - (ecase (first directory) + (#-gcl ecase #+gcl case (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) @@ -477,6 +517,13 @@ (values (pathname-host defaults) (pathname-device defaults) (append (pathname-directory defaults) (cdr directory)) + (unspecific-handler defaults))) + #+gcl + (t + (assert (stringp (first directory))) + (values (pathname-host defaults) + (pathname-device defaults) + (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) @@ -484,7 +531,10 @@ :version (funcall unspecific-handler version)))))) (define-modify-macro appendf (&rest args) - append "Append onto list") + append "Append onto list") ;; only to be used on short lists. + +(define-modify-macro orf (&rest args) + or "or a flag") (defun asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) @@ -515,7 +565,7 @@ ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; We only use it on implementations that support it. - (or #+(or sbcl ccl ecl lispworks) :unspecific))) + (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -649,7 +699,7 @@ :until (eq form eof) :collect form))) -#-windows +#-(and (or win32 windows mswindows mingw32) (not cygwin)) (progn #+clisp (defun get-uid () (posix:uid)) #+sbcl (defun get-uid () (sb-unix:unix-getuid)) @@ -660,8 +710,8 @@ #-(or cmu sbcl clisp allegro ecl) (defun get-uid () (let ((uid-string - (with-output-to-string (asdf::*VERBOSE-OUT*) - (asdf:run-shell-command "id -ur")))) + (with-output-to-string (*verbose-out*) + (run-shell-command "id -ur")))) (with-input-from-string (stream uid-string) (read-line stream) (handler-case (parse-integer (read-line stream)) @@ -687,28 +737,26 @@ (return p)) (let ((sofar (ignore-errors (truename (pathname-root p))))) (unless sofar (return p)) - (loop :for component :in (cdr directory) - :for rest :on (cdr directory) - :for more = (ignore-errors - (truename - (merge-pathnames* - (make-pathname :directory `(:relative ,component)) - sofar))) :do - (if more - (setf sofar more) - (return - (merge-pathnames* - (make-pathname :host nil :device nil - :directory `(:relative , at rest) - :defaults p) - sofar))) - :finally - (return - (merge-pathnames* - (make-pathname :host nil :device nil - :directory nil - :defaults p) - sofar))))))) + (flet ((solution (directories) + (merge-pathnames* + (make-pathname :host nil :device nil + :directory `(:relative , at directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) + sofar))) + (loop :for component :in (cdr directory) + :for rest :on (cdr directory) + :for more = (ignore-errors + (truename + (merge-pathnames* + (make-pathname :directory `(:relative ,component)) + sofar))) :do + (if more + (setf sofar more) + (return (solution rest))) + :finally + (return (solution nil)))))))) (defun lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) @@ -778,7 +826,9 @@ (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) - ;; XXX crap name + ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? + (load-dependencies :accessor component-load-dependencies :initform nil) + ;; XXX crap name, but it's an official API name! (do-first :initform nil :initarg :do-first :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: @@ -797,6 +847,16 @@ (properties :accessor component-properties :initarg :properties :initform nil))) +(defun component-find-path (component) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) + + ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) @@ -829,20 +889,38 @@ (component-system it) component)) -(defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity t) - (ignore-errors - (prin1 (component-name c) stream)))) +(defvar *default-component-class* 'cl-source-file) + +(defun compute-module-components-by-name (module) + (let ((hash (module-components-by-name module))) + (clrhash hash) + (loop :for c :in (module-components module) + :for name = (component-name c) + :for previous = (gethash name (module-components-by-name module)) + :do + (when previous + (error 'duplicate-names :name name)) + :do (setf (gethash name (module-components-by-name module)) c)) + hash)) (defclass module (component) - ((components :initform nil :accessor module-components :initarg :components) - ;; what to do if we can't satisfy a dependency of one of this module's - ;; components. This allows a limited form of conditional processing - (if-component-dep-fails :initform :fail - :accessor module-if-component-dep-fails - :initarg :if-component-dep-fails) - (default-component-class :accessor module-default-component-class - :initform 'cl-source-file :initarg :default-component-class))) + ((components + :initform nil + :initarg :components + :accessor module-components) + (components-by-name + :initform (make-hash-table :test 'equal) + :accessor module-components-by-name) + ;; What to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing. + (if-component-dep-fails + :initform :fail + :initarg :if-component-dep-fails + :accessor module-if-component-dep-fails) + (default-component-class + :initform *default-component-class* + :initarg :default-component-class + :accessor module-default-component-class))) (defun component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). @@ -984,21 +1062,9 @@ (let ((defaults (eval dir))) (when defaults (cond ((directory-pathname-p defaults) - (let ((file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local))) - #+(and (or win32 windows) (not :clisp)) - (shortcut (make-pathname - :defaults defaults :version :newest - :name name :type "asd.lnk" :case :local))) - (if (and file (probe-file file)) - (return file)) - #+(and (or win32 windows) (not :clisp)) - (when (probe-file shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target))))))) + (let ((file (probe-asd name defaults))) + (when file + (return file)))) (t (restart-case (let* ((*print-circle* nil) @@ -1031,22 +1097,26 @@ (defun make-temporary-package () (flet ((try (counter) (ignore-errors - (make-package (format nil "~a~D" 'asdf counter) + (make-package (format nil "~A~D" :asdf counter) :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) (defun safe-file-write-date (pathname) - ;; if FILE-WRITE-DATE returns NIL, it's possible that the - ;; user or some other agent has deleted an input file. If - ;; that's the case, well, that's not good, but as long as - ;; the operation is otherwise considered to be done we - ;; could continue and survive. - (or (and pathname (file-write-date pathname)) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls operation-done-p which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (or (and pathname (probe-file pathname) (file-write-date pathname)) (progn - (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." - pathname) + (when pathname + (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." + pathname)) 0))) (defun find-system (name &optional (error-p t)) @@ -1066,10 +1136,7 @@ (let ((*package* package)) (asdf-message "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. - on-disk - *package*) + on-disk *package*) (load on-disk))) (delete-package package)))) (let ((in-memory (system-registered-p name))) @@ -1088,18 +1155,31 @@ ;;;; ------------------------------------------------------------------------- ;;;; Finding components -(defmethod find-component ((module module) name &optional version) - (if (slot-boundp module 'components) - (let ((m (find name (module-components module) - :test #'equal :key #'component-name))) - (if (and m (version-satisfies m version)) m)))) +(defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) +(defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + +(defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + +(defmethod find-component ((module module) (name string)) + (when (slot-boundp module 'components-by-name) + (values (gethash name (module-components-by-name module))))) + +(defmethod find-component ((component component) (name symbol)) + (if name + (find-component component (coerce-name name)) + component)) + +(defmethod find-component ((module module) (name cons)) + (find-component (find-component module (car name)) (cdr name))) -;;; a component with no parent is a system -(defmethod find-component ((module (eql nil)) name &optional version) - (declare (ignorable module)) - (let ((m (find-system name nil))) - (if (and m (version-satisfies m version)) m))) ;;; component subclasses @@ -1117,8 +1197,11 @@ (defclass html-file (doc-file) ((type :initform "html"))) -(defmethod source-file-type ((component module) (s module)) :directory) +(defmethod source-file-type ((component module) (s module)) + (declare (ignorable component s)) + :directory) (defmethod source-file-type ((component source-file) (s module)) + (declare (ignorable s)) (source-file-explicit-type component)) (defun merge-component-name-type (name &key type defaults) @@ -1166,14 +1249,19 @@ (defclass operation () ( - ;; what is the TYPE of this slot? seems like it should be boolean, - ;; but TRAVERSE checks to see if it's a list of component names... - ;; [2010/02/07:rpg] + ;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of existing system, + ;; but not recurse to other systems we depend on. + ;; :ALL (or any other atom) to force all systems + ;; including other systems we depend on. + ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) + ;; to force systems named in a given list + ;; (but this feature never worked before ASDF 1.700 and is cerror'ed out.) (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) - (visited-nodes :initform nil :accessor operation-visited-nodes) - (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) + (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) @@ -1222,13 +1310,13 @@ (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) - (push (cons (node-for o c) data) - (operation-visited-nodes (operation-ancestor o))))) + (setf (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o))) + (cons t data)))) (defmethod component-visited-p ((o operation) (c component)) - (assoc (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) + (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o)))) (defmethod (setf visiting-component) (new-value operation component) ;; MCL complains about unused lexical variables @@ -1239,15 +1327,13 @@ (let ((node (node-for o c)) (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal)))) - new-value) + (setf (gethash node (operation-visiting-nodes a)) t) + (remhash node (operation-visiting-nodes a))) + new-value)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (node-for o c))) - (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + (gethash node (operation-visiting-nodes (operation-ancestor o))))) (defmethod component-depends-on ((op-spec symbol) (c component)) (component-depends-on (make-instance op-spec) c)) @@ -1275,12 +1361,17 @@ ;; original source file, then (list (component-pathname c))))) -(defmethod input-files ((operation operation) (c module)) nil) +(defmethod input-files ((operation operation) (c module)) + (declare (ignorable operation c)) + nil) + +(defmethod component-operation-time (o c) + (gethash (type-of o) (component-operation-times c))) (defmethod operation-done-p ((o operation) (c component)) (let ((out-files (output-files o c)) (in-files (input-files o c)) - (op-time (gethash (type-of o) (component-operation-times c)))) + (op-time (component-operation-time o c))) (flet ((earliest-out () (reduce #'min (mapcar #'safe-file-write-date out-files))) (latest-in () @@ -1323,183 +1414,220 @@ (>= (earliest-out) (latest-in)))))))) -;;; So you look at this code and think "why isn't it a bunch of -;;; methods". And the answer is, because standard method combination -;;; runs :before methods most->least-specific, which is back to front -;;; for our purposes. + +;;; For 1.700 I've done my best to refactor TRAVERSE +;;; by splitting it up in a bunch of functions, +;;; so as to improve the collection and use-detection algorithm. --fare +;;; The protocol is as follows: we pass around operation, dependency, +;;; bunch of other stuff, and a force argument. Return a force flag. +;;; The returned flag is T if anything has changed that requires a rebuild. +;;; The force argument is a list of components that will require a rebuild +;;; if the flag is T, at which point whoever returns the flag has to +;;; mark them all as forced, and whoever recurses again can use a NIL list +;;; as a further argument. (defvar *forcing* nil "This dynamically-bound variable is used to force operations in recursive calls to traverse.") -(defmethod traverse ((operation operation) (c component)) - (let ((forced nil)) ;return value -- everyone side-effects onto this - (labels ((%do-one-dep (required-op required-c required-v) - ;; returns a partial plan that results from performing required-op - ;; on required-c, possibly with a required-vERSION - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (if required-v - (error 'missing-dependency-of-version - :required-by c - :version required-v - :requires required-c) - (error 'missing-dependency - :required-by c - :requires required-c)))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) - (do-one-dep (required-op required-c required-v) - ;; this function is a thin, error-handling wrapper around - ;; %do-one-dep. Returns a partial plan per that function. - (loop - (restart-case - (return (%do-one-dep required-op required-c required-v)) - (retry () - :report (lambda (s) - (format s "~@" - required-c)) - :test - (lambda (c) -#| - (print (list :c1 c (typep c 'missing-dependency))) - (when (typep c 'missing-dependency) - (print (list :c2 (missing-requires c) required-c - (equalp (missing-requires c) - required-c)))) -|# - (or (null c) - (and (typep c 'missing-dependency) - (equalp (missing-requires c) - required-c)))))))) - (do-dep (op dep) - ;; type of arguments uncertain: op seems to at least potentially be a - ;; symbol, rather than an operation - ;; dep is either a list of component names (?) or (we hope) a single - ;; component name. - ;; handle a single dependency, returns nothing of interest --- side- - ;; effects onto the FORCED variable, which is scoped over TRAVERSE - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency - :required-by c - :requires (car dep)))) - (t - (dolist (d dep) - ;; structured dependencies --- this parses keywords - ;; the keywords could be broken out and cleanly (extensibly) - ;; processed by EQL methods, but for the pervasive side-effecting - ;; onto FORCED - (cond ((consp d) - (cond ((string-equal - (symbol-name (first d)) - "VERSION") - ;; https://bugs.launchpad.net/asdf/+bug/527788 - (appendf - forced - (do-one-dep op (second d) (third d)))) - ;; this particular subform is not documented, indeed - ;; clashes with the documentation, since it assumes a - ;; third component. - ;; See https://bugs.launchpad.net/asdf/+bug/518467 - ((and (string-equal - (symbol-name (first d)) - "FEATURE") - (find (second d) *features* - :test 'string-equal)) - (appendf - forced - (do-one-dep op (third d) nil))) - (t - (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))) - (t - (appendf forced (do-one-dep op d nil))))))))) +(defgeneric do-traverse (operation component collect)) + +(defun %do-one-dep (operation c collect required-op required-c required-v) + ;; collects a partial plan that results from performing required-op + ;; on required-c, possibly with a required-vERSION + (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) + (and d (version-satisfies d required-v) d)) + (if required-v + (error 'missing-dependency-of-version + :required-by c + :version required-v + :requires required-c) + (error 'missing-dependency + :required-by c + :requires required-c)))) + (op (make-sub-operation c operation dep-c required-op))) + (do-traverse op dep-c collect))) + +(defun do-one-dep (operation c collect required-op required-c required-v) + ;; this function is a thin, error-handling wrapper around + ;; %do-one-dep. Returns a partial plan per that function. + (loop + (restart-case + (return (%do-one-dep operation c collect + required-op required-c required-v)) + (retry () + :report (lambda (s) + (format s "~@" + required-c)) + :test + (lambda (c) + #| + (print (list :c1 c (typep c 'missing-dependency))) + (when (typep c 'missing-dependency) + (print (list :c2 (missing-requires c) required-c + (equalp (missing-requires c) + required-c)))) + |# + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) + +(defun do-dep (operation c collect op dep) + ;; type of arguments uncertain: + ;; op seems to at least potentially be a symbol, rather than an operation + ;; dep is a list of component names + (cond ((eq op 'feature) + (if (member (car dep) *features*) + nil + (error 'missing-dependency + :required-by c + :requires (car dep)))) + (t + (let ((flag nil)) + (flet ((dep (op comp ver) + (when (do-one-dep operation c collect + op comp ver) + (setf flag t)))) + (dolist (d dep) + (if (atom d) + (dep op d nil) + ;; structured dependencies --- this parses keywords + ;; the keywords could be broken out and cleanly (extensibly) + ;; processed by EQL methods + (cond ((eq :version (first d)) + ;; https://bugs.launchpad.net/asdf/+bug/527788 + (dep op (second d) (third d))) + ;; This particular subform is not documented and + ;; has always been broken in the past. + ;; Therefore no one uses it, and I'm cerroring it out, + ;; after fixing it + ;; See https://bugs.launchpad.net/asdf/+bug/518467 + ((eq :feature (first d)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") + (when (find (second d) *features* :test 'string-equal) + (dep op (third d) nil))) + (t + (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) + flag)))) + +(defun do-collect (collect x) + (funcall collect x)) + +(defmethod do-traverse ((operation operation) (c component) collect) + (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? + (labels + ((update-flag (x) + (when x + (setf flag t))) + (dep (op comp) + (update-flag (do-dep operation c collect op comp)))) + ;; Have we been visited yet? If so, just process the result. (aif (component-visited-p operation c) - (return-from traverse - (if (cdr it) (list (cons 'pruned-op c)) nil))) + (progn + (update-flag (cdr it)) + (return-from do-traverse flag))) ;; dependencies - (if (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) + (when (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (unwind-protect - (progn - ;; first we check and do all the dependencies for the - ;; module. Operations planned in this loop will show up - ;; in the contents of the FORCED variable, and are consumed - ;; downstream (watch out for the shadowing FORCED variable - ;; around the DOLIST below!) - (let ((*forcing* nil)) - ;; upstream dependencies are never forced to happen just because - ;; the things that depend on them are.... - (loop :for (required-op . deps) :in - (component-depends-on operation c) - :do (do-dep required-op deps))) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - ;; this is set based on the results of the - ;; dependencies and whether we are in the - ;; context of a *forcing* call... - (must-operate (or *forcing* - ;; inter-system dependencies do NOT trigger - ;; building components - (and - (not (typep c 'system)) - forced))) - (error nil)) - (dolist (kid (module-components c)) - (handler-case - (let ((*forcing* must-operate)) - (appendf forced (traverse operation kid))) - (missing-dependency (condition) - (when (eq (module-if-component-dep-fails c) - :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) - :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - ;; the test here is a bit oddly written. FORCED here doesn't - ;; mean that this operation is forced on this component, but that - ;; something upstream of this component has been forced. - (when (or forced module-ops - *forcing* - (not (operation-done-p operation c)) - (let ((f (operation-forced - (operation-ancestor operation)))) - ;; does anyone fully understand the following condition? - ;; if so, please add a comment to explain it... - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - ;; this was string=, but for the benefit - ;; of mlisp, we use string-equal for this - ;; purpose. - :test #'string-equal))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (component-do-first c))))) - (loop :for (required-op . deps) :in do-first - :do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c))))))) - (setf (visiting-component operation c) nil)) - (visit-component operation c (and forced t)) - forced))) + (progn + ;; first we check and do all the dependencies for the module. + ;; Operations planned in this loop will show up + ;; in the results, and are consumed below. + (let ((*forcing* nil)) + ;; upstream dependencies are never forced to happen just because + ;; the things that depend on them are.... + (loop + :for (required-op . deps) :in (component-depends-on operation c) + :do (dep required-op deps))) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + ;; This is set based on the results of the + ;; dependencies and whether we are in the + ;; context of a *forcing* call... + ;; inter-system dependencies do NOT trigger + ;; building components + (*forcing* + (or *forcing* + (and flag (not (typep c 'system))))) + (error nil)) + (while-collecting (internal-collect) + (dolist (kid (module-components c)) + (handler-case + (update-flag + (do-traverse operation kid #'internal-collect)) + (missing-dependency (condition) + (when (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error))))))) + (update-flag + (or + *forcing* + (not (operation-done-p operation c)) + ;; For sub-operations, check whether + ;; the original ancestor operation was forced, + ;; or names us amongst an explicit list of things to force... + ;; except that this check doesn't distinguish + ;; between all the things with a given name. Sigh. + ;; BROKEN! + (let ((f (operation-forced + (operation-ancestor operation)))) + (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=))))))) + (when flag + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (component-do-first c))))) + (loop :for (required-op . deps) :in do-first + :do (do-dep operation c collect required-op deps))) + (do-collect collect (vector module-ops)) + (do-collect collect (cons operation c))))) + (setf (visiting-component operation c) nil))) + (visit-component operation c flag) + flag)) + +(defmethod traverse ((operation operation) (c component)) + ;; cerror'ing a feature that seems to have NEVER EVER worked + ;; ever since danb created it in his 2003-03-16 commit e0d02781. + ;; It was both fixed and disabled in the 1.700 rewrite. + (when (consp (operation-forced operation)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") + (setf (operation-forced operation) + (mapcar #'coerce-name (operation-forced operation)))) + (flatten-tree + (while-collecting (collect) + (do-traverse operation c #'collect)))) +(defun flatten-tree (l) + ;; You collected things into a list. + ;; Most elements are just things to collect again. + ;; A (simple-vector 1) indicate that you should recurse into its contents. + ;; This way, in two passes (rather than N being the depth of the tree), + ;; you can collect things with marginally constant-time append, + ;; achieving linear time collection instead of quadratic time. + (while-collecting (c) + (labels ((r (x) + (if (typep x '(simple-vector 1)) + (r* (svref x 0)) + (c x))) + (r* (l) + (dolist (x l) (r x)))) + (r* l)))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error @@ -1508,6 +1636,7 @@ (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) + (declare (ignorable operation c)) nil) (defmethod explain ((operation operation) (component component)) @@ -1532,9 +1661,10 @@ (defmethod perform :after ((o compile-op) (c cl-source-file)) ;; Note how we use OUTPUT-FILES to find the binary locations ;; This allows the user to override the names. - (let* ((input (output-files o c)) - (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl))) - (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=)))) + (let* ((files (output-files o c)) + (object (first files)) + (fasl (second files))) + (c:build-fasl fasl :lisp-files (list object)))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) @@ -1567,20 +1697,23 @@ (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) + (declare (ignorable operation)) (let ((p (lispize-pathname (component-pathname c)))) #-:broken-fasl-loader - (list #-ecl (compile-file-pathname p) - #+ecl (compile-file-pathname p :type :object) + (list (compile-file-pathname p #+ecl :type #+ecl :object) #+ecl (compile-file-pathname p :type :fasl)) #+:broken-fasl-loader (list p))) (defmethod perform ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) -(defmethod input-files ((op compile-op) (c static-file)) +(defmethod input-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) @@ -1602,35 +1735,60 @@ (perform operation component)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) - (let ((state :initial)) - (loop :until (or (eq state :success) - (eq state :failure)) :do - (case state - (:recompiled - (setf state :failure) - (call-next-method) - (setf state :success)) - (:failed-load - (setf state :recompiled) - (perform (make-instance 'compile-op) c)) - (t - (with-simple-restart - (try-recompiling "Recompile ~a and try loading it again" - (component-name c)) - (setf state :failed-load) - (call-next-method) - (setf state :success))))))) + (declare (ignorable o)) + (loop :with state = :initial + :until (or (eq state :success) + (eq state :failure)) :do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-load + (setf state :recompiled) + (perform (make-instance 'compile-op) c)) + (t + (with-simple-restart + (try-recompiling "Recompile ~a and try loading it again" + (component-name c)) + (setf state :failed-load) + (call-next-method) + (setf state :success)))))) + +(defmethod perform-with-restarts ((o compile-op) (c cl-source-file)) + (loop :with state = :initial + :until (or (eq state :success) + (eq state :failure)) :do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-compile + (setf state :recompiled) + (perform-with-restarts o c)) + (t + (with-simple-restart + (try-recompiling "Try recompiling ~a" + (component-name c)) + (setf state :failed-compile) + (call-next-method) + (setf state :success)))))) (defmethod perform ((operation load-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod operation-done-p ((operation load-op) (c static-file)) + (declare (ignorable operation c)) t) -(defmethod output-files ((o operation) (c component)) +(defmethod output-files ((operation operation) (c component)) + (declare (ignorable operation c)) nil) (defmethod component-depends-on ((operation load-op) (c component)) + (declare (ignorable operation)) (cons (list 'compile-op (component-name c)) (call-next-method))) @@ -1640,19 +1798,23 @@ (defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) + (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) (and (load source) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation load-source-op) (c component)) + (declare (ignorable operation c)) nil) ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) + (declare (ignorable o)) (let ((what-would-load-op-do (cdr (assoc 'load-op (component-in-order-to c))))) (mapcar (lambda (dep) @@ -1662,6 +1824,7 @@ what-would-load-op-do))) (defmethod operation-done-p ((o load-source-op) (c source-file)) + (declare (ignorable o)) (if (or (not (component-property c 'last-loaded-as-source)) (> (safe-file-write-date (component-pathname c)) (component-property c 'last-loaded-as-source))) @@ -1674,28 +1837,34 @@ (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) + (declare (ignorable operation c)) nil) (defmethod operation-done-p ((operation test-op) (c system)) "Testing a system is _never_ done." + (declare (ignorable operation c)) nil) (defmethod component-depends-on :around ((o test-op) (c system)) + (declare (ignorable o)) (cons `(load-op ,(component-name c)) (call-next-method))) ;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations -(defun operate (operation-class system &rest args &key (verbose t) version force - &allow-other-keys) +(defgeneric operate (operation-class system &key &allow-other-keys)) + +(defmethod operate (operation-class system &rest args + &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force + &allow-other-keys) (declare (ignore force)) (let* ((*package* *package*) (*readtable* *readtable*) (op (apply #'make-instance operation-class :original-initargs args args)) - (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) (system (if (typep system 'component) system (find-system system)))) (unless (version-satisfies system version) (error 'missing-component-of-version :requires system :version version)) @@ -1704,8 +1873,9 @@ (loop :for (op . component) :in steps :do (loop (restart-case - (progn (perform-with-restarts op component) - (return)) + (progn + (perform-with-restarts op component) + (return)) (retry () :report (lambda (s) @@ -1723,7 +1893,7 @@ (return))))))) op)) -(defun oos (operation-class system &rest args &key force (verbose t) version +(defun oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) (apply #'operate operation-class system args)) @@ -1753,21 +1923,21 @@ (setf (documentation 'operate 'function) operate-docstring)) -(defun load-system (system &rest args &key force (verbose t) version +(defun load-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'load-op system args)) -(defun compile-system (system &rest args &key force (verbose t) version +(defun compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'compile-op system args)) -(defun test-system (system &rest args &key force (verbose t) version +(defun test-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." @@ -1800,13 +1970,15 @@ (defmacro defsystem (name &body options) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) - &allow-other-keys) + defsystem-depends-on &allow-other-keys) options - (let ((component-options (remove-keyword :class options))) + (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from + ,@(loop :for system :in defsystem-depends-on + :collect `(load-system ,system)) (let ((s (system-registered-p ',name))) (cond ((and s (eq (type-of (cdr s)) ',class)) (setf (car s) (get-universal-time))) @@ -1818,8 +1990,7 @@ (%set-system-source-file *load-truename* (cdr (system-registered-p ',name)))) (parse-component-form - nil (apply - #'list + nil (list* :module (coerce-name ',name) :pathname ,(determine-system-pathname pathname pathname-arg-p) @@ -1870,11 +2041,11 @@ new-tree)) -(defvar *serial-depends-on*) +(defvar *serial-depends-on* nil) (defun sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") + "~&The value specified for ~(~A~) ~A is ~S") type name value)) (defun check-component-input (type name weakly-depends-on @@ -1924,7 +2095,6 @@ (%define-component-inline-methods component rest)) (defun parse-component-form (parent options) - (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the @@ -1956,10 +2126,9 @@ (or (find-component parent name) (make-instance (class-for-type parent type))))) (when weakly-depends-on - (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) - (when (boundp '*serial-depends-on*) - (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) + (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) + (when *serial-depends-on* + (push *serial-depends-on* depends-on)) (apply #'reinitialize-instance ret :name (coerce-name name) :pathname pathname @@ -1973,28 +2142,22 @@ (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) - (loop :for c-form :in components + (loop + :for c-form :in components :for c = (parse-component-form ret c-form) + :for name = (component-name c) :collect c - :if serial - :do (push (component-name c) *serial-depends-on*)))) + :when serial :do (setf *serial-depends-on* name)))) + (compute-module-components-by-name ret)) - ;; check for duplicate names - (let ((name-hash (make-hash-table :test #'equal))) - (loop :for c in (module-components ret) :do - (if (gethash (component-name c) - name-hash) - (error 'duplicate-names :name (component-name c)) - (setf (gethash (component-name c) - name-hash) - t))))) + (setf (component-load-dependencies ret) depends-on) ;; Used by POIU (setf (component-in-order-to ret) (union-of-dependencies in-order-to `((compile-op (compile-op , at depends-on)) - (load-op (load-op , at depends-on)))) - (component-do-first ret) `((compile-op (load-op , at depends-on)))) + (load-op (load-op , at depends-on))))) + (setf (component-do-first ret) `((compile-op (load-op , at depends-on)))) (%refresh-component-inline-methods ret rest) ret))) @@ -2018,20 +2181,9 @@ output to `*verbose-out*`. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (asdf-message "; $ ~A~%" command) - #+sbcl - (sb-ext:process-exit-code - (apply #'sb-ext:run-program - #+win32 "sh" #-win32 "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out* - #+win32 '(:search t) #-win32 nil)) - #+(or cmu scl) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) + #+abcl + (ext:run-shell-command command :output *verbose-out*) #+allegro ;; will this fail if command has embedded quotes - it seems to work @@ -2045,18 +2197,10 @@ (format *verbose-out* "~{~&; ~a~%~}~%" stdout) exit-code) - #+lispworks - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :show-cmd nil - :prefix "" - :output-stream *verbose-out*) - #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) - #+openmcl + #+clozure (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) @@ -2066,12 +2210,34 @@ #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) - #+abcl - (ext:run-shell-command command :output *verbose-out*) + #+gcl + (lisp:system command) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :show-cmd nil + :prefix "" + :output-stream *verbose-out*) + + #+sbcl + (sb-ext:process-exit-code + (apply #'sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out* + #+win32 '(:search t) #-win32 nil)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) - #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl) - (error "RUN-SHELL-COMMAND not implemented for this Lisp") - )) + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) + (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) ;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname @@ -2090,9 +2256,13 @@ :defaults (system-source-file system-designator))) (defun relativize-directory (directory) - (if (eq (car directory) :absolute) - (cons :relative (cdr directory)) - directory)) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory))) (defun relativize-pathname-directory (pathspec) (let ((p (pathname pathspec))) @@ -2119,9 +2289,10 @@ (defparameter *os-features* '((:windows :mswindows :win32 :mingw32) (:solaris :sunos) + :linux ;; for GCL at least, must appear before :bsd. :macosx :darwin :apple :freebsd :netbsd :openbsd :bsd - :linux :unix)) + :unix)) (defparameter *architecture-features* '((:x86-64 :amd64 :x86_64 :x8664-target) @@ -2131,15 +2302,6 @@ (defun lisp-version-string () (let ((s (lisp-implementation-version))) (declare (ignorable s)) - #+(or scl sbcl ecl armedbear cormanlisp mcl) s - #+cmu (substitute #\- #\/ s) - #+clozure (format nil "~d.~d~@[-~d~]" - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - #+ppc64-target 64 - #-ppc64-target nil) - #+lispworks (format nil "~A~@[~A~]" s - (when (member :lispworks-64bit *features*) "-64bit")) #+allegro (format nil "~A~A~A~A" excl::*common-lisp-version-number* @@ -2152,8 +2314,24 @@ (:-ics "8") (:+ics "")) (if (member :64bit *features*) "-64bit" "")) - #+(or clisp gcl) (subseq s 0 (position #\space s)) - #+digitool (subseq s 8))) + #+clisp (subseq s 0 (position #\space s)) + #+clozure (format nil "~d.~d-fasl~d" + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) + #+cmu (substitute #\- #\/ s) + #+digitool (subseq s 8) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+lispworks (format nil "~A~@[~A~]" s + (when (member :lispworks-64bit *features*) "-64bit")) + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant + #+(or armedbear cormanlisp mcl sbcl scl) s + #-(or allegro armedbear clisp clozure cmu cormanlisp digitool + ecl gcl lispworks mcl sbcl scl) s)) (defun first-feature (features) (labels @@ -2221,28 +2399,25 @@ ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") :for dir :in (split-string dirs :separator ":") :collect (try dir "common-lisp/")) - #+windows + #+(and (or win32 windows mswindows mingw32) (not cygwin)) ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - #+(not cygwin) - ,(try (or (getenv "USERPROFILE") (user-homedir)) - "Application Data/common-lisp/config/")) + ,(try (getenv "APPDATA") "common-lisp/config/")) ,(try (user-homedir) ".config/common-lisp/"))))) (defun system-configuration-directories () (remove-if #'null (append - #+windows + #+(and (or win32 windows mswindows mingw32) (not cygwin)) (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `( - ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") + `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - #+(not cygwin) - ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) + ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) (list #p"/etc/")))) (defun in-first-directory (dirs x) (loop :for dir :in dirs - :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir))))))) + :thereis (and dir (ignore-errors + (truename (merge-pathnames* x (ensure-directory-pathname dir))))))) (defun in-user-configuration-directory (x) (in-first-directory (user-configuration-directories) x)) (defun in-system-configuration-directory (x) @@ -2299,27 +2474,16 @@ and the order is by decreasing length of namestring of the source pathname.") (defvar *user-cache* - (or - (let ((h (getenv "XDG_CACHE_HOME"))) - (and h `(,h "common-lisp" :implementation))) - #+(and windows lispworks) - (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows??? - (and h `(,h "common-lisp" "cache"))) - #+(and windows (not cygwin)) - ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache - (let ((h (or (getenv "USERPROFILE") (user-homedir)))) - (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp"))) - '(:home ".cache" "common-lisp" :implementation))) + (flet ((try (x &rest sub) (and x `(,x , at sub)))) + (or + (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* - (or - #+(and windows lispworks) - (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows??? - (and h `(,h "common-lisp" "cache"))) - #+windows - (let ((h (or (getenv "USERPROFILE") (user-homedir)))) - (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp"))) - #+(or unix cygwin) - '("/var/cache/common-lisp" :uid :implementation))) + ;; No good default, plus there's a security problem + ;; with other users messing with such directories. + *user-cache*) (defun output-translations () (car *output-translations*)) @@ -2515,10 +2679,11 @@ #+sbcl (,(getenv "SBCL_HOME") ()) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) ;; All-import, here is where we want user stuff to be: :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) ;; If we want to enable the user cache by default, here would be the place: :enable-user-cache)) @@ -2706,21 +2871,16 @@ #+abcl (defun translate-jar-pathname (source wildcard) (declare (ignore wildcard)) - (let* ((p (first (pathname-device source))) - (r (concatenate 'string - (if (and (find :windows *features*) - (not (null (pathname-device p)))) - (format nil "~A/" (pathname-device p)) - "") - (namestring (make-pathname :directory (pathname-directory p) - :name (pathname-name p) - :type (pathname-type p))))) - (root (apply-output-translations - (format nil "/___jar___file___root___/~A" r))) - (entry (make-pathname :directory (pathname-directory source) - :name (pathname-name source) - :type (pathname-type source)))) - (concatenate 'string (namestring root) (namestring entry)))) + (let* ((p (pathname (first (pathname-device source)))) + (root (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device p))))) + (apply-output-translations + (merge-pathnames* + (relativize-pathname-directory source) + (merge-pathnames* + (relativize-pathname-directory (ensure-directory-pathname p)) + root))))) ;;;; ----------------------------------------------------------------- ;;;; Compatibility mode for ASDF-Binary-Locations @@ -2860,29 +3020,33 @@ (setf *source-registry* '()) (values)) +(defun probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let ((file + (make-pathname + :defaults defaults :version :newest :case :local + :name name + :type "asd"))) + (when (probe-file file) + (return file))) + #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (concatenate 'string name ".asd") + :type "lnk"))) + (when (probe-file shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target))))))))) + (defun sysdef-source-registry-search (system) (ensure-source-registry) - (let ((name (coerce-name system))) - (block nil - (dolist (dir (source-registry)) - (let ((defaults (eval dir))) - (when defaults - (cond ((directory-pathname-p defaults) - (let ((file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local))) - #+(and (or win32 windows) (not :clisp)) - (shortcut (make-pathname - :defaults defaults :version :newest - :name name :type "asd.lnk" :case :local))) - (when (and file (probe-file file)) - (return file)) - #+(and (or win32 windows) (not :clisp)) - (when (probe-file shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target)))))))))))))) + (loop :with name = (coerce-name system) + :for defaults :in (source-registry) + :for file = (probe-asd name defaults) + :when file :return file)) (defun validate-source-registry-directive (directive) (unless @@ -2947,10 +3111,15 @@ (defun register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (funcall collect directory) - (let* ((files (ignore-errors - (directory (merge-pathnames* *wild-asd* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+clisp #+clisp :circle t))) + (let* ((files + (handler-case + (directory (merge-pathnames* *wild-asd* directory) + #+sbcl #+sbcl :resolve-symlinks nil + #+clisp #+clisp :circle t) + (error (c) + (warn "Error while scanning system definitions under directory ~S:~%~A" + directory c) + nil))) (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) :test #'equal :from-end t))) (loop @@ -2987,17 +3156,14 @@ (datadirs (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) (dirs (cons datahome (split-string datadirs :separator ":")))) - #+(and windows (not cygwin)) - ((datahome - #+lispworks (sys:get-folder-path :common-appdata) - #-lispworks (try (or (getenv "USERPROFILE") (user-homedir)) - "Application Data")) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + ((datahome (getenv "APPDATA")) (datadir #+lispworks (sys:get-folder-path :local-appdata) #-lispworks (try (getenv "ALLUSERSPROFILE") "Application Data")) (dirs (list datahome datadir))) - #+(and (not unix) (not windows) (not cygwin)) + #-(or unix win32 windows mswindows mingw32 cygwin) ((dirs ())) (loop :for dir :in dirs :collect `(:directory ,(try dir "common-lisp/systems/")) @@ -3099,9 +3265,9 @@ (initialize-source-registry))) ;;;; ----------------------------------------------------------------- -;;;; SBCL and ClozureCL hook into REQUIRE +;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL ;;;; -#+(or sbcl clozure abcl) +#+(or abcl clozure cmu ecl sbcl) (progn (defun module-provide-asdf (name) (handler-bind @@ -3111,14 +3277,16 @@ (format *error-output* "ASDF could not load ~A because ~A.~%" name e)))) (let* ((*verbose-out* (make-broadcast-stream)) - (system (asdf:find-system name nil))) + (system (find-system name nil))) (when system - (asdf:operate 'asdf:load-op name) + (load-system name) t)))) (pushnew 'module-provide-asdf - #+sbcl sb-ext:*module-provider-functions* + #+abcl sys::*module-provider-functions* #+clozure ccl::*module-provider-functions* - #+abcl sys::*module-provider-functions*)) + #+cmu ext:*module-provider-functions* + #+ecl si:*module-provider-functions* + #+sbcl sb-ext:*module-provider-functions*)) ;;;; ------------------------------------------------------------------------- ;;;; Cleanups after hot-upgrade. From mevenson at common-lisp.net Thu May 6 20:15:32 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 06 May 2010 16:15:32 -0400 Subject: [armedbear-cvs] r12656 - trunk/abcl/src/org/armedbear/lisp/util Message-ID: Author: mevenson Date: Thu May 6 16:15:26 2010 New Revision: 12656 Log: Properly implement HTTP/1.1 HEAD requests. Modified: trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java Modified: trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java (original) +++ trunk/abcl/src/org/armedbear/lisp/util/HttpHead.java Thu May 6 16:15:26 2010 @@ -92,8 +92,9 @@ return result; } - String head = "HEAD " + url + " HTTP/1.1"; + String head = "HEAD " + url.getPath() + " HTTP/1.1"; out.println(head); + out.println("Host: " + url.getAuthority()); out.println("Connection: close"); out.println(""); out.flush(); From mevenson at common-lisp.net Thu May 6 20:15:35 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 06 May 2010 16:15:35 -0400 Subject: [armedbear-cvs] r12657 - trunk/abcl/contrib/asdf-install Message-ID: Author: mevenson Date: Thu May 6 16:15:32 2010 New Revision: 12657 Log: Adjust ASDF interface to match ASDF2 definition. Modified: trunk/abcl/contrib/asdf-install/installer.lisp Modified: trunk/abcl/contrib/asdf-install/installer.lisp ============================================================================== --- trunk/abcl/contrib/asdf-install/installer.lisp (original) +++ trunk/abcl/contrib/asdf-install/installer.lisp Thu May 6 16:15:32 2010 @@ -541,8 +541,7 @@ (return-from sysdef-source-dir-search file))))))) (defmethod asdf:find-component :around - ((module (eql nil)) name &optional version) - (declare (ignore version)) + ((module (eql nil)) name) (when (or (not *propagate-installation*) (member name *systems-installed-this-time* :test (lambda (a b) From ehuelsmann at common-lisp.net Fri May 7 21:08:14 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Fri, 07 May 2010 17:08:14 -0400 Subject: [armedbear-cvs] r12658 - in trunk/abcl: . test/lisp/abcl Message-ID: Author: ehuelsmann Date: Fri May 7 17:08:12 2010 New Revision: 12658 Log: Close #38: Add some metaclass tests - to be expanded upon fixing encountered issues. Added: trunk/abcl/test/lisp/abcl/metaclass.lisp Modified: trunk/abcl/abcl.asd Modified: trunk/abcl/abcl.asd ============================================================================== --- trunk/abcl/abcl.asd (original) +++ trunk/abcl/abcl.asd Fri May 7 17:08:12 2010 @@ -32,6 +32,7 @@ :pathname "test/lisp/abcl/" :components ((:file "compiler-tests") (:file "condition-tests") + (:file "metaclass") (:file "mop-tests-setup") (:file "mop-tests" :depends-on ("mop-tests-setup")) (:file "file-system-tests") Added: trunk/abcl/test/lisp/abcl/metaclass.lisp ============================================================================== --- (empty file) +++ trunk/abcl/test/lisp/abcl/metaclass.lisp Fri May 7 17:08:12 2010 @@ -0,0 +1,118 @@ +;;; metaclass.lisp +;;; +;;; Copyright (C) 2005 Peter Graves +;;; $Id: misc-tests.lisp 12402 2010-01-26 11:15:48Z mevenson $ +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(in-package #:abcl.test.lisp) + +(defclass testclass1 () () + (:metaclass standard-class)) +(defclass testclass2 () () + (:metaclass standard-class) + (:documentation "test")) +(defclass metaclass1 (standard-class) () + (:metaclass standard-class)) +(defclass metaclass2 (standard-class) () + (:metaclass standard-class) + (:documentation "test")) + +(defclass testclass3 () () + (:metaclass metaclass1) + (:documentation "test")) + +(deftest testclass1.instantiate + (not (null (make-instance 'testclass1))) + T) +(deftest testclass2.instantiate + (not (null (make-instance 'testclass2))) + T) +(deftest testclass3.instantiate + (not (null (make-instance 'testclass3))) + T) + +(deftest testclass1.class-of + (eq (class-of (make-instance 'testclass1)) (find-class 'testclass1)) + T) +(deftest testclass1.metaclass-of + (eq (class-of (class-of (make-instance 'testclass1))) + (find-class 'standard-class)) + T) + +(deftest testclass3.metaclass-of + (eq (class-of (class-of (make-instance 'testclass3))) + (find-class 'metaclass1)) + T) + +(deftest standard-class.typep.class + (typep (class-of (find-class 'standard-class)) 'class) + T) +(deftest standard-class.typep.standard-class + (typep (class-of (class-of (find-class 'standard-class))) 'standard-class) + T) +(deftest metaclass1.typep.class + (typep (find-class 'metaclass1) 'class) + T) +(deftest metaclass1.typep.standard-class + (typep (find-class 'metaclass1) 'standard-class) + T) +(deftest testclass3.class-of.typep + (typep (class-of (make-instance 'testclass3)) 'metaclass1) + T) +(deftest testclass3.metaclass-of.typep + (typep (class-of (class-of (make-instance 'testclass3))) 'standard-class) + T) + +(defclass testclass4 () + ((a :initarg :a :initform 3) + (b :initarg :b :initform 4)) + (:metaclass metaclass1) + (:documentation "test")) + +(deftest testclass4.init-noargs + (slot-value (make-instance 'testclass4) 'a) + 3) + +(deftest testclass4.initargs + (slot-value (make-instance 'testclass4 :a 2) 'a) + 2) + +(defclass testclass5 () + ((a :initarg :a) + (b :initarg :b :initform 1)) + (:metaclass metaclass1) + (:default-initargs :a 5)) + +(deftest testclass5.init-noargs + (slot-value (make-instance 'testclass5) 'a) + 5) + +(deftest testclass5.initargs + (slot-value (make-instance 'testclass5 :a 3) 'a) + 3) + +(defclass testclass6 () + ((a :initarg :a :allocation :class)) + (:metaclass metaclass1) + (:documentation "test")) + +(deftest testclass6.1 + (let ((instance1 (make-instance 'testclass6 :a 3)) + (instance2 (make-instance 'testclass6 :a 4))) + (slot-value instance1 'a)) + 4) + + From mevenson at common-lisp.net Sat May 8 09:23:31 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 08 May 2010 05:23:31 -0400 Subject: [armedbear-cvs] r12659 - trunk/abcl Message-ID: Author: mevenson Date: Sat May 8 05:23:29 2010 New Revision: 12659 Log: Fix Ant-based invocation of Java Unit tests. Remove reference to remove FastStringBuffer tests, add reference to the UtilitiesTest class. Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Sat May 8 05:23:29 2010 @@ -671,9 +671,9 @@ - + From astalla at common-lisp.net Sat May 8 21:55:48 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 08 May 2010 17:55:48 -0400 Subject: [armedbear-cvs] r12660 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sat May 8 17:55:47 2010 New Revision: 12660 Log: Fixed and rationalized class precedence list computation for java-class metaclasses. Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Sat May 8 17:55:47 2010 @@ -325,26 +325,65 @@ (java:java-exception-cause e))))) ;;; JAVA-CLASS support +(defconstant +java-lang-object+ (jclass "java.lang.Object")) (defclass java-class (standard-class) ((jclass :initarg :java-class :initform (error "class is required") :reader java-class-jclass))) +;;init java.lang.Object class +(defconstant +java-lang-object-class+ + (%register-java-class +java-lang-object+ + (mop::ensure-class (make-symbol "java.lang.Object") + :metaclass (find-class 'java-class) + :direct-superclasses (list (find-class 'java-object)) + :java-class +java-lang-object+))) + (defun ensure-java-class (jclass) (let ((class (%find-java-class jclass))) (if class class (%register-java-class - jclass (mop::ensure-class (make-symbol (jclass-name jclass)) - :metaclass (find-class 'java-class) - :direct-superclasses (if (jclass-superclass-p jclass (jclass "java.lang.Object")) - (list (find-class 'java-object)) - (mapcar #'ensure-java-class - (delete nil - (concatenate 'list (list (jclass-superclass jclass)) - (jclass-interfaces jclass))))) - :java-class jclass))))) + jclass (mop::ensure-class + (make-symbol (jclass-name jclass)) + :metaclass (find-class 'java-class) + :direct-superclasses (mapcar #'ensure-java-class + (remove-duplicates + (delete nil + (concatenate 'list + (list (jclass-superclass jclass)) + (jclass-interfaces jclass))) + :key #'jclass-name :test #'string=)) + :java-class jclass))))) + +(defmethod mop::compute-class-precedence-list ((class java-class)) + "Sort classes this way: + 1. Java classes (but not java.lang.Object) + 2. Java interfaces + 3. java.lang.Object + 4. other classes + Rationale: + 1. Concrete classes are the most specific. + 2. Then come interfaces. + So if a generic function is specialized both on an interface and a concrete class, + the concrete class comes first. + 3. because everything is an Object. + 4. to handle base CLOS classes. + Note: Java interfaces are not sorted among themselves in any way, so if a + gf is specialized on two different interfaces and you apply it to an object that + implements both, it is unspecified which method will be called." + (let ((cpl (call-next-method))) + (flet ((score (class) + (if (not (typep class 'java-class)) + 4 + (cond + ((jcall (jmethod "java.lang.Object" "equals" "java.lang.Object") + (java-class-jclass class) +java-lang-object+) 3) + ((jclass-interface-p (java-class-jclass class)) 2) + (t 1))))) + (stable-sort cpl #'(lambda (x y) + (< (score x) (score y))))))) (defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) From astalla at common-lisp.net Sun May 9 14:58:37 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 09 May 2010 10:58:37 -0400 Subject: [armedbear-cvs] r12661 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun May 9 10:58:36 2010 New Revision: 12661 Log: Fix computation of the class precedence list for Java classes in case of multiple occurrences of the same interface in the class hierarchy. Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Sun May 9 10:58:36 2010 @@ -348,13 +348,16 @@ jclass (mop::ensure-class (make-symbol (jclass-name jclass)) :metaclass (find-class 'java-class) - :direct-superclasses (mapcar #'ensure-java-class - (remove-duplicates - (delete nil - (concatenate 'list - (list (jclass-superclass jclass)) - (jclass-interfaces jclass))) - :key #'jclass-name :test #'string=)) + :direct-superclasses + (let ((supers + (mapcar #'ensure-java-class + (delete nil + (concatenate 'list + (list (jclass-superclass jclass)) + (jclass-interfaces jclass)))))) + (if (jclass-interface-p jclass) + (append supers (list (find-class 'java-object))) + supers)) :java-class jclass))))) (defmethod mop::compute-class-precedence-list ((class java-class)) @@ -373,7 +376,7 @@ Note: Java interfaces are not sorted among themselves in any way, so if a gf is specialized on two different interfaces and you apply it to an object that implements both, it is unspecified which method will be called." - (let ((cpl (call-next-method))) + (let ((cpl (nreverse (mop::collect-superclasses* class)))) (flet ((score (class) (if (not (typep class 'java-class)) 4 From astalla at common-lisp.net Sun May 9 15:44:05 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 09 May 2010 11:44:05 -0400 Subject: [armedbear-cvs] r12662 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun May 9 11:44:04 2010 New Revision: 12662 Log: JCLASS now supports an optional CLASS-LOADER argument. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Sun May 9 11:44:04 2010 @@ -115,14 +115,14 @@ return null; } - // ### jclass name-or-class-ref => class-ref + // ### jclass name-or-class-ref &optional class-loader => class-ref private static final Primitive JCLASS = new pf_jclass(); private static final class pf_jclass extends Primitive { pf_jclass() { super(Symbol.JCLASS, "name-or-class-ref", - "Returns a reference to the Java class designated by NAME-OR-CLASS-REF."); + "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader."); } @Override @@ -130,6 +130,17 @@ { return JavaObject.getInstance(javaClass(arg)); } + + @Override + public LispObject execute(LispObject className, LispObject classLoader) + { + ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class); + if(loader != null) { + return JavaObject.getInstance(javaClass(className, loader)); + } else { + return JavaObject.getInstance(javaClass(className)); + } + } }; // ### jfield - retrieve or modify a field in a Java class or instance. @@ -1149,25 +1160,27 @@ return null; // not reached } - static Class classForName(String className) - { + private static Class classForName(String className) { + return classForName(className, JavaClassLoader.getPersistentInstance()); + } + + private static Class classForName(String className, ClassLoader classLoader) { try { - return Class.forName(className); + return Class.forName(className, true, classLoader); } catch (ClassNotFoundException e) { - try { - return Class.forName(className, true, JavaClassLoader.getPersistentInstance()); - } - catch (ClassNotFoundException ex) { - error(new LispError("Class not found: " + className)); - // Not reached. - return null; - } + error(new LispError("Class not found: " + className)); + // Not reached. + return null; } } + private static Class javaClass(LispObject obj) { + return javaClass(obj, null); + } + // Supports Java primitive types too. - static Class javaClass(LispObject obj) + static Class javaClass(LispObject obj, ClassLoader classLoader) { if (obj instanceof AbstractString || obj instanceof Symbol) { String s = javaString(obj); @@ -1188,7 +1201,12 @@ if (s.equals("double")) return Double.TYPE; // Not a primitive Java type. - Class c = classForName(s); + Class c; + if(classLoader != null) { + c = classForName(s, classLoader); + } else { + c = classForName(s); + } if (c == null) error(new LispError(s + " does not designate a Java class.")); From mevenson at common-lisp.net Mon May 10 04:15:29 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 10 May 2010 00:15:29 -0400 Subject: [armedbear-cvs] r12663 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 10 00:15:25 2010 New Revision: 12663 Log: Adjust JCLASS docstring to reflect optional classloader argument. Modified: trunk/abcl/src/org/armedbear/lisp/Java.java Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Mon May 10 00:15:25 2010 @@ -121,7 +121,7 @@ { pf_jclass() { - super(Symbol.JCLASS, "name-or-class-ref", + super(Symbol.JCLASS, "name-or-class-ref &optional class-loader", "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader."); } From mevenson at common-lisp.net Mon May 10 04:15:33 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 10 May 2010 00:15:33 -0400 Subject: [armedbear-cvs] r12664 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 10 00:15:32 2010 New Revision: 12664 Log: Add FASL and Java version to ASDF output location root cache directory. Thanks to Alan Ruttenberg. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Mon May 10 00:15:32 2010 @@ -2297,7 +2297,8 @@ (defparameter *architecture-features* '((:x86-64 :amd64 :x86_64 :x8664-target) (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) - :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc)) + :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) (defun lisp-version-string () (let ((s (lisp-implementation-version))) @@ -2329,7 +2330,8 @@ #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")) ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant - #+(or armedbear cormanlisp mcl sbcl scl) s + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+(or mcl sbcl scl) s #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) From ehuelsmann at common-lisp.net Mon May 10 21:13:28 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 10 May 2010 17:13:28 -0400 Subject: [armedbear-cvs] r12665 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 10 17:13:26 2010 New Revision: 12665 Log: Apply the speed improvement used for dispatching everywhere: all standard classes get a constant (not a variable) assigned, because that gets evaluated only at class-loading time, variables and dynamic lookups get evaluated *every* time. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon May 10 17:13:26 2010 @@ -53,6 +53,13 @@ (export '(class-precedence-list class-slots)) (defconstant +the-standard-class+ (find-class 'standard-class)) +(defconstant +the-standard-object-class+ (find-class 'standard-object)) +(defconstant +the-standard-method-class+ (find-class 'standard-method)) +(defconstant +the-standard-reader-method-class+ + (find-class 'standard-reader-method)) +(defconstant +the-standard-generic-function-class+ + (find-class 'standard-generic-function)) +(defconstant +the-T-class+ (find-class 'T)) ;; Don't use DEFVAR, because that disallows loading clos.lisp ;; after compiling it: the binding won't get assigned to T anymore @@ -556,7 +563,7 @@ direct-default-initargs &allow-other-keys) (let ((supers (or direct-superclasses - (list (find-class 'standard-object))))) + (list +the-standard-object-class+)))) (setf (class-direct-superclasses class) supers) (dolist (superclass supers) (pushnew class (class-direct-subclasses superclass)))) @@ -579,7 +586,9 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object))) +(defvar *extensible-built-in-classes* + (list (find-class 'sequence) + (find-class 'java:java-object))) (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) ;; Check for duplicate slots. @@ -740,8 +749,6 @@ (defun (setf classes-to-emf-table) (new-value gf) (set-generic-function-classes-to-emf-table gf new-value)) -(defvar the-class-standard-method (find-class 'standard-method)) - (defun (setf method-lambda-list) (new-value method) (set-method-lambda-list method new-value)) @@ -850,8 +857,8 @@ &rest all-keys &key lambda-list - (generic-function-class (find-class 'standard-generic-function)) - (method-class the-class-standard-method) + (generic-function-class +the-standard-generic-function-class+) + (method-class +the-standard-method-class+) (method-combination 'standard) (argument-precedence-order nil apo-p) documentation @@ -885,7 +892,7 @@ (error 'program-error :format-control "~A already names an ordinary function, macro, or special operator." :format-arguments (list function-name))) - (setf gf (apply (if (eq generic-function-class (find-class 'standard-generic-function)) + (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+) #'make-instance-standard-generic-function #'make-instance) generic-function-class @@ -898,7 +905,7 @@ (defun initial-discriminating-function (gf args) (set-funcallable-instance-function gf - (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-discriminating-function #'compute-discriminating-function) gf)) @@ -933,7 +940,7 @@ argument-precedence-order documentation) (declare (ignore generic-function-class)) - (let ((gf (std-allocate-instance (find-class 'standard-generic-function)))) + (let ((gf (std-allocate-instance +the-standard-generic-function-class+))) (%set-generic-function-name gf name) (setf (generic-function-lambda-list gf) lambda-list) (setf (generic-function-initial-methods gf) ()) @@ -1162,7 +1169,7 @@ (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) (setf gf (ensure-generic-function name :lambda-list method-lambda-list))) (let ((method - (if (eq (generic-function-method-class gf) the-class-standard-method) + (if (eq (generic-function-method-class gf) +the-standard-method-class+) (apply #'make-instance-standard-method gf all-keys) (apply #'make-instance (generic-function-method-class gf) all-keys)))) (%add-method gf method) @@ -1177,7 +1184,7 @@ function fast-function) (declare (ignore gf)) - (let ((method (std-allocate-instance the-class-standard-method))) + (let ((method (std-allocate-instance +the-standard-method-class+))) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) (%set-method-specializers method (canonicalize-specializers specializers)) @@ -1366,7 +1373,7 @@ (if (or (null methods) (null (%cdr methods))) methods (sort methods - (if (eq (class-of gf) (find-class 'standard-generic-function)) + (if (eq (class-of gf) +the-standard-generic-function-class+) #'(lambda (m1 m2) (std-method-more-specific-p m1 m2 required-classes (generic-function-argument-precedence-order gf))) @@ -1419,7 +1426,7 @@ (defun slow-method-lookup (gf args) (let ((applicable-methods (%compute-applicable-methods gf args))) (if applicable-methods - (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method-function #'compute-effective-method-function) gf applicable-methods))) @@ -1430,7 +1437,7 @@ (defun slow-method-lookup-1 (gf arg arg-specialization) (let ((applicable-methods (%compute-applicable-methods gf (list arg)))) (if applicable-methods - (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method-function #'compute-effective-method-function) gf applicable-methods))) @@ -1516,7 +1523,7 @@ (around (let ((next-emfun (funcall - (if (eq (class-of gf) (find-class 'standard-generic-function)) + (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method-function #'compute-effective-method-function) gf (remove around methods)))) @@ -1766,7 +1773,7 @@ fast-function slot-name) (declare (ignore gf)) - (let ((method (std-allocate-instance (find-class 'standard-reader-method)))) + (let ((method (std-allocate-instance +the-standard-reader-method-class+))) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) (%set-method-specializers method (canonicalize-specializers specializers)) @@ -1817,7 +1824,7 @@ (ensure-method function-name :lambda-list '(new-value object) :qualifiers () - :specializers (list (find-class 't) class) + :specializers (list +the-T-class+ class) ;; :function `(function ,method-function) :function (if (autoloadp 'compile) method-function From mevenson at common-lisp.net Tue May 11 14:13:19 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 11 May 2010 10:13:19 -0400 Subject: [armedbear-cvs] r12666 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 11 10:13:17 2010 New Revision: 12666 Log: Fix ASDF:MERGE-PATHNAMES* in the case that default directory is nil. Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue May 11 10:13:17 2010 @@ -516,7 +516,9 @@ ((:relative) (values (pathname-host defaults) (pathname-device defaults) - (append (pathname-directory defaults) (cdr directory)) + (if (null (pathname-directory defaults)) + directory + (append (pathname-directory defaults) (cdr directory))) (unspecific-handler defaults))) #+gcl (t From mevenson at common-lisp.net Tue May 11 14:45:53 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 11 May 2010 10:45:53 -0400 Subject: [armedbear-cvs] r12667 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 11 10:45:53 2010 New Revision: 12667 Log: Fix WILD-PATHNAME-P to check for pathname components which are strings containing "*". Not working for pathnames whose HOST or DEVICE containing "*". Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Tue May 11 10:45:53 2010 @@ -1672,13 +1672,36 @@ if (memq(Keyword.WILD_INFERIORS, directory)) { return true; } + Cons d = (Cons) directory; + while (true) { + if (d.car() instanceof AbstractString) { + String s = d.car().writeToString(); + if (s.contains("*")) { + return true; + } + } + if (d.cdr() == NIL || ! (d.cdr() instanceof Cons)) { + break; + } + d = (Cons)d.cdr(); + } } if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) { return true; } + if (name instanceof AbstractString) { + if (name.writeToString().contains("*")) { + return true; + } + } if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) { return true; } + if (type instanceof AbstractString) { + if (type.writeToString().contains("*")) { + return true; + } + } if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) { return true; } From astalla at common-lisp.net Tue May 11 18:17:22 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 11 May 2010 14:17:22 -0400 Subject: [armedbear-cvs] r12668 - trunk/abcl Message-ID: Author: astalla Date: Tue May 11 14:17:22 2010 New Revision: 12668 Log: Updated CHANGES for the 0.20 release Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Tue May 11 14:17:22 2010 @@ -22,10 +22,9 @@ * [ticket #91] Threads started through MAKE-THREAD now have a thread-termination restart available in their debugger -* [svn r12634] THREADS:THREAD-JOIN implemented +* [svn r12663] JCLASS supports an optional class-loader argument -* [svn r12638] Experimental feature to allow insertion of byte code - in compiled Lisp functions +* [svn r12634] THREADS:THREAD-JOIN implemented Fixes ----- From ehuelsmann at common-lisp.net Tue May 11 18:57:42 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 May 2010 14:57:42 -0400 Subject: [armedbear-cvs] r12669 - branches/0.20.x Message-ID: Author: ehuelsmann Date: Tue May 11 14:57:41 2010 New Revision: 12669 Log: Create 0.20 maintenance branch. Added: branches/0.20.x/ - copied from r12668, /trunk/ From ehuelsmann at common-lisp.net Tue May 11 18:58:55 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 11 May 2010 14:58:55 -0400 Subject: [armedbear-cvs] r12670 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 11 14:58:54 2010 New Revision: 12670 Log: Update trunk version number after branching 0.20. Modified: trunk/abcl/src/org/armedbear/lisp/Version.java Modified: trunk/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Version.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Version.java Tue May 11 14:58:54 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.20.0-dev"; + return "0.21.0-dev"; } public static void main(String args[]) { From mevenson at common-lisp.net Wed May 12 10:10:27 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Wed, 12 May 2010 06:10:27 -0400 Subject: [armedbear-cvs] r12671 - trunk/abcl Message-ID: Author: mevenson Date: Wed May 12 06:10:25 2010 New Revision: 12671 Log: Site specific initialization code can be named by 'abcl.startup.file'. Builds of ABCL can now be customized with "site specific" startup code by setting the Ant property 'abcl.startup.file' to the path of a file containing the custom code. This code is merged into 'system.lisp' which is loaded during the boot process. Modified: trunk/abcl/abcl.properties.in trunk/abcl/build.xml Modified: trunk/abcl/abcl.properties.in ============================================================================== --- trunk/abcl/abcl.properties.in (original) +++ trunk/abcl/abcl.properties.in Wed May 12 06:10:25 2010 @@ -10,4 +10,7 @@ #abcl.compile.lisp.skip=true # java.options sets the Java options in the abcl wrapper scripts -#java.options=-Xmx1g \ No newline at end of file +#java.options=-Xmx1g + +# Additional site specific startup code to be merged in 'system.lisp' +abcl.startup.file=${basedir}/startup.lisp Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Wed May 12 06:10:25 2010 @@ -101,7 +101,7 @@ Compiled ABCL with Java version: ${java.version} - + Cleaning all intermediate compilation artifacts. Setting 'abcl.build.incremental' enables incremental compilation. @@ -223,9 +223,12 @@ + + Compiling Lisp system @@ -241,6 +244,9 @@ + + + abcl.hostname: ${abcl.hostname} + + + + + + + + From astalla at common-lisp.net Wed May 12 22:52:35 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 12 May 2010 18:52:35 -0400 Subject: [armedbear-cvs] r12672 - branches/less-reflection/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed May 12 18:52:33 2010 New Revision: 12672 Log: FASL loader implemented. Has serious bugs (tests fail to compile), but can serve as a basis for further work. Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java Wed May 12 18:52:33 2010 @@ -97,7 +97,7 @@ symbol.setSymbolFunction(new Autoload(symbol, null, "org.armedbear.lisp.".concat(className))); } - + public void load() { if (className != null) { Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java Wed May 12 18:52:33 2010 @@ -38,7 +38,25 @@ import java.util.*; public class FaslClassLoader extends JavaClassLoader { + + private final LispObject[] functions; + private String baseName; + private LispObject loader; //The function used to load FASL functions by number + private final JavaObject boxedThis = new JavaObject(this); + public FaslClassLoader(int functionCount, String baseName, boolean useLoaderFunction) { + functions = new LispObject[functionCount]; + this.baseName = baseName; + if(useLoaderFunction) { + try { + this.loader = (LispObject) loadClass(baseName + "_0").newInstance(); + } catch(Exception e) { + //e.printStackTrace(); + Debug.trace("useLoaderFunction = true but couldn't fully init FASL loader, will fall back to reflection!"); + } + } + } + protected Class findClass(String name) throws ClassNotFoundException { try { Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); @@ -51,13 +69,11 @@ } } - //TODO have compiler generate subclass, TEST ONLY!!! - protected Map functions = new HashMap(); - - public LispObject loadFunction(String className) { + public LispObject loadFunction(int fnNumber) { try { - LispObject o = (LispObject) loadClass(className).newInstance(); - functions.put(className, o); + //Function name is fnIndex + 1 + LispObject o = (LispObject) loadClass(baseName + "_" + (fnNumber + 1)).newInstance(); + functions[fnNumber] = o; return o; } catch(Exception e) { e.printStackTrace(); @@ -66,41 +82,55 @@ } } - public LispObject getFunction(final String className) { - LispObject o = functions.get(className); + public LispObject getFunction(int fnNumber) { + if(fnNumber >= functions.length) { + return error(new LispError("Compiled function not found: " + baseName + "_" + (fnNumber + 1) + " " + Symbol.LOAD_TRUENAME.symbolValue())); + } + LispObject o = functions[fnNumber]; if(o == null) { - o = loadFunction(className); + if(loader != null) { + loader.execute(boxedThis, Fixnum.getInstance(fnNumber)); + return functions[fnNumber]; + } else { //Fallback to reflection + return loadFunction(fnNumber); + } + } else { + return o; } - return o; } - public static LispObject faslLoadFunction(String className) { - FaslClassLoader cl = (FaslClassLoader) LispThread.currentThread().safeSymbolValue(_FASL_LOADER_).javaInstance(); - return cl.getFunction(className); + public LispObject putFunction(int fnNumber, LispObject fn) { + functions[fnNumber] = fn; + return fn; } private static final Primitive MAKE_FASL_CLASS_LOADER = new pf_make_fasl_class_loader(); private static final class pf_make_fasl_class_loader extends Primitive { pf_make_fasl_class_loader() { - super("make-fasl-class-loader", PACKAGE_SYS, false, ""); + super("make-fasl-class-loader", PACKAGE_SYS, false, "function-count base-name"); + } + + @Override + public LispObject execute(LispObject functionCount, LispObject baseName) { + return execute(functionCount, baseName, T); } @Override - public LispObject execute() { - return new JavaObject(new FaslClassLoader()); + public LispObject execute(LispObject functionCount, LispObject baseName, LispObject init) { + return new FaslClassLoader(functionCount.intValue(), baseName.getStringValue(), init != NIL).boxedThis; } }; private static final Primitive GET_FASL_FUNCTION = new pf_get_fasl_function(); private static final class pf_get_fasl_function extends Primitive { pf_get_fasl_function() { - super("get-fasl-function", PACKAGE_SYS, false, "loader class-name"); + super("get-fasl-function", PACKAGE_SYS, false, "loader function-number"); } @Override - public LispObject execute(LispObject loader, LispObject className) { + public LispObject execute(LispObject loader, LispObject fnNumber) { FaslClassLoader l = (FaslClassLoader) loader.javaInstance(FaslClassLoader.class); - return l.getFunction("org.armedbear.lisp." + className.getStringValue()); + return l.getFunction(fnNumber.intValue()); } }; Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java Wed May 12 18:52:33 2010 @@ -178,20 +178,20 @@ @Override public LispObject execute() { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 0)); } @Override public LispObject execute(LispObject arg) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 1)); } @Override public LispObject execute(LispObject first, LispObject second) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 2)); } @Override @@ -199,7 +199,7 @@ LispObject third) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 3)); } @Override @@ -207,7 +207,7 @@ LispObject third, LispObject fourth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 4)); } @Override @@ -216,7 +216,7 @@ LispObject fifth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 5)); } @Override @@ -225,7 +225,7 @@ LispObject fifth, LispObject sixth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 6)); } @Override @@ -235,7 +235,7 @@ LispObject seventh) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 7)); } @Override @@ -245,7 +245,7 @@ LispObject seventh, LispObject eighth) { - return error(new WrongNumberOfArgumentsException(this)); + return error(new WrongNumberOfArgumentsException(this, 8)); } @Override Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java Wed May 12 18:52:33 2010 @@ -281,6 +281,8 @@ sb.append(c.getCondition().writeToString()); sb.append(separator); System.err.print(sb.toString()); + System.err.println("backtrace: "); + evaluate("(princ (sys::backtrace))"); System.exit(2); } ++i; Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java Wed May 12 18:52:33 2010 @@ -1243,6 +1243,7 @@ url = Lisp.class.getResource(name.getNamestring()); input = url.openStream(); } catch (IOException e) { + System.err.println("Failed to read class bytes from boot class " + url); error(new LispError("Failed to read class bytes from boot class " + url)); } } Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java Wed May 12 18:52:33 2010 @@ -252,6 +252,7 @@ } } + private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*"); static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_"); public static final LispObject loadSystemFile(final String filename, @@ -332,6 +333,7 @@ final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); + thread.bindSpecial(FASL_LOADER, NIL); try { Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); return loadFileFromStream(pathname, truename, stream, @@ -557,7 +559,7 @@ thread, Stream.currentReadtable); if (obj == EOF) break; - result = eval(obj, env, thread); + result = eval(obj, env, thread); if (print) { Stream out = checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue(thread)); Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Wed May 12 18:52:33 2010 @@ -40,6 +40,14 @@ (defvar *output-file-pathname*) +(defvar *function-packages* nil "An alist containing mappings (function-number . package). Every time an (IN-PACKAGE pkg) form is found at top-level, (*class-number* . pkg) is pushed onto this list.") + +(defun base-classname (&optional (output-file-pathname *output-file-pathname*)) + (sanitize-class-name (pathname-name output-file-pathname))) + +(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*)) + (%format nil "~A_0" (base-classname output-file-pathname))) + (declaim (ftype (function (t) t) compute-classfile-name)) (defun compute-classfile-name (n &optional (output-file-pathname *output-file-pathname*)) @@ -51,13 +59,14 @@ output-file-pathname)))) (defun sanitize-class-name (name) - (dotimes (i (length name)) + (let ((name (copy-seq name))) + (dotimes (i (length name)) (declare (type fixnum i)) (when (or (char= (char name i) #\-) (char= (char name i) #\.) (char= (char name i) #\Space)) (setf (char name i) #\_))) - name) + name)) (declaim (ftype (function () t) next-classfile-name)) @@ -124,6 +133,8 @@ (return-from process-toplevel-form)) ((IN-PACKAGE DEFPACKAGE) (note-toplevel-form form) + (if (eq operator 'in-package) + (push (cons (1+ *class-number*) (cadr form)) *function-packages*)) (setf form (precompiler:precompile-form form nil *compile-file-environment*)) (eval form) ;; Force package prefix to be used when dumping form. @@ -156,6 +167,7 @@ (parse-body body) (let* ((expr `(lambda ,lambda-list , at decls (block ,block-name , at body))) + (saved-class-number *class-number*) (classfile (next-classfile-name)) (internal-compiler-errors nil) (result (with-open-file @@ -181,7 +193,7 @@ (setf form `(fset ',name (sys::get-fasl-function *fasl-loader* - ,(pathname-name classfile)) + ,saved-class-number) ; (proxy-preloaded-function ',name ,(file-namestring classfile)) ,*source-position* ',lambda-list @@ -239,6 +251,7 @@ (let ((name (second form))) (eval form) (let* ((expr (function-lambda-expression (macro-function name))) + (saved-class-number *class-number*) (classfile (next-classfile-name))) (with-open-file (f classfile @@ -258,13 +271,13 @@ ;(proxy-preloaded-function ; '(macro-function ,name) ; ,(file-namestring classfile)) - (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))) + (sys::get-fasl-function *fasl-loader* ,saved-class-number))) `(fset ',name (make-macro ',name ;(proxy-preloaded-function ; '(macro-function ,name) ; ,(file-namestring classfile)) - (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))) + (sys::get-fasl-function *fasl-loader* ,saved-class-number)) ,*source-position* ',(third form))))))))) (DEFTYPE @@ -366,7 +379,10 @@ ;; however, binding *load-truename* isn't fully compliant, I think. (when compile-time-too (let ((*load-truename* *output-file-pathname*) - (*fasl-loader* (make-fasl-class-loader))) + (*fasl-loader* (make-fasl-class-loader + *class-number* + (concatenate 'string "org.armedbear.lisp." (base-classname)) + nil))) (eval form)))) (declaim (ftype (function (t) t) convert-ensure-method)) @@ -383,7 +399,8 @@ (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) (jvm::with-saved-compiler-policy - (let* ((classfile (next-classfile-name)) + (let* ((saved-class-number *class-number*) + (classfile (next-classfile-name)) (result (with-open-file (f classfile @@ -396,7 +413,7 @@ (declare (ignore result)) (cond (compiled-function (setf (getf tail key) - `(sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))) + `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) ;; `(load-compiled-function ,(file-namestring classfile)))) (t ;; FIXME This should be a warning or error of some sort... @@ -430,6 +447,7 @@ (return-from convert-toplevel-form (precompiler:precompile-form form nil *compile-file-environment*))) (let* ((expr `(lambda () ,form)) + (saved-class-number *class-number*) (classfile (next-classfile-name)) (result (with-open-file @@ -443,7 +461,7 @@ (declare (ignore result)) (setf form (if compiled-function - `(funcall (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)));(load-compiled-function ,(file-namestring classfile))) + `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) (precompiler:precompile-form form nil *compile-file-environment*))))) @@ -530,6 +548,7 @@ (*compile-file-truename* (truename in)) (*source* *compile-file-truename*) (*class-number* 0) + (*function-packages* nil) (namestring (namestring *compile-file-truename*)) (start (get-internal-real-time)) elapsed) @@ -592,10 +611,57 @@ :stream out) (%stream-terpri out) - ;;TODO FAKE TEST ONLY!!! (when (> *class-number* 0) + (let* ((basename (base-classname)) + (expr `(lambda (fasl-loader fn-index) + (identity fasl-loader) ;;to avoid unused arg + ;;Ugly: should export & import JVM:: symbols + #|(let ((*package* *package*)) + ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined + (when x + `(in-package ,(string x))))|# + (ecase fn-index + ,@(loop + :for i :from 1 :to *class-number* + :collect + (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) + `(,(1- i) (jvm::with-inline-code () + ;(jvm::emit 'jvm::ldc (jvm::pool-string (symbol-name 'sys::*fasl-loader*))) + ;(jvm::emit 'jvm::ldc (jvm::pool-string (string :system))) + ;(jvm::emit-invokestatic jvm::+lisp-class+ "internInPackage" + ;(list jvm::+java-string+ jvm::+java-string+) jvm::+lisp-symbol+) + ;(jvm::emit-push-current-thread) + ; (jvm::emit-invokevirtual jvm::+lisp-symbol-class+ "symbolValue" + ; (list jvm::+lisp-thread+) jvm::+lisp-object+) + (jvm::emit 'jvm::aload 1) + (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + nil jvm::+java-object+) + (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") + (jvm::emit 'jvm::dup) + (jvm::emit-push-constant-int ,(1- i)) + (jvm::emit 'jvm::new ,class) + (jvm::emit 'jvm::dup) + (jvm::emit-invokespecial-init ,class '()) + (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" + (list "I" jvm::+lisp-object+) jvm::+lisp-object+) + (jvm::emit 'jvm::pop)) + t)))))) + (classname (fasl-loader-classname)) + (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") + *output-file-pathname*)))) + (jvm::with-saved-compiler-policy + (jvm::with-file-compilation + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (jvm:compile-defun nil expr nil + classfile f nil))))) (write (list 'setq '*fasl-loader* - '(sys::make-fasl-class-loader)) :stream out) + `(sys::make-fasl-class-loader + ,*class-number* + ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out) (%stream-terpri out)) #| (dump-form `(dotimes (,count-sym ,*class-number*) @@ -633,7 +699,8 @@ (zipfile (namestring (merge-pathnames (make-pathname :type type) output-file))) - (pathnames ())) + (pathnames (list (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") + output-file))))) (dotimes (i *class-number*) (let* ((pathname (compute-classfile-name (1+ i)))) (when (probe-file pathname) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp Wed May 12 18:52:33 2010 @@ -958,7 +958,8 @@ (symbol-name symbol)) 'precompiler)))) (unless (and handler (fboundp handler)) - (error "No handler for ~S." symbol)) + (error "No handler for ~S." (let ((*package* (find-package :keyword))) + (format nil "~S" symbol)))) (setf (get symbol 'precompile-handler) handler))) (defun install-handlers () From mevenson at common-lisp.net Thu May 13 12:47:51 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 13 May 2010 08:47:51 -0400 Subject: [armedbear-cvs] r12673 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 13 08:47:51 2010 New Revision: 12673 Log: Load 'system.lisp' later in boot so conditions trigger debugger. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/boot.lisp 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 May 13 08:47:51 2010 @@ -92,6 +92,7 @@ } initializeLisp(); initializeTopLevel(); + initializeSystem(); if (!noinit) processInitializationFile(); if (args != null) @@ -117,6 +118,7 @@ initializeJLisp(); initializeTopLevel(); + initializeSystem(); processInitializationFile(); return interpreter; } @@ -211,6 +213,11 @@ } } + private static synchronized void initializeSystem() + { + Load.loadSystemFile("system"); + } + // Check for --noinit; verify that arguments are supplied for --load and // --eval options. Copy all unrecognized arguments into // ext:*command-line-argument-list* Modified: trunk/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/boot.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/boot.lisp Thu May 13 08:47:51 2010 @@ -209,12 +209,4 @@ (%format t "Startup completed in ~A seconds.~%" (float (/ (ext:uptime) 1000))))) -;;; "system.lisp" contains system installation specific information -;;; (currently only the logical pathname definition for "SYS;SRC") -;;; that is not currently required for ABCL to run. Since -;;; LOAD-SYSTEM-FILE exits the JVM if its argument cannot be found, we -;;; use REQUIRE trapping any error. -(handler-case - (require 'system) - (t ())) From mevenson at common-lisp.net Thu May 13 12:59:18 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 13 May 2010 08:59:18 -0400 Subject: [armedbear-cvs] r12674 - trunk/abcl Message-ID: Author: mevenson Date: Thu May 13 08:59:18 2010 New Revision: 12674 Log: Correct to "everything commented out" convention. Modified: trunk/abcl/abcl.properties.in Modified: trunk/abcl/abcl.properties.in ============================================================================== --- trunk/abcl/abcl.properties.in (original) +++ trunk/abcl/abcl.properties.in Thu May 13 08:59:18 2010 @@ -13,4 +13,4 @@ #java.options=-Xmx1g # Additional site specific startup code to be merged in 'system.lisp' -abcl.startup.file=${basedir}/startup.lisp +#abcl.startup.file=${basedir}/startup.lisp From mevenson at common-lisp.net Thu May 13 16:38:13 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 13 May 2010 12:38:13 -0400 Subject: [armedbear-cvs] r12675 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 13 12:38:10 2010 New Revision: 12675 Log: Fix build from scratch breakage in r12673. Modified: trunk/abcl/build.xml trunk/abcl/src/org/armedbear/lisp/Interpreter.java Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Thu May 13 12:38:10 2010 @@ -241,6 +241,7 @@ classname="org.armedbear.lisp.Main"> + @@ -278,12 +279,19 @@ - + + + + + + - + 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 May 13 12:38:10 2010 @@ -52,6 +52,7 @@ private final OutputStream outputStream; private static boolean noinit = false; + private static boolean nosystem = false; private static boolean noinform = false; public static synchronized Interpreter getInstance() @@ -92,7 +93,8 @@ } initializeLisp(); initializeTopLevel(); - initializeSystem(); + if (!nosystem) + initializeSystem(); if (!noinit) processInitializationFile(); if (args != null) @@ -231,6 +233,8 @@ String arg = args[i]; if (arg.equals("--noinit")) { noinit = true; + } else if (arg.equals("--nosystem")) { + nosystem = true; } else if (arg.equals("--noinform")) { noinform = true; } else if (arg.equals("--batch")) { From mevenson at common-lisp.net Thu May 13 16:44:06 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 13 May 2010 12:44:06 -0400 Subject: [armedbear-cvs] r12676 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 13 12:44:05 2010 New Revision: 12676 Log: Muffle warning from Ant 1.8.1 about includeantruntime not being set. Modified: trunk/abcl/abcl.in trunk/abcl/build.xml trunk/abcl/src/org/armedbear/lisp/require.lisp Modified: trunk/abcl/abcl.in ============================================================================== --- trunk/abcl/abcl.in (original) +++ trunk/abcl/abcl.in Thu May 13 12:44:05 2010 @@ -19,8 +19,13 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -exec @JAVA@ @ABCL_JAVA_OPTIONS@ \ - -cp @ABCL_CLASSPATH@ \ +if [ -z ${CLASSPATH} ]; then + CLASSPATH=@ABCL_CLASSPATH@ +else + CLASSPATH=@ABCL_CLASSPATH@:${CLASSPATH} +fi + +CLASSPATH=$CLASSPATH exec @JAVA@ @ABCL_JAVA_OPTIONS@ \ org.armedbear.lisp.Main \ "$@" Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml (original) +++ trunk/abcl/build.xml Thu May 13 12:44:05 2010 @@ -176,6 +176,7 @@ Modified: trunk/abcl/src/org/armedbear/lisp/require.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/require.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/require.lisp Thu May 13 12:44:05 2010 @@ -38,15 +38,31 @@ (defun module-provide-system (module) (let ((*readtable* (copy-readtable nil))) - (handler-case - (load-system-file (string-downcase (string module))) - (t (e) - (unless (and (typep e 'error) - (search "Failed to find loadable system file" - (format nil "~A" e))) - (format *error-output* "Failed to require ~A because '~A'~%" - module e)) - nil)))) + (handler-case + (load-system-file (string-downcase (string module))) + (t (e) + (unless (and (typep e 'error) + (search "Failed to find loadable system file" + (format nil "~A" e))) + (format *error-output* "Failed to require ~A because '~A'~%" + module e)) + nil)))) + + ;; (progn + ;; (format t "BEFORE~%") + ;; (load-system-file (string-downcase (string module))) + ;; (format t "AFTER~%")) + ;; ((error (c) + ;; (progn + ;; (format t "MATCHED~%") + ;; ;; XXX It would be much better to detect an error + ;; ;; type rather than searching for a string, but + + ;; ;; that's tricky as LOAD-SYSTEM-FILE is such an + ;; ;; early primitive. + ;; (when (search "Failed to find loadable system file" + ;; (format nil "~A" c)) + ;; (return-from module-provide-system (values nil c))))))))) (defvar *module-provider-functions* nil) @@ -61,6 +77,6 @@ (unless (some (lambda (p) (funcall p module-name)) (append (list #'module-provide-system) sys::*module-provider-functions*)) - (error "Don't know how to ~S ~A." 'require module-name)))) + (warn "Failed to require ~A." module-name)))) (set-difference *modules* saved-modules)))) From mevenson at common-lisp.net Thu May 13 16:47:47 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Thu, 13 May 2010 12:47:47 -0400 Subject: [armedbear-cvs] r12677 - in trunk/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu May 13 12:47:44 2010 New Revision: 12677 Log: Correct incorrect inclusion of changes in last commit. Modified: trunk/abcl/abcl.in trunk/abcl/src/org/armedbear/lisp/require.lisp Modified: trunk/abcl/abcl.in ============================================================================== --- trunk/abcl/abcl.in (original) +++ trunk/abcl/abcl.in Thu May 13 12:47:44 2010 @@ -19,13 +19,8 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -if [ -z ${CLASSPATH} ]; then - CLASSPATH=@ABCL_CLASSPATH@ -else - CLASSPATH=@ABCL_CLASSPATH@:${CLASSPATH} -fi - -CLASSPATH=$CLASSPATH exec @JAVA@ @ABCL_JAVA_OPTIONS@ \ +exec @JAVA@ @ABCL_JAVA_OPTIONS@ \ + -cp @ABCL_CLASSPATH@ \ org.armedbear.lisp.Main \ "$@" Modified: trunk/abcl/src/org/armedbear/lisp/require.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/require.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/require.lisp Thu May 13 12:47:44 2010 @@ -38,31 +38,15 @@ (defun module-provide-system (module) (let ((*readtable* (copy-readtable nil))) - (handler-case - (load-system-file (string-downcase (string module))) - (t (e) - (unless (and (typep e 'error) - (search "Failed to find loadable system file" - (format nil "~A" e))) - (format *error-output* "Failed to require ~A because '~A'~%" - module e)) - nil)))) - - ;; (progn - ;; (format t "BEFORE~%") - ;; (load-system-file (string-downcase (string module))) - ;; (format t "AFTER~%")) - ;; ((error (c) - ;; (progn - ;; (format t "MATCHED~%") - ;; ;; XXX It would be much better to detect an error - ;; ;; type rather than searching for a string, but - - ;; ;; that's tricky as LOAD-SYSTEM-FILE is such an - ;; ;; early primitive. - ;; (when (search "Failed to find loadable system file" - ;; (format nil "~A" c)) - ;; (return-from module-provide-system (values nil c))))))))) + (handler-case + (load-system-file (string-downcase (string module))) + (t (e) + (unless (and (typep e 'error) + (search "Failed to find loadable system file" + (format nil "~A" e))) + (format *error-output* "Failed to require ~A because '~A'~%" + module e)) + nil)))) (defvar *module-provider-functions* nil) @@ -77,6 +61,6 @@ (unless (some (lambda (p) (funcall p module-name)) (append (list #'module-provide-system) sys::*module-provider-functions*)) - (warn "Failed to require ~A." module-name)))) + (error "Don't know how to ~S ~A." 'require module-name)))) (set-difference *modules* saved-modules)))) From vvoutilainen at common-lisp.net Thu May 13 20:03:07 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Thu, 13 May 2010 16:03:07 -0400 Subject: [armedbear-cvs] r12678 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Thu May 13 16:03:06 2010 New Revision: 12678 Log: Re #96: partial fix for argument lists where &key appears before &rest. This fix takes care of the defun cases, but some lambda cases still go unnoticed. Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Thu May 13 16:03:06 2010 @@ -162,6 +162,11 @@ } else if (obj == Symbol.AND_REST || obj == Symbol.AND_BODY) { + if (_andKey) + { + error(new ProgramError( + "&REST/&BODY must precede &KEY.")); + } state = STATE_REST; arity = -1; maxArgs = -1; From astalla at common-lisp.net Thu May 13 21:15:08 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 13 May 2010 17:15:08 -0400 Subject: [armedbear-cvs] r12679 - in branches/less-reflection/abcl: . contrib/asdf-install doc/asdf src/org/armedbear/lisp src/org/armedbear/lisp/util test/lisp/abcl Message-ID: Author: astalla Date: Thu May 13 17:15:07 2010 New Revision: 12679 Log: Fixed missing probe-file in zipped fasl construction. Advanced the branch to merge the latest trunk updates. Modified: branches/less-reflection/abcl/CHANGES branches/less-reflection/abcl/abcl.asd branches/less-reflection/abcl/abcl.properties.in branches/less-reflection/abcl/build.xml branches/less-reflection/abcl/contrib/asdf-install/installer.lisp branches/less-reflection/abcl/doc/asdf/asdf.texinfo branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp Modified: branches/less-reflection/abcl/CHANGES ============================================================================== --- branches/less-reflection/abcl/CHANGES (original) +++ branches/less-reflection/abcl/CHANGES Thu May 13 17:15:07 2010 @@ -1,3 +1,68 @@ +Version 0.20 +============ +yet-to-be-tagged +(???) + + +Features +-------- + +* [svn r12576] Support for CLOS METACLASS feature + +* [svn r12591-602] Consolidation of copy/paste code in the readers + +* [svn r12619] Update included ASDF (to ASDF2) + +* [svn r12620] Use interpreted function in FASL when compilation fails + +* [ticket 95] Pathname functions work with URLs and JARs + +* Many small speed improvements (by marking functions 'final') + +* [ticket #91] Threads started through MAKE-THREAD now have a + thread-termination restart available in their debugger + +* [svn r12663] JCLASS supports an optional class-loader argument + +* [svn r12634] THREADS:THREAD-JOIN implemented + +Fixes +----- + +* [ticket 89] Inlining of READ-LINE broken when the return value + is unused + +* [svn r12636] Java class verification error when compiling PROGV + in a context wanting an unboxed return value (typically a + logical expression) + +* [svn r12635] ABCL loads stale fasls instead of updated source + even when LOAD is called with a file name without extension + +* [ticket #92] Codepoints between #xD800 and #xDFFF are incorrectly + returned as characters from CODE-CHAR + +* [ticket #93] Reader doesn't handle zero returned values from + macro functions correctly + +* [ticket #79] Different, yet similarly named, uninterned symbols + are incorrectly coalesced into the same object in a fasl. + +* [ticket #86] No restarts available to kill a thread, if none + bound by user code + +* [svn r12586] Increased function dispatch speed by eliminating + FIND-CLASS calls (replacing them by constant references) + +Other +----- + +* [svn r12581] LispCharacter() constructors made private, in favor + of getInstance() for better re-use of pre-constructed characters + +* [svn r12583] JAVA-CLASS reimplemented in Lisp + + Version 0.19 ============ svn://common-lisp.net/project/armedbear/svn/trunk/abcl @@ -78,8 +143,8 @@ * [svn r12441] ZipCache now caches all references to ZipFiles based on the last-modified time for local files. Remote files are always - retrieved due to problems in the underlying JVM code. - + retrieved due to problems in the underlying JVM code. + SYS:REMOVE-ZIP-CACHE implements a way to invalidate an entry given a pathname. @@ -187,21 +252,21 @@ for some aspects of jar pathname work added. * New toplevel 'doc' directory now contains: - + + [svn r12410] Design for the (in progress) reworking of the Stream inheritance. - + + [svn r12433] Design and current status for the re-implementation of jar pathnames. * [svn r12402] Change ABCL unit tests to use the ABCL-TEST-LISP definition contained in 'abcl.asd'. Fixed and renabled math-tests. Added new - tests for work related to handling jar pathnames. + tests for work related to handling jar pathnames. * [svn r12401] The REFERENCES-NEEDED-P field of the LOCAL-FUNCTION structure now tracks whether local functions need the capture of an actual function object. - + Version 0.18.1 ============== Modified: branches/less-reflection/abcl/abcl.asd ============================================================================== --- branches/less-reflection/abcl/abcl.asd (original) +++ branches/less-reflection/abcl/abcl.asd Thu May 13 17:15:07 2010 @@ -32,6 +32,7 @@ :pathname "test/lisp/abcl/" :components ((:file "compiler-tests") (:file "condition-tests") + (:file "metaclass") (:file "mop-tests-setup") (:file "mop-tests" :depends-on ("mop-tests-setup")) (:file "file-system-tests") Modified: branches/less-reflection/abcl/abcl.properties.in ============================================================================== --- branches/less-reflection/abcl/abcl.properties.in (original) +++ branches/less-reflection/abcl/abcl.properties.in Thu May 13 17:15:07 2010 @@ -10,4 +10,7 @@ #abcl.compile.lisp.skip=true # java.options sets the Java options in the abcl wrapper scripts -#java.options=-Xmx1g \ No newline at end of file +#java.options=-Xmx1g + +# Additional site specific startup code to be merged in 'system.lisp' +#abcl.startup.file=${basedir}/startup.lisp Modified: branches/less-reflection/abcl/build.xml ============================================================================== --- branches/less-reflection/abcl/build.xml (original) +++ branches/less-reflection/abcl/build.xml Thu May 13 17:15:07 2010 @@ -101,7 +101,7 @@ Compiled ABCL with Java version: ${java.version} - + Cleaning all intermediate compilation artifacts. Setting 'abcl.build.incremental' enables incremental compilation. @@ -143,7 +143,7 @@ - + @@ -176,6 +176,7 @@ @@ -223,9 +224,12 @@ + + Compiling Lisp system @@ -238,9 +242,13 @@ classname="org.armedbear.lisp.Main"> + + + + abcl.hostname: ${abcl.hostname} + + + + + + + + + + + + + + @@ -671,9 +696,9 @@ - + @@ -705,7 +730,7 @@ - + Modified: branches/less-reflection/abcl/contrib/asdf-install/installer.lisp ============================================================================== --- branches/less-reflection/abcl/contrib/asdf-install/installer.lisp (original) +++ branches/less-reflection/abcl/contrib/asdf-install/installer.lisp Thu May 13 17:15:07 2010 @@ -541,8 +541,7 @@ (return-from sysdef-source-dir-search file))))))) (defmethod asdf:find-component :around - ((module (eql nil)) name &optional version) - (declare (ignore version)) + ((module (eql nil)) name) (when (or (not *propagate-installation*) (member name *systems-installed-this-time* :test (lambda (a b) Modified: branches/less-reflection/abcl/doc/asdf/asdf.texinfo ============================================================================== --- branches/less-reflection/abcl/doc/asdf/asdf.texinfo (original) +++ branches/less-reflection/abcl/doc/asdf/asdf.texinfo Thu May 13 17:15:07 2010 @@ -32,6 +32,9 @@ This manual describes ASDF, a system definition facility for Common Lisp programs and libraries. +You can find the latest version of this manual at + at url{http://common-lisp.net/project/asdf/asdf.html}. + ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors. @@ -167,12 +170,12 @@ the ASDF internals and how to extend ASDF. @emph{Nota Bene}: -We are preparing for a release of ASDF 2, +We are preparing for a release of ASDF 2, hopefully for May 2010, which will have version 2.000 and later. -Current releases, in the 1.600 series and beyond, +Current releases, in the 1.700 series and beyond, should be considered as release candidates. We're still working on polishing the code and documentation. - at ref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. + at xref{FAQ,,``What has changed between ASDF 1 and ASDF 2?''}. @node Loading ASDF, Configuring ASDF, Introduction, Top @@ -238,7 +241,7 @@ then you're using an old version of ASDF (from before 1.635). If it returns @code{NIL} then ASDF is not installed. -If you are running a version older than 1.678, +If you are running a version older than 1.711, we recommend that you load a newer ASDF using the method below. @@ -532,7 +535,7 @@ each in subtly different and incompatible ways: ASDF-Binary-Locations, cl-launch, common-lisp-controller. ASDF-Binary-Locations is now not needed anymore and should not be used. -cl-launch 3.0 and common-lisp-controller 7.1 have been updated +cl-launch 2.900 and common-lisp-controller 7.1 have been updated to just delegate this functionality to ASDF. @node Using ASDF, Defining systems with defsystem, Configuring ASDF, Top @@ -549,7 +552,7 @@ (asdf:load-system :@var{foo}) @end example -On some implementations (namely, SBCL and Clozure CL), +On some implementations (namely ABCL, Clozure CL, CMUCL, ECL and SBCL), ASDF hooks into the @code{CL:REQUIRE} facility and you can just use: @@ -1316,11 +1319,11 @@ @code{defsystem} grammar subsection, which doesn't provide any obvious way to specify required features. Furthermore, in 2009, discussions on the - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} suggested that the specification of required features may be broken, and that no one may have been using them for a while. Please contact the - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} if you are interested in getting this features feature fixed.} Traditionally defsystem users have used reader conditionals @@ -1671,7 +1674,7 @@ where output file caches are located. Mentions of XDG variables refer to that document. - at uref{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} + at url{http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html} This specification allows the user to specify some environment variables to customize how applications behave to his preferences. @@ -2463,7 +2466,7 @@ There is also a STABLE version, which is earlier than release. You may get the ASDF source repository using git: - at kbd{git clone http://common-lisp.net/project/asdf/asdf.git} + at kbd{git clone git://common-lisp.net/projects/asdf/asdf.git} You will find the above referenced tags in this repository. You can also browse the repository on @@ -2472,7 +2475,7 @@ Discussion of ASDF development is conducted on the mailing list @kbd{asdf-devel@@common-lisp.net}. - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel} @node FAQ, TODO list, Getting the latest version, Top @@ -2484,7 +2487,7 @@ ASDF bugs are tracked on launchpad: @url{https://launchpad.net/asdf}. If you're unsure about whether something is a bug, of for general discussion, -use the @uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} +use the @url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list} @section ``What has changed between ASDF 1 and ASDF 2?'' @@ -2496,7 +2499,7 @@ While the code and documentation are essentially complete we are still working on polishing them before release. -Releases in the 1.600 series and beyond +Releases in the 1.700 series and beyond should be considered as release candidates. For all practical purposes, ASDF 2 refers to releases later than 1.656, @@ -2513,12 +2516,14 @@ we recommend that you should upgrade to ASDF 2 or its latest release candidate. - at subsection ASDF can portably name files inside systems and components + at subsection ASDF can portably name files in subdirectories Common Lisp namestrings are not portable, except maybe for logical pathnamestrings, -that themselves require a lot of setup that is itself ultimately non-portable. -The only portable ways to refer to pathnames inside systems and components +that themselves have various limitations and require a lot of setup +that is itself ultimately non-portable. + +In ASDF 1, the only portable ways to refer to pathnames inside systems and components were very awkward, using @code{#.(make-pathname ...)} and @code{#.(merge-pathnames ...)}. Even the above were themselves were inadequate in the general case @@ -2534,6 +2539,7 @@ @xref{The defsystem grammar,,Pathname specifiers}. + @subsection Output translations A popular feature added to ASDF was output pathname translation: @@ -2571,13 +2577,24 @@ with sensible defaults, adequate configuration languages, and a coherent set of configuration files and hooks. +We believe it's a vast improvement because it decouples +application distribution from library distribution. +The application writer can avoid thinking where the libraries are, +and the library distributor (dpkg, clbuild, advanced user, etc.) +can configure them once and for every application. +Yet settings can be easily overridden where needed, +so whoever needs control has exactly as much as required. + At the same time, ASDF 2 remains compatible with the old magic you may have in your build scripts +(using @code{*central-registry*} and + at code{*system-definition-search-functions*}) to tailor the ASDF configuration to your build automation needs, and also allows for new magic, simpler and more powerful magic. @xref{Controlling where ASDF searches for systems}. + @subsection Usual operations are made easier to the user In ASDF 1, you had to use the awkward syntax @@ -2592,23 +2609,43 @@ @subsection Many bugs have been fixed -These issues and many others have been fixed, -including the following: +The following issues and many others have been fixed: -Dependencies were not correctly propagated -across submodules within a system. + at itemize + at item +The infamous TRAVERSE function has been revamped significantly, +with many bugs squashed. +In particular, dependencies were not correctly propagated +across submodules within a system but now are. +The :version and :feature features and +the :force (system1 .. systemN) feature have been fixed. + at item +Performance has been notably improved for large systems +(say with thousands of components) by using +hash-tables instead of linear search, +and linear-time list accumulation +instead of quadratic-time recursive appends. + + at item Many features used to not be portable, especially where pathnames were involved. +Windows support was notably quirky because of such non-portability. -The internal test suite used to massively fail -in many implementations. + at item +The internal test suite used to massively fail on many implementations. +While still incomplete, it now fully passes +on all implementations supported by the test suite. -Support was broken for some implementations (notably ABCL). + at item +Support was lacking for some implementations. +ABCL was notably wholly broken. +ECL extensions were not integrated in the ASDF release. + at item The documentation was grossly out of date. -ECL extensions were not integrated in the ASDF release. + at end itemize @subsection ASDF itself is versioned @@ -2623,9 +2660,10 @@ With ASDF 2, we provide a new stable set of working features that everyone can rely on from now on. Use @code{#+asdf2} to detect presence of ASDF 2, - at code{(asdf:version-satisfies (asdf:asdf-version) "1.678")} + at code{(asdf:version-satisfies (asdf:asdf-version) "1.711")} to check the availability of a version no earlier than required. + @subsection ASDF can be upgraded When an old version of ASDF was loaded, @@ -2667,6 +2705,64 @@ the practical consequence of which will mean faster convergence towards the latest version for everyone. + + at subsection Pitfalls of ASDF 2 + +The main pitfalls in upgrading to ASDF 2 seem to be related +to the output translation mechanism. + + at itemize + + at item +Output translations is enabled by default. This may surprise some users, +most of them in pleasant way (we hope), a few of them in an unpleasant way. +It is trivial to disable output translations. + at xref{FAQ,,``How can I wholly disable the compiler output cache?''}. + + at item +Some systems in the large have been known not to play well with output translations. +They were relatively easy to fix. +Once again, it is also easy to disable output translations, +or to override its configuration. + + at item +The new ASDF output translations are incompatible with ASDF-Binary-Locations. +They replace A-B-L, and there is compatibility mode to emulate +your previous A-B-L configuration. +See @code{asdf:enable-asdf-binary-locations-compatibility} in + at pxref{Controlling where ASDF saves compiled files,,Backward Compatibility}. +But thou shall not load ABL on top of ASDF 2. + + at end itemize + +Other issues include the following: + + at itemize + + at item +There is a slight performance bug, notably on SBCL, +when initially searching for @file{asd} files, +the implicit @code{(directory "/configured/path/**/*.asd")} +for every configured path @code{(:tree "/configured/path/")} +in your @code{source-registry} configuration can cause a slight pause. +Try to @code{(time (asdf:initialize-source-registry))} +to see how bad it is or isn't on your system. +If you insist on not having this pause, +you can avoid the pause by overriding the default source-registry configuration +and not use any deep @code{:tree} entry but only @code{:directory} entries +or shallow @code{:tree} entries. +Or you can fix your implementation to not be quite that slow +when recursing through directories. + + at item +On Windows, only LispWorks supports proper default configuration pathnames +based on the Windows registry. +Other implementations make do. +Windows support is largely untested, so please help report and fix bugs. + + at end itemize + + @section Issues with installing the proper version of ASDF @subsection ``My Common Lisp implementation comes with an outdated version of ASDF. What to do?'' @@ -2690,25 +2786,59 @@ If there are any issues with the current release, it's a bug that you should report upstream and that we will fix ASAP. -As to how to include ASDF, we recommend that -if you do have a few magic systems in your implementation path, -that are specially treated in @code{wrapping-source-registry}, -like SBCL does. -In this case, we explicitly ask you to @emph{NOT} distribute - at file{asdf.asd} together with your implementation's ASDF, -least you separate it from the other systems in this path, -or otherwise rename the system and its @file{asd} file -to e.g. @code{asdf-sbcl} and @file{asdf-sbcl.asd}. +As to how to include ASDF, we recommend the following: + + at itemize + at item +If ASDF isn't installed yet, then @code{(require :asdf)} +should load the version of ASDF that is bundled with your system. +You may have it load some other version configured by the user, +if you allow such configuration. + + at item +If your system provides a mechanism to hook into @code{CL:REQUIRE}, +then it would be nice to add ASDF to this hook the same way that +ABCL, CCL, CMUCL, ECL and SBCL do it. + + at item +You may, like SBCL, have ASDF be implicitly used to require systems +that are bundled with your Lisp distribution. +If you do have a few magic systems that come with your implementation +in a precompiled way such that one should only use the binary version +that goes with your distribution, like SBCL does, +then you should add them in the beginning of @code{wrapping-source-registry}. + + at item +If you have magic systems as above, like SBCL does, +then we explicitly ask you to @emph{NOT} distribute + at file{asdf.asd} as part of those magic systems. +You should still include the file @file{asdf.lisp} in your source distribution +and precompile it in your binary distribution, +but @file{asdf.asd} if included at all, +should be secluded from the magic systems, +in a separate file hierarchy, +or you may otherwise rename the system and its file to e.g. + at code{asdf-ecl} and @file{asdf-ecl.asd}, or + at code{sb-asdf} and @file{sb-asdf.asd}. +Indeed, if you made @file{asdf.asd} a magic system, +then users would no longer be able to upgrade ASDF using ASDF itself +to some version of their preference that +they maintain independently from your Lisp distribution. + at item If you do not have any such magic systems, or have other non-magic systems that you want to bundle with your implementation, then you may add them to the @code{default-source-registry}, and you are welcome to include @file{asdf.asd} amongst them. -Please send upstream any patches you make to ASDF itself, + at item +Please send us upstream any patches you make to ASDF itself, so we can merge them back in for the benefit of your users when they upgrade to the upstream version. + at end itemize + + @section Issues with configuring ASDF @@ -2772,9 +2902,9 @@ The test operation, however, is largely left to the system definer to specify. @code{test-op} has been a topic of considerable discussion on the - at uref{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, + at url{http://common-lisp.net/cgi-bin/mailman/listinfo/asdf-devel,asdf-devel mailing list}, and on the - at uref{https://launchpad.net/asdf,launchpad bug-tracker}. + at url{https://launchpad.net/asdf,launchpad bug-tracker}. Here are some guidelines: Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/AutoloadedFunctionProxy.java Thu May 13 17:15:07 2010 @@ -50,7 +50,7 @@ new Symbol[] { AUTOLOADING_CACHE, // allow loading local preloaded functions - Load._FASL_ANONYMOUS_PACKAGE_, // package for uninterned symbols + Load._FASL_UNINTERNED_SYMBOLS_, // vector of uninterned symbols Symbol._PACKAGE_, // current package Symbol.LOAD_TRUENAME // LOAD-TIME-VALUE depends on this }; Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReader.java Thu May 13 17:15:07 2010 @@ -141,12 +141,7 @@ { LispThread thread = LispThread.currentThread(); - Symbol symbol = (Symbol) stream.readSymbol(FaslReadtable.getInstance()); - LispObject pkg = Load._FASL_ANONYMOUS_PACKAGE_.symbolValue(thread); - Debug.assertTrue(pkg != NIL); - symbol = ((Package)pkg).intern(symbol.getName()); - symbol.setPackage(NIL); - return symbol; + return stream.readSymbol(FaslReadtable.getInstance()); } }; @@ -277,10 +272,41 @@ { @Override public LispObject execute(Stream stream, char c, int n) - { return stream.readCharacterLiteral(FaslReadtable.getInstance(), LispThread.currentThread()); } }; + + // ### fasl-sharp-question-mark + public static final DispatchMacroFunction FASL_SHARP_QUESTION_MARK = + new DispatchMacroFunction("fasl-sharp-question-mark", PACKAGE_SYS, + false, "stream sub-char numarg") + { + @Override + public LispObject execute(Stream stream, char c, int n) + { + LispThread thread = LispThread.currentThread(); + LispObject uninternedSymbols = + Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(thread); + + if (! (uninternedSymbols instanceof Cons)) // it must be a vector + return uninternedSymbols.AREF(n); + + // During normal loading, we won't get to this bit, however, + // with eval-when processing, we may need to fall back to + // *FASL-UNINTERNED-SYMBOLS* being an alist structure + LispObject label = LispInteger.getInstance(n); + while (uninternedSymbols != NIL) + { + LispObject item = uninternedSymbols.car(); + if (label.eql(item.cdr())) + return item.car(); + + uninternedSymbols = uninternedSymbols.cdr(); + } + return error(new LispError("No entry for uninterned symbol.")); + } + }; + } Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslReadtable.java Thu May 13 17:15:07 2010 @@ -100,6 +100,7 @@ dtfunctions[10] = LispReader.SHARP_ILLEGAL; // newline, linefeed dtfunctions[12] = LispReader.SHARP_ILLEGAL; // page dtfunctions[13] = LispReader.SHARP_ILLEGAL; // return + dtfunctions['?'] = FaslReader.FASL_SHARP_QUESTION_MARK; dispatchTables.constants['#'] = dt; readtableCase = Keyword.UPCASE; Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Interpreter.java Thu May 13 17:15:07 2010 @@ -52,6 +52,7 @@ private final OutputStream outputStream; private static boolean noinit = false; + private static boolean nosystem = false; private static boolean noinform = false; public static synchronized Interpreter getInstance() @@ -92,6 +93,8 @@ } initializeLisp(); initializeTopLevel(); + if (!nosystem) + initializeSystem(); if (!noinit) processInitializationFile(); if (args != null) @@ -117,6 +120,7 @@ initializeJLisp(); initializeTopLevel(); + initializeSystem(); processInitializationFile(); return interpreter; } @@ -211,6 +215,11 @@ } } + private static synchronized void initializeSystem() + { + Load.loadSystemFile("system"); + } + // Check for --noinit; verify that arguments are supplied for --load and // --eval options. Copy all unrecognized arguments into // ext:*command-line-argument-list* @@ -224,6 +233,8 @@ String arg = args[i]; if (arg.equals("--noinit")) { noinit = true; + } else if (arg.equals("--nosystem")) { + nosystem = true; } else if (arg.equals("--noinform")) { noinform = true; } else if (arg.equals("--batch")) { @@ -280,9 +291,8 @@ thread.bindSpecial(Symbol.PRINT_ESCAPE, NIL); sb.append(c.getCondition().writeToString()); sb.append(separator); - System.err.print(sb.toString()); - System.err.println("backtrace: "); - evaluate("(princ (sys::backtrace))"); + System.err.println(sb); + //evaluate("(pprint (sys::backtrace))"); System.exit(2); } ++i; @@ -465,7 +475,7 @@ public LispObject execute(LispObject first, LispObject second) throws UnhandledCondition { - final Condition condition = (Condition) first; + final LispObject condition = first; if (interpreter == null) { final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Java.java Thu May 13 17:15:07 2010 @@ -115,14 +115,14 @@ return null; } - // ### jclass name-or-class-ref => class-ref + // ### jclass name-or-class-ref &optional class-loader => class-ref private static final Primitive JCLASS = new pf_jclass(); private static final class pf_jclass extends Primitive { pf_jclass() { - super(Symbol.JCLASS, "name-or-class-ref", - "Returns a reference to the Java class designated by NAME-OR-CLASS-REF."); + super(Symbol.JCLASS, "name-or-class-ref &optional class-loader", + "Returns a reference to the Java class designated by NAME-OR-CLASS-REF. If the CLASS-LOADER parameter is passed, the class is resolved with respect to the given ClassLoader."); } @Override @@ -130,6 +130,17 @@ { return JavaObject.getInstance(javaClass(arg)); } + + @Override + public LispObject execute(LispObject className, LispObject classLoader) + { + ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class); + if(loader != null) { + return JavaObject.getInstance(javaClass(className, loader)); + } else { + return JavaObject.getInstance(javaClass(className)); + } + } }; // ### jfield - retrieve or modify a field in a Java class or instance. @@ -1149,25 +1160,27 @@ return null; // not reached } - static Class classForName(String className) - { + private static Class classForName(String className) { + return classForName(className, JavaClassLoader.getPersistentInstance()); + } + + private static Class classForName(String className, ClassLoader classLoader) { try { - return Class.forName(className); + return Class.forName(className, true, classLoader); } catch (ClassNotFoundException e) { - try { - return Class.forName(className, true, JavaClassLoader.getPersistentInstance()); - } - catch (ClassNotFoundException ex) { - error(new LispError("Class not found: " + className)); - // Not reached. - return null; - } + error(new LispError("Class not found: " + className)); + // Not reached. + return null; } } + private static Class javaClass(LispObject obj) { + return javaClass(obj, null); + } + // Supports Java primitive types too. - static Class javaClass(LispObject obj) + static Class javaClass(LispObject obj, ClassLoader classLoader) { if (obj instanceof AbstractString || obj instanceof Symbol) { String s = javaString(obj); @@ -1188,7 +1201,12 @@ if (s.equals("double")) return Double.TYPE; // Not a primitive Java type. - Class c = classForName(s); + Class c; + if(classLoader != null) { + c = classForName(s, classLoader); + } else { + c = classForName(s); + } if (c == null) error(new LispError(s + " does not designate a Java class.")); Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java Thu May 13 17:15:07 2010 @@ -351,19 +351,44 @@ public static final LispObject error(LispObject condition) - { pushJavaStackFrames(); return Symbol.ERROR.execute(condition); } - public static final LispObject error(LispObject condition, LispObject message) + public static final int ierror(LispObject condition) + { + error(condition); + return 0; // Not reached + } + public static final String serror(LispObject condition) + { + error(condition); + return ""; // Not reached + } + + + public static final LispObject error(LispObject condition, LispObject message) { pushJavaStackFrames(); return Symbol.ERROR.execute(condition, Keyword.FORMAT_CONTROL, message); } + public static final int ierror(LispObject condition, LispObject message) + { + error(condition, message); + return 0; // Not reached + } + + public static final String serror(LispObject condition, LispObject message) + { + error(condition, message); + return ""; // Not reached + } + + + public static final LispObject type_error(LispObject datum, LispObject expectedType) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/LispObject.java Thu May 13 17:15:07 2010 @@ -719,14 +719,14 @@ return toString(); } - public String unreadableString(String s) { + public final String unreadableString(String s) { return unreadableString(s, true); } - public String unreadableString(Symbol sym) { + public final String unreadableString(Symbol sym) { return unreadableString(sym, true); } - public String unreadableString(String s, boolean identity) + public final String unreadableString(String s, boolean identity) { StringBuilder sb = new StringBuilder("#<"); sb.append(s); @@ -739,7 +739,7 @@ return sb.toString(); } - public String unreadableString(Symbol symbol, boolean identity) + public final String unreadableString(Symbol symbol, boolean identity) { return unreadableString(symbol.writeToString(), identity); Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/LispReader.java Thu May 13 17:15:07 2010 @@ -46,19 +46,19 @@ public LispObject execute(Stream stream, char ignored) { - try + try { while (true) { int n = stream._readChar(); if (n < 0) - return null; + return LispThread.currentThread().setValues(); if (n == '\n') - return null; + return LispThread.currentThread().setValues(); } } catch (java.io.IOException e) { - return null; + return LispThread.currentThread().setValues(); } } }; @@ -328,7 +328,7 @@ { stream.skipBalancedComment(); - return null; + return LispThread.currentThread().setValues(); } }; Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/LispThread.java Thu May 13 17:15:07 2010 @@ -48,6 +48,8 @@ final static ConcurrentHashMap map = new ConcurrentHashMap(); + LispObject threadValue = NIL; + private static ThreadLocal threads = new ThreadLocal(){ @Override public LispThread initialValue() { @@ -87,7 +89,7 @@ public void run() { try { - funcall(wrapper, + threadValue = funcall(wrapper, new LispObject[] { fun }, LispThread.this); } @@ -930,6 +932,35 @@ } }; + private static final Primitive THREAD_JOIN = + new Primitive("thread-join", PACKAGE_THREADS, true, "thread", + "Waits for thread to finish.") + { + @Override + public LispObject execute(LispObject arg) + { + // join the thread, and returns it's value. The second return + // value is T if the thread finishes normally, NIL if its + // interrupted. + if (arg instanceof LispThread) { + final LispThread joinedThread = (LispThread) arg; + final LispThread waitingThread = currentThread(); + try { + joinedThread.javaThread.join(); + return + waitingThread.setValues(joinedThread.threadValue, T); + } catch (InterruptedException e) { + waitingThread.processThreadInterrupts(); + return + waitingThread.setValues(joinedThread.threadValue, NIL); + } + } else { + return type_error(arg, Symbol.THREAD); + } + } + }; + + public static final long javaSleepInterval(LispObject lispSleep) { Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java Thu May 13 17:15:07 2010 @@ -84,14 +84,14 @@ abclPathname.invalidateNamestring(); LispObject abcl = Pathname.truename(abclPathname, false); if (lisp instanceof Pathname && abcl instanceof Pathname) { - lispPathname = (Pathname)lisp; - abclPathname = (Pathname)abcl; - long lispLastModified = lispPathname.getLastModified(); - long abclLastModified = abclPathname.getLastModified(); + lispPathname = (Pathname)lisp; + abclPathname = (Pathname)abcl; + long lispLastModified = lispPathname.getLastModified(); + long abclLastModified = abclPathname.getLastModified(); if (abclLastModified > lispLastModified) { - return lispPathname; + return abclPathname; // fasl file is newer } else { - return abclPathname; + return lispPathname; } } else if (abcl instanceof Pathname) { return (Pathname) abcl; @@ -363,7 +363,7 @@ // ### *fasl-version* // internal symbol static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(35)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(36)); // ### *fasl-external-format* // internal symbol @@ -371,15 +371,16 @@ internConstant("*FASL-EXTERNAL-FORMAT*", PACKAGE_SYS, new SimpleString("UTF-8")); - // ### *fasl-anonymous-package* + // ### *fasl-uninterned-symbols* // internal symbol /** - * This variable gets bound to a package with no name in which the - * reader can intern its uninterned symbols. + * This variable gets bound to NIL upon loading a FASL, but + * gets set to a vector of symbols as one of the first actions + * by the FASL itself. * */ - public static final Symbol _FASL_ANONYMOUS_PACKAGE_ = - internSpecial("*FASL-ANONYMOUS-PACKAGE*", PACKAGE_SYS, NIL); + public static final Symbol _FASL_UNINTERNED_SYMBOLS_ = + internSpecial("*FASL-UNINTERNED-SYMBOLS*", PACKAGE_SYS, NIL); // ### init-fasl &key version private static final Primitive INIT_FASL = new init_fasl(); @@ -395,7 +396,7 @@ if (second.eql(_FASL_VERSION_.getSymbolValue())) { // OK final LispThread thread = LispThread.currentThread(); - thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, NIL); + thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL); thread.bindSpecial(_SOURCE_, NIL); return faslLoadStream(thread); } @@ -411,8 +412,8 @@ boolean print, boolean auto) { - return loadFileFromStream(pathname == null ? NIL : pathname, - truename == null ? NIL : truename, + return loadFileFromStream(pathname == null ? NIL : pathname, + truename == null ? NIL : truename, in, verbose, print, auto, false); } @@ -585,7 +586,6 @@ final SpecialBindingsMark mark = thread.markSpecialBindings(); LispObject result = NIL; try { - thread.bindSpecial(_FASL_ANONYMOUS_PACKAGE_, new Package()); thread.bindSpecial(AUTOLOADING_CACHE, AutoloadedFunctionProxy.makePreloadingContext()); in.setExternalFormat(_FASL_EXTERNAL_FORMAT_.symbolValue(thread)); Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Pathname.java Thu May 13 17:15:07 2010 @@ -345,7 +345,7 @@ } String scheme = url.getProtocol(); if (scheme.equals("file")) { - Pathname p = new Pathname(s); + Pathname p = new Pathname(url.getFile()); this.host = p.host; this.device = p.device; this.directory = p.directory; @@ -680,10 +680,13 @@ sb.append('.'); if (type instanceof AbstractString) { String t = type.getStringValue(); - if (t.indexOf('.') >= 0) { - Debug.assertTrue(namestring == null); - return null; - } + // Allow Windows shortcuts to include TYPE + if (!(t.endsWith(".lnk") && Utilities.isPlatformWindows)) { + if (t.indexOf('.') >= 0) { + Debug.assertTrue(namestring == null); + return null; + } + } sb.append(t); } else if (type == Keyword.WILD) { sb.append('*'); @@ -737,8 +740,8 @@ // the namestring." 19.2.2.2.3.1 if (directory != NIL) { final char separatorChar; - if (device instanceof Cons) { - separatorChar = '/'; // Jar file. + if (isJar() || isURL()) { + separatorChar = '/'; } else { separatorChar = File.separatorChar; } @@ -1669,13 +1672,36 @@ if (memq(Keyword.WILD_INFERIORS, directory)) { return true; } + Cons d = (Cons) directory; + while (true) { + if (d.car() instanceof AbstractString) { + String s = d.car().writeToString(); + if (s.contains("*")) { + return true; + } + } + if (d.cdr() == NIL || ! (d.cdr() instanceof Cons)) { + break; + } + d = (Cons)d.cdr(); + } } if (name == Keyword.WILD || name == Keyword.WILD_INFERIORS) { return true; } + if (name instanceof AbstractString) { + if (name.writeToString().contains("*")) { + return true; + } + } if (type == Keyword.WILD || type == Keyword.WILD_INFERIORS) { return true; } + if (type instanceof AbstractString) { + if (type.writeToString().contains("*")) { + return true; + } + } if (version == Keyword.WILD || version == Keyword.WILD_INFERIORS) { return true; } @@ -1792,7 +1818,9 @@ if (pathname.device != NIL) { // XXX if device represent JARs we want to merge result.device = p.device; } else { - result.device = d.device; + if (!p.isURL()) { + result.device = d.device; + } } if (pathname.isJar()) { Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Stream.java Thu May 13 17:15:07 2010 @@ -481,7 +481,7 @@ char c = (char) n; // ### BUG: Codepoint conversion if (rt.isWhitespace(c)) continue; - LispObject result = processChar(c, rt); + LispObject result = processChar(thread, c, rt); if (result != null) return result; } @@ -497,15 +497,36 @@ } } - private final LispObject processChar(char c, Readtable rt) - + /** Dispatch macro function if 'c' has one associated, + * read a token otherwise. + * + * When the macro function returns zero values, this function + * returns null or the token or returned value otherwise. + */ + private final LispObject processChar(LispThread thread, + char c, Readtable rt) { final LispObject handler = rt.getReaderMacroFunction(c); - if (handler instanceof ReaderMacroFunction) - return ((ReaderMacroFunction)handler).execute(this, c); - if (handler != null && handler != NIL) - return handler.execute(this, LispCharacter.getInstance(c)); - return readToken(c, rt); + LispObject value; + + if (handler instanceof ReaderMacroFunction) { + thread._values = null; + value = ((ReaderMacroFunction)handler).execute(this, c); + } + else if (handler != null && handler != NIL) { + thread._values = null; + value = handler.execute(this, LispCharacter.getInstance(c)); + } + else + return readToken(c, rt); + + // If we're looking at zero return values, set 'value' to null + if (value == NIL) { + LispObject[] values = thread._values; + if (values != null && values.length == 0) + value = null; + } + return value; } public LispObject readPathname(ReadtableAccessor rta) { @@ -583,20 +604,16 @@ { while (true) { int n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return error(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion if (rt.getSyntaxType(c) == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { // Single escape. n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return error(new EndOfFile(this)); + sb.append((char)n); // ### BUG: Codepoint conversion continue; } @@ -657,11 +674,12 @@ // normal token beginning with '.' _unreadChar(nextChar); } - LispObject obj = processChar(c, rt); - if (obj == null) { - // A comment. + + LispObject obj = processChar(thread, c, rt); + if (obj == null) continue; - } + + if (first == null) { first = new Cons(obj); last = first; @@ -948,20 +966,16 @@ try { while (true) { int n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return serror(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion byte syntaxType = rt.getSyntaxType(c); if (syntaxType == Readtable.SYNTAX_TYPE_SINGLE_ESCAPE) { n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return null; - } + if (n < 0) + return serror(new EndOfFile(this)); + sb.append((char)n); // ### BUG: Codepoint conversion continue; } @@ -970,7 +984,7 @@ sb.append(c); } } catch (IOException e) { - error(new StreamError(this, e)); + return serror(new StreamError(this, e)); } return sb.toString(); } @@ -1114,9 +1128,9 @@ } if (n < 0) { error(new EndOfFile(this)); - // Not reached. - return flags; + return null; // Not reached } + sb.setCharAt(0, (char) n); // ### BUG: Codepoint conversion flags = new BitSet(1); flags.set(0); @@ -1230,22 +1244,19 @@ final LispObject readBaseObject = Symbol.READ_BASE.symbolValue(thread); if (readBaseObject instanceof Fixnum) { readBase = ((Fixnum)readBaseObject).value; - } else { + } else // The value of *READ-BASE* is not a Fixnum. - error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); - // Not reached. - return 10; - } - if (readBase < 2 || readBase > 36) { - error(new LispError("The value of *READ-BASE* is not of type '(INTEGER 2 36).")); - // Not reached. - return 10; - } + return ierror(new LispError("The value of *READ-BASE* is not " + + "of type '(INTEGER 2 36).")); + + if (readBase < 2 || readBase > 36) + return ierror(new LispError("The value of *READ-BASE* is not " + + "of type '(INTEGER 2 36).")); + return readBase; } private final LispObject makeNumber(String token, int length, int radix) - { if (length == 0) return null; @@ -1414,11 +1425,9 @@ try { while (true) { int n = _readChar(); - if (n < 0) { - error(new EndOfFile(this)); - // Not reached. - return 0; - } + if (n < 0) + return (char)ierror(new EndOfFile(this)); + char c = (char) n; // ### BUG: Codepoint conversion if (!rt.isWhitespace(c)) return c; @@ -1439,7 +1448,8 @@ char c = flushWhitespace(rt); if (c == delimiter) break; - LispObject obj = processChar(c, rt); + + LispObject obj = processChar(thread, c, rt); if (obj != null) result = new Cons(obj, result); } @@ -1839,9 +1849,7 @@ return n; // Reads an 8-bit byte. } catch (IOException e) { - error(new StreamError(this, e)); - // Not reached. - return -1; + return ierror(new StreamError(this, e)); } } Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Version.java Thu May 13 17:15:07 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.20.0-dev"; + return "0.21.0-dev"; } public static void main(String args[]) { Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/ZipCache.java Thu May 13 17:15:07 2010 @@ -182,7 +182,15 @@ } else { if (url.getProtocol().equals("file")) { entry = new Entry(); - File f = new File(url.getPath()); + String path = url.getPath(); + + if (Utilities.isPlatformWindows) { + String authority = url.getAuthority(); + if (authority != null) { + path = authority + path; + } + } + File f = new File(path); entry.lastModified = f.lastModified(); try { entry.file = new ZipFile(f); Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/asdf.lisp Thu May 13 17:15:07 2010 @@ -49,225 +49,286 @@ (cl:in-package :cl-user) -(declaim (optimize (speed 2) (debug 2) (safety 3))) +(declaim (optimize (speed 2) (debug 2) (safety 3)) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) -#+ecl (require 'cmp) +#+ecl (require :cmp) ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more at the end of the file. +#+gcl +(eval-when (:compile-toplevel :load-toplevel) + (defpackage :asdf-utilities (:use :cl)) + (defpackage :asdf (:use :cl :asdf-utilities))) + (eval-when (:load-toplevel :compile-toplevel :execute) + #+allegro + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) (let* ((asdf-version - ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace - (subseq "VERSION:1.679" (1+ (length "VERSION")))) - #+allegro (excl::*autoload-package-name-alist* nil) + ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:1.719" (1+ (length "VERSION")))) (existing-asdf (find-package :asdf)) - (versym '#:*asdf-version*) - (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf))) - (redefined-functions - '(#:perform #:explain #:output-files #:operation-done-p + (vername '#:*asdf-version*) + (versym (and existing-asdf + (find-symbol (string vername) existing-asdf))) + (existing-version (and versym (boundp versym) (symbol-value versym))) + (already-there (equal asdf-version existing-version))) + (unless (and existing-asdf already-there) + #-gcl + (when existing-asdf + (format *error-output* + "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" + existing-version asdf-version)) + (labels + ((rename-away (package) + (loop :with name = (package-name package) + :for i :from 1 :for new = (format nil "~A.~D" name i) + :unless (find-package new) :do + (rename-package-name package name new))) + (rename-package-name (package old new) + (let* ((old-names (cons (package-name package) + (package-nicknames package))) + (new-names (subst new old old-names :test 'equal)) + (new-name (car new-names)) + (new-nicknames (cdr new-names))) + (rename-package package new-name new-nicknames))) + (ensure-exists (name nicknames use) + (let* ((previous + (remove-duplicates + (remove-if + #'null + (mapcar #'find-package (cons name nicknames))) + :from-end t))) + (cond + (previous + ;; do away with packages with conflicting (nick)names + (map () #'rename-away (cdr previous)) + ;; reuse previous package with same name + (let ((p (car previous))) + (rename-package p name nicknames) + (ensure-use p use) + p)) + (t + (make-package name :nicknames nicknames :use use))))) + (find-sym (symbol package) + (find-symbol (string symbol) package)) + (intern* (symbol package) + (intern (string symbol) package)) + (remove-symbol (symbol package) + (let ((sym (find-sym symbol package))) + (when sym + (unexport sym package) + (unintern sym package)))) + (ensure-unintern (package symbols) + (dolist (sym symbols) (remove-symbol sym package))) + (ensure-shadow (package symbols) + (shadow symbols package)) + (ensure-use (package use) + (dolist (used (reverse use)) + (do-external-symbols (sym used) + (unless (eq sym (find-sym sym package)) + (remove-symbol sym package))) + (use-package used package))) + (ensure-fmakunbound (package symbols) + (loop :for name :in symbols + :for sym = (find-sym name package) + :when sym :do (fmakunbound sym))) + (ensure-export (package export) + (let ((syms (loop :for x :in export :collect + (intern* x package)))) + (do-external-symbols (sym package) + (unless (member sym syms) + (remove-symbol sym package))) + (dolist (sym syms) + (export sym package)))) + (ensure-package (name &key nicknames use unintern fmakunbound shadow export) + (let ((p (ensure-exists name nicknames use))) + (ensure-unintern p unintern) + (ensure-shadow p shadow) + (ensure-export p export) + (ensure-fmakunbound p fmakunbound) + p))) + (macrolet + ((pkgdcl (name &key nicknames use export + redefined-functions unintern fmakunbound shadow) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',(append #-(or gcl ecl) redefined-functions + unintern) + :fmakunbound ',(append #+(or gcl ecl) redefined-functions + fmakunbound)))) + (pkgdcl + :asdf-utilities + :nicknames (#:asdf-extensions) + :use (#:common-lisp) + :unintern (#:split #:make-collector) + :export + (#:absolute-pathname-p + #:aif + #:appendf + #:asdf-message + #:coerce-name + #:directory-pathname-p + #:ends-with + #:ensure-directory-pathname + #:getenv + #:get-uid + #:length=n-p + #:merge-pathnames* + #:pathname-directory-pathname + #:read-file-forms + #:remove-keys + #:remove-keyword + #:resolve-symlinks + #:split-string + #:component-name-to-pathname-components + #:split-name-type + #:system-registered-p + #:truenamize + #:while-collecting)) + (pkgdcl + :asdf + :use (:common-lisp :asdf-utilities) + :redefined-functions + (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname - #:system-source-file))) - (unless (equal asdf-version existing-version) - (labels ((rename-away (package) - (loop :with name = (package-name package) - :for i :from 1 :for new = (format nil "~A.~D" name i) - :unless (find-package new) :do - (rename-package-name package name new))) - (rename-package-name (package old new) - (let* ((old-names (cons (package-name package) (package-nicknames package))) - (new-names (subst new old old-names :test 'equal)) - (new-name (car new-names)) - (new-nicknames (cdr new-names))) - (rename-package package new-name new-nicknames))) - (ensure-exists (name nicknames use) - (let* ((previous - (remove-duplicates - (remove-if - #'null - (mapcar #'find-package (cons name nicknames))) - :from-end t))) - (cond - (previous - (map () #'rename-away (cdr previous)) ;; packages with conflicting (nick)names - (let ((p (car previous))) ;; previous package with same name - (rename-package p name nicknames) - (ensure-use p use) - p)) - (t - (make-package name :nicknames nicknames :use use))))) - (find-sym (symbol package) - (find-symbol (string symbol) package)) - (remove-symbol (symbol package) - (let ((sym (find-sym symbol package))) - (when sym - (unexport sym package) - (unintern sym package)))) - (ensure-unintern (package symbols) - (dolist (sym symbols) (remove-symbol sym package))) - (ensure-shadow (package symbols) - (shadow symbols package)) - (ensure-use (package use) - (dolist (used (reverse use)) - (do-external-symbols (sym used) - (unless (eq sym (find-sym sym package)) - (remove-symbol sym package))) - (use-package used package))) - (ensure-fmakunbound (package symbols) - (loop :for name :in symbols - :for sym = (find-sym name package) - :when sym :do (fmakunbound sym))) - (ensure-export (package export) - (let ((syms (loop :for x :in export :collect - (intern (string x) package)))) - (do-external-symbols (sym package) - (unless (member sym syms) - (remove-symbol sym package))) - (dolist (sym syms) - (export sym package)))) - (ensure-package (name &key nicknames use unintern fmakunbound shadow export) - (let ((p (ensure-exists name nicknames use))) - (ensure-unintern p unintern) - (ensure-shadow p shadow) - (ensure-export p export) - (ensure-fmakunbound p fmakunbound) - p))) - (ensure-package - ':asdf-utilities - :nicknames '(#:asdf-extensions) - :use '(#:common-lisp) - :unintern '(#:split #:make-collector) - :export - '(#:absolute-pathname-p - #:aif - #:appendf - #:asdf-message - #:coerce-name - #:directory-pathname-p - #:ends-with - #:ensure-directory-pathname - #:getenv - #:get-uid - #:length=n-p - #:merge-pathnames* - #:pathname-directory-pathname - #:pathname-sans-name+type ;; deprecated. Use pathname-directory-pathname - #:read-file-forms - #:remove-keys - #:remove-keyword - #:resolve-symlinks - #:split-string - #:component-name-to-pathname-components - #:split-name-type - #:system-registered-p - #:truenamize - #:while-collecting)) - (ensure-package - ':asdf - :use '(:common-lisp :asdf-utilities) - :unintern `(#-ecl , at redefined-functions - #:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector) - :fmakunbound `(#+ecl , at redefined-functions - #:system-source-file - #:component-relative-pathname #:system-relative-pathname - #:process-source-registry - #:inherit-source-registry #:process-source-registry-directive) - :export - '(#:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies - - #:input-files #:output-files #:perform ; operation methods - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - - #:component-depends-on - - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - #:system-licence - #:system-source-file - #:system-source-directory - #:system-relative-pathname - #:map-systems - - #:operation-on-warnings - #:operation-on-failure - ;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*resolve-symlinks* - - #:asdf-version - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-name - #:error-pathname - #:load-system-definition-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-component-of-version - #:missing-dependency - #:missing-dependency-of-version - #:circular-dependency ; errors - #:duplicate-names - - #:try-recompiling - #:retry - #:accept ; restarts - #:coerce-entry-to-directory - #:remove-entry-from-registry - - #:initialize-output-translations - #:disable-output-translations - #:clear-output-translations - #:ensure-output-translations - #:apply-output-translations - #:compile-file-pathname* - #:enable-asdf-binary-locations-compatibility - - #:*default-source-registries* - #:initialize-source-registry - #:compute-source-registry - #:clear-source-registry - #:ensure-source-registry - #:process-source-registry)) - (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version)))))) - -(in-package #:asdf) + #:system-source-file #:operate #:find-component) + :unintern + (#:*asdf-revision* #:around #:asdf-method-combination + #:split #:make-collector) + :fmakunbound + (#:system-source-file + #:component-relative-pathname #:system-relative-pathname + #:process-source-registry + #:inherit-source-registry #:process-source-registry-directive) + :export + (#:defsystem #:oos #:operate #:find-system #:run-shell-command + #:system-definition-pathname #:find-component ; miscellaneous + #:compile-system #:load-system #:test-system + #:compile-op #:load-op #:load-source-op + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + #:version-satisfies + + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:module-components-by-name ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:map-systems + + #:operation-on-warnings + #:operation-on-failure + ;;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*asdf-verbose* + + #:asdf-version + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names + + #:try-recompiling + #:retry + #:accept ; restarts + #:coerce-entry-to-directory + #:remove-entry-from-registry + + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file-pathname* + #:enable-asdf-binary-locations-compatibility + + #:*default-source-registries* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry))) + (let* ((version (intern* vername :asdf)) + (upvar (intern* '#:*upgraded-p* :asdf)) + (upval0 (and (boundp upvar) (symbol-value upvar))) + (upval1 (if existing-version (cons existing-version upval0) upval0))) + (eval `(progn + (defparameter ,version ,asdf-version) + (defparameter ,upvar ',upval1)))))))) + +(in-package :asdf) + +;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 +#+gcl +(eval-when (:compile-toplevel :load-toplevel) + (defvar *asdf-version* nil) + (defvar *upgraded-p* nil)) +(when *upgraded-p* + #+ecl + (when (find-class 'compile-op nil) + (defmethod update-instance-for-redefined-class :after + ((c compile-op) added deleted plist &key) + (declare (ignore added deleted)) + (let ((system-p (getf plist 'system-p))) + (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) + (when (find-class 'module nil) + (eval + '(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when (member 'components-by-name added) + (compute-module-components-by-name m)))))) ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters @@ -275,7 +336,7 @@ (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.661\")." +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"1.704\")." *asdf-version*) (defvar *resolve-symlinks* t @@ -289,6 +350,8 @@ (defvar *verbose-out* nil) +(defvar *asdf-verbose* t) + (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) @@ -301,21 +364,6 @@ (setf excl:*warn-on-nested-reader-conditionals* nil))) ;;;; ------------------------------------------------------------------------- -;;;; Cleanups before hot-upgrade. -;;;; Things to do in case we're upgrading from a previous version of ASDF. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS -;;;; for each of the classes we define that has changed incompatibly. -(eval-when (:compile-toplevel :load-toplevel :execute) - #+ecl - (when (find-class 'compile-op nil) - (defmethod update-instance-for-redefined-class :after - ((c compile-op) added deleted plist &key) - (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist)) - (let ((system-p (getf plist 'system-p))) - (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))) - -;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. (defgeneric perform-with-restarts (operation component)) @@ -324,6 +372,7 @@ (defgeneric explain (operation component)) (defgeneric output-files (operation component)) (defgeneric input-files (operation component)) +(defgeneric component-operation-time (operation component)) (defgeneric system-source-file (system) (:documentation "Return the source file in which system is defined.")) @@ -347,10 +396,9 @@ (defgeneric version-satisfies (component version)) -(defgeneric find-component (module name &optional version) - (:documentation "Finds the component with name NAME present in the -MODULE module; if MODULE is nil, then the component is assumed to be a -system.")) +(defgeneric find-component (base path) + (:documentation "Finds the component with PATH starting from BASE module; +if BASE is nil, then the component is assumed to be a system.")) (defgeneric source-file-type (component system)) @@ -365,7 +413,7 @@ This value stored will be a cons cell, the first element of which is a computed key, so not interesting. The CDR wil be the DATA value stored by VISIT-COMPONENT; recover -it as \(cdr \(component-visited-p op c\)\). +it as (cdr (component-visited-p op c)). In the current form of ASDF, the DATA value retrieved is effectively a boolean, indicating whether some operations are to be performed in order to do OPERATION X COMPONENT. If the @@ -421,21 +469,13 @@ (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) - (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) , at body - (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars)))))) + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) -(defun pathname-sans-name+type (pathname) - "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, -and NIL NAME and TYPE components. -Issue: doesn't override the VERSION component. - -Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead." - (make-pathname :name nil :type nil :defaults pathname)) - (defun pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" @@ -462,7 +502,7 @@ (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) - (ecase (first directory) + (#-gcl ecase #+gcl case (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) @@ -476,7 +516,16 @@ ((:relative) (values (pathname-host defaults) (pathname-device defaults) - (append (pathname-directory defaults) (cdr directory)) + (if (null (pathname-directory defaults)) + directory + (append (pathname-directory defaults) (cdr directory))) + (unspecific-handler defaults))) + #+gcl + (t + (assert (stringp (first directory))) + (values (pathname-host defaults) + (pathname-device defaults) + (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) @@ -484,7 +533,10 @@ :version (funcall unspecific-handler version)))))) (define-modify-macro appendf (&rest args) - append "Append onto list") + append "Append onto list") ;; only to be used on short lists. + +(define-modify-macro orf (&rest args) + or "or a flag") (defun asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) @@ -515,7 +567,7 @@ ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; We only use it on implementations that support it. - (or #+(or sbcl ccl ecl lispworks) :unspecific))) + (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") @@ -649,7 +701,7 @@ :until (eq form eof) :collect form))) -#-windows +#-(and (or win32 windows mswindows mingw32) (not cygwin)) (progn #+clisp (defun get-uid () (posix:uid)) #+sbcl (defun get-uid () (sb-unix:unix-getuid)) @@ -660,8 +712,8 @@ #-(or cmu sbcl clisp allegro ecl) (defun get-uid () (let ((uid-string - (with-output-to-string (asdf::*VERBOSE-OUT*) - (asdf:run-shell-command "id -ur")))) + (with-output-to-string (*verbose-out*) + (run-shell-command "id -ur")))) (with-input-from-string (stream uid-string) (read-line stream) (handler-case (parse-integer (read-line stream)) @@ -687,28 +739,26 @@ (return p)) (let ((sofar (ignore-errors (truename (pathname-root p))))) (unless sofar (return p)) - (loop :for component :in (cdr directory) - :for rest :on (cdr directory) - :for more = (ignore-errors - (truename - (merge-pathnames* - (make-pathname :directory `(:relative ,component)) - sofar))) :do - (if more - (setf sofar more) - (return - (merge-pathnames* - (make-pathname :host nil :device nil - :directory `(:relative , at rest) - :defaults p) - sofar))) - :finally - (return - (merge-pathnames* - (make-pathname :host nil :device nil - :directory nil - :defaults p) - sofar))))))) + (flet ((solution (directories) + (merge-pathnames* + (make-pathname :host nil :device nil + :directory `(:relative , at directories) + :name (pathname-name p) + :type (pathname-type p) + :version (pathname-version p)) + sofar))) + (loop :for component :in (cdr directory) + :for rest :on (cdr directory) + :for more = (ignore-errors + (truename + (merge-pathnames* + (make-pathname :directory `(:relative ,component)) + sofar))) :do + (if more + (setf sofar more) + (return (solution rest))) + :finally + (return (solution nil)))))))) (defun lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) @@ -778,7 +828,9 @@ (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to :accessor component-in-order-to) - ;; XXX crap name + ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? + (load-dependencies :accessor component-load-dependencies :initform nil) + ;; XXX crap name, but it's an official API name! (do-first :initform nil :initarg :do-first :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: @@ -797,6 +849,16 @@ (properties :accessor component-properties :initarg :properties :initform nil))) +(defun component-find-path (component) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + +(defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) + + ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) @@ -829,20 +891,38 @@ (component-system it) component)) -(defmethod print-object ((c component) stream) - (print-unreadable-object (c stream :type t :identity t) - (ignore-errors - (prin1 (component-name c) stream)))) +(defvar *default-component-class* 'cl-source-file) + +(defun compute-module-components-by-name (module) + (let ((hash (module-components-by-name module))) + (clrhash hash) + (loop :for c :in (module-components module) + :for name = (component-name c) + :for previous = (gethash name (module-components-by-name module)) + :do + (when previous + (error 'duplicate-names :name name)) + :do (setf (gethash name (module-components-by-name module)) c)) + hash)) (defclass module (component) - ((components :initform nil :accessor module-components :initarg :components) - ;; what to do if we can't satisfy a dependency of one of this module's - ;; components. This allows a limited form of conditional processing - (if-component-dep-fails :initform :fail - :accessor module-if-component-dep-fails - :initarg :if-component-dep-fails) - (default-component-class :accessor module-default-component-class - :initform 'cl-source-file :initarg :default-component-class))) + ((components + :initform nil + :initarg :components + :accessor module-components) + (components-by-name + :initform (make-hash-table :test 'equal) + :accessor module-components-by-name) + ;; What to do if we can't satisfy a dependency of one of this module's + ;; components. This allows a limited form of conditional processing. + (if-component-dep-fails + :initform :fail + :initarg :if-component-dep-fails + :accessor module-if-component-dep-fails) + (default-component-class + :initform *default-component-class* + :initarg :default-component-class + :accessor module-default-component-class))) (defun component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). @@ -984,21 +1064,9 @@ (let ((defaults (eval dir))) (when defaults (cond ((directory-pathname-p defaults) - (let ((file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local))) - #+(and (or win32 windows) (not :clisp)) - (shortcut (make-pathname - :defaults defaults :version :newest - :name name :type "asd.lnk" :case :local))) - (if (and file (probe-file file)) - (return file)) - #+(and (or win32 windows) (not :clisp)) - (when (probe-file shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target))))))) + (let ((file (probe-asd name defaults))) + (when file + (return file)))) (t (restart-case (let* ((*print-circle* nil) @@ -1031,22 +1099,26 @@ (defun make-temporary-package () (flet ((try (counter) (ignore-errors - (make-package (format nil "~a~D" 'asdf counter) + (make-package (format nil "~A~D" :asdf counter) :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) (defun safe-file-write-date (pathname) - ;; if FILE-WRITE-DATE returns NIL, it's possible that the - ;; user or some other agent has deleted an input file. If - ;; that's the case, well, that's not good, but as long as - ;; the operation is otherwise considered to be done we - ;; could continue and survive. - (or (and pathname (file-write-date pathname)) + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls operation-done-p which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (or (and pathname (probe-file pathname) (file-write-date pathname)) (progn - (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." - pathname) + (when pathname + (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." + pathname)) 0))) (defun find-system (name &optional (error-p t)) @@ -1066,10 +1138,7 @@ (let ((*package* package)) (asdf-message "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. - on-disk - *package*) + on-disk *package*) (load on-disk))) (delete-package package)))) (let ((in-memory (system-registered-p name))) @@ -1088,18 +1157,31 @@ ;;;; ------------------------------------------------------------------------- ;;;; Finding components -(defmethod find-component ((module module) name &optional version) - (if (slot-boundp module 'components) - (let ((m (find name (module-components module) - :test #'equal :key #'component-name))) - (if (and m (version-satisfies m version)) m)))) +(defmethod find-component ((base string) path) + (let ((s (find-system base nil))) + (and s (find-component s path)))) +(defmethod find-component ((base symbol) path) + (cond + (base (find-component (coerce-name base) path)) + (path (find-component path nil)) + (t nil))) + +(defmethod find-component ((base cons) path) + (find-component (car base) (cons (cdr base) path))) + +(defmethod find-component ((module module) (name string)) + (when (slot-boundp module 'components-by-name) + (values (gethash name (module-components-by-name module))))) + +(defmethod find-component ((component component) (name symbol)) + (if name + (find-component component (coerce-name name)) + component)) + +(defmethod find-component ((module module) (name cons)) + (find-component (find-component module (car name)) (cdr name))) -;;; a component with no parent is a system -(defmethod find-component ((module (eql nil)) name &optional version) - (declare (ignorable module)) - (let ((m (find-system name nil))) - (if (and m (version-satisfies m version)) m))) ;;; component subclasses @@ -1117,8 +1199,11 @@ (defclass html-file (doc-file) ((type :initform "html"))) -(defmethod source-file-type ((component module) (s module)) :directory) +(defmethod source-file-type ((component module) (s module)) + (declare (ignorable component s)) + :directory) (defmethod source-file-type ((component source-file) (s module)) + (declare (ignorable s)) (source-file-explicit-type component)) (defun merge-component-name-type (name &key type defaults) @@ -1166,14 +1251,19 @@ (defclass operation () ( - ;; what is the TYPE of this slot? seems like it should be boolean, - ;; but TRAVERSE checks to see if it's a list of component names... - ;; [2010/02/07:rpg] + ;; as of danb's 2003-03-16 commit e0d02781, :force can be: + ;; T to force the inside of existing system, + ;; but not recurse to other systems we depend on. + ;; :ALL (or any other atom) to force all systems + ;; including other systems we depend on. + ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) + ;; to force systems named in a given list + ;; (but this feature never worked before ASDF 1.700 and is cerror'ed out.) (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) - (visited-nodes :initform nil :accessor operation-visited-nodes) - (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) + (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) @@ -1222,13 +1312,13 @@ (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) - (push (cons (node-for o c) data) - (operation-visited-nodes (operation-ancestor o))))) + (setf (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o))) + (cons t data)))) (defmethod component-visited-p ((o operation) (c component)) - (assoc (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) + (gethash (node-for o c) + (operation-visited-nodes (operation-ancestor o)))) (defmethod (setf visiting-component) (new-value operation component) ;; MCL complains about unused lexical variables @@ -1239,15 +1329,13 @@ (let ((node (node-for o c)) (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal)))) - new-value) + (setf (gethash node (operation-visiting-nodes a)) t) + (remhash node (operation-visiting-nodes a))) + new-value)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (node-for o c))) - (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + (gethash node (operation-visiting-nodes (operation-ancestor o))))) (defmethod component-depends-on ((op-spec symbol) (c component)) (component-depends-on (make-instance op-spec) c)) @@ -1275,12 +1363,17 @@ ;; original source file, then (list (component-pathname c))))) -(defmethod input-files ((operation operation) (c module)) nil) +(defmethod input-files ((operation operation) (c module)) + (declare (ignorable operation c)) + nil) + +(defmethod component-operation-time (o c) + (gethash (type-of o) (component-operation-times c))) (defmethod operation-done-p ((o operation) (c component)) (let ((out-files (output-files o c)) (in-files (input-files o c)) - (op-time (gethash (type-of o) (component-operation-times c)))) + (op-time (component-operation-time o c))) (flet ((earliest-out () (reduce #'min (mapcar #'safe-file-write-date out-files))) (latest-in () @@ -1323,183 +1416,220 @@ (>= (earliest-out) (latest-in)))))))) -;;; So you look at this code and think "why isn't it a bunch of -;;; methods". And the answer is, because standard method combination -;;; runs :before methods most->least-specific, which is back to front -;;; for our purposes. + +;;; For 1.700 I've done my best to refactor TRAVERSE +;;; by splitting it up in a bunch of functions, +;;; so as to improve the collection and use-detection algorithm. --fare +;;; The protocol is as follows: we pass around operation, dependency, +;;; bunch of other stuff, and a force argument. Return a force flag. +;;; The returned flag is T if anything has changed that requires a rebuild. +;;; The force argument is a list of components that will require a rebuild +;;; if the flag is T, at which point whoever returns the flag has to +;;; mark them all as forced, and whoever recurses again can use a NIL list +;;; as a further argument. (defvar *forcing* nil "This dynamically-bound variable is used to force operations in recursive calls to traverse.") -(defmethod traverse ((operation operation) (c component)) - (let ((forced nil)) ;return value -- everyone side-effects onto this - (labels ((%do-one-dep (required-op required-c required-v) - ;; returns a partial plan that results from performing required-op - ;; on required-c, possibly with a required-vERSION - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (if required-v - (error 'missing-dependency-of-version - :required-by c - :version required-v - :requires required-c) - (error 'missing-dependency - :required-by c - :requires required-c)))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) - (do-one-dep (required-op required-c required-v) - ;; this function is a thin, error-handling wrapper around - ;; %do-one-dep. Returns a partial plan per that function. - (loop - (restart-case - (return (%do-one-dep required-op required-c required-v)) - (retry () - :report (lambda (s) - (format s "~@" - required-c)) - :test - (lambda (c) -#| - (print (list :c1 c (typep c 'missing-dependency))) - (when (typep c 'missing-dependency) - (print (list :c2 (missing-requires c) required-c - (equalp (missing-requires c) - required-c)))) -|# - (or (null c) - (and (typep c 'missing-dependency) - (equalp (missing-requires c) - required-c)))))))) - (do-dep (op dep) - ;; type of arguments uncertain: op seems to at least potentially be a - ;; symbol, rather than an operation - ;; dep is either a list of component names (?) or (we hope) a single - ;; component name. - ;; handle a single dependency, returns nothing of interest --- side- - ;; effects onto the FORCED variable, which is scoped over TRAVERSE - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency - :required-by c - :requires (car dep)))) - (t - (dolist (d dep) - ;; structured dependencies --- this parses keywords - ;; the keywords could be broken out and cleanly (extensibly) - ;; processed by EQL methods, but for the pervasive side-effecting - ;; onto FORCED - (cond ((consp d) - (cond ((string-equal - (symbol-name (first d)) - "VERSION") - ;; https://bugs.launchpad.net/asdf/+bug/527788 - (appendf - forced - (do-one-dep op (second d) (third d)))) - ;; this particular subform is not documented, indeed - ;; clashes with the documentation, since it assumes a - ;; third component. - ;; See https://bugs.launchpad.net/asdf/+bug/518467 - ((and (string-equal - (symbol-name (first d)) - "FEATURE") - (find (second d) *features* - :test 'string-equal)) - (appendf - forced - (do-one-dep op (third d) nil))) - (t - (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))) - (t - (appendf forced (do-one-dep op d nil))))))))) +(defgeneric do-traverse (operation component collect)) + +(defun %do-one-dep (operation c collect required-op required-c required-v) + ;; collects a partial plan that results from performing required-op + ;; on required-c, possibly with a required-vERSION + (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) + (and d (version-satisfies d required-v) d)) + (if required-v + (error 'missing-dependency-of-version + :required-by c + :version required-v + :requires required-c) + (error 'missing-dependency + :required-by c + :requires required-c)))) + (op (make-sub-operation c operation dep-c required-op))) + (do-traverse op dep-c collect))) + +(defun do-one-dep (operation c collect required-op required-c required-v) + ;; this function is a thin, error-handling wrapper around + ;; %do-one-dep. Returns a partial plan per that function. + (loop + (restart-case + (return (%do-one-dep operation c collect + required-op required-c required-v)) + (retry () + :report (lambda (s) + (format s "~@" + required-c)) + :test + (lambda (c) + #| + (print (list :c1 c (typep c 'missing-dependency))) + (when (typep c 'missing-dependency) + (print (list :c2 (missing-requires c) required-c + (equalp (missing-requires c) + required-c)))) + |# + (or (null c) + (and (typep c 'missing-dependency) + (equalp (missing-requires c) + required-c)))))))) + +(defun do-dep (operation c collect op dep) + ;; type of arguments uncertain: + ;; op seems to at least potentially be a symbol, rather than an operation + ;; dep is a list of component names + (cond ((eq op 'feature) + (if (member (car dep) *features*) + nil + (error 'missing-dependency + :required-by c + :requires (car dep)))) + (t + (let ((flag nil)) + (flet ((dep (op comp ver) + (when (do-one-dep operation c collect + op comp ver) + (setf flag t)))) + (dolist (d dep) + (if (atom d) + (dep op d nil) + ;; structured dependencies --- this parses keywords + ;; the keywords could be broken out and cleanly (extensibly) + ;; processed by EQL methods + (cond ((eq :version (first d)) + ;; https://bugs.launchpad.net/asdf/+bug/527788 + (dep op (second d) (third d))) + ;; This particular subform is not documented and + ;; has always been broken in the past. + ;; Therefore no one uses it, and I'm cerroring it out, + ;; after fixing it + ;; See https://bugs.launchpad.net/asdf/+bug/518467 + ((eq :feature (first d)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") + (when (find (second d) *features* :test 'string-equal) + (dep op (third d) nil))) + (t + (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) + flag)))) + +(defun do-collect (collect x) + (funcall collect x)) + +(defmethod do-traverse ((operation operation) (c component) collect) + (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? + (labels + ((update-flag (x) + (when x + (setf flag t))) + (dep (op comp) + (update-flag (do-dep operation c collect op comp)))) + ;; Have we been visited yet? If so, just process the result. (aif (component-visited-p operation c) - (return-from traverse - (if (cdr it) (list (cons 'pruned-op c)) nil))) + (progn + (update-flag (cdr it)) + (return-from do-traverse flag))) ;; dependencies - (if (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) + (when (component-visiting-p operation c) + (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (unwind-protect - (progn - ;; first we check and do all the dependencies for the - ;; module. Operations planned in this loop will show up - ;; in the contents of the FORCED variable, and are consumed - ;; downstream (watch out for the shadowing FORCED variable - ;; around the DOLIST below!) - (let ((*forcing* nil)) - ;; upstream dependencies are never forced to happen just because - ;; the things that depend on them are.... - (loop :for (required-op . deps) :in - (component-depends-on operation c) - :do (do-dep required-op deps))) - ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - ;; this is set based on the results of the - ;; dependencies and whether we are in the - ;; context of a *forcing* call... - (must-operate (or *forcing* - ;; inter-system dependencies do NOT trigger - ;; building components - (and - (not (typep c 'system)) - forced))) - (error nil)) - (dolist (kid (module-components c)) - (handler-case - (let ((*forcing* must-operate)) - (appendf forced (traverse operation kid))) - (missing-dependency (condition) - (when (eq (module-if-component-dep-fails c) - :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) - :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - ;; the test here is a bit oddly written. FORCED here doesn't - ;; mean that this operation is forced on this component, but that - ;; something upstream of this component has been forced. - (when (or forced module-ops - *forcing* - (not (operation-done-p operation c)) - (let ((f (operation-forced - (operation-ancestor operation)))) - ;; does anyone fully understand the following condition? - ;; if so, please add a comment to explain it... - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - ;; this was string=, but for the benefit - ;; of mlisp, we use string-equal for this - ;; purpose. - :test #'string-equal))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (component-do-first c))))) - (loop :for (required-op . deps) :in do-first - :do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c))))))) - (setf (visiting-component operation c) nil)) - (visit-component operation c (and forced t)) - forced))) + (progn + ;; first we check and do all the dependencies for the module. + ;; Operations planned in this loop will show up + ;; in the results, and are consumed below. + (let ((*forcing* nil)) + ;; upstream dependencies are never forced to happen just because + ;; the things that depend on them are.... + (loop + :for (required-op . deps) :in (component-depends-on operation c) + :do (dep required-op deps))) + ;; constituent bits + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + ;; This is set based on the results of the + ;; dependencies and whether we are in the + ;; context of a *forcing* call... + ;; inter-system dependencies do NOT trigger + ;; building components + (*forcing* + (or *forcing* + (and flag (not (typep c 'system))))) + (error nil)) + (while-collecting (internal-collect) + (dolist (kid (module-components c)) + (handler-case + (update-flag + (do-traverse operation kid #'internal-collect)) + (missing-dependency (condition) + (when (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error))))))) + (update-flag + (or + *forcing* + (not (operation-done-p operation c)) + ;; For sub-operations, check whether + ;; the original ancestor operation was forced, + ;; or names us amongst an explicit list of things to force... + ;; except that this check doesn't distinguish + ;; between all the things with a given name. Sigh. + ;; BROKEN! + (let ((f (operation-forced + (operation-ancestor operation)))) + (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=))))))) + (when flag + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (component-do-first c))))) + (loop :for (required-op . deps) :in do-first + :do (do-dep operation c collect required-op deps))) + (do-collect collect (vector module-ops)) + (do-collect collect (cons operation c))))) + (setf (visiting-component operation c) nil))) + (visit-component operation c flag) + flag)) +(defmethod traverse ((operation operation) (c component)) + ;; cerror'ing a feature that seems to have NEVER EVER worked + ;; ever since danb created it in his 2003-03-16 commit e0d02781. + ;; It was both fixed and disabled in the 1.700 rewrite. + (when (consp (operation-forced operation)) + (cerror "Continue nonetheless." + "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") + (setf (operation-forced operation) + (mapcar #'coerce-name (operation-forced operation)))) + (flatten-tree + (while-collecting (collect) + (do-traverse operation c #'collect)))) + +(defun flatten-tree (l) + ;; You collected things into a list. + ;; Most elements are just things to collect again. + ;; A (simple-vector 1) indicate that you should recurse into its contents. + ;; This way, in two passes (rather than N being the depth of the tree), + ;; you can collect things with marginally constant-time append, + ;; achieving linear time collection instead of quadratic time. + (while-collecting (c) + (labels ((r (x) + (if (typep x '(simple-vector 1)) + (r* (svref x 0)) + (c x))) + (r* (l) + (dolist (x l) (r x)))) + (r* l)))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error @@ -1508,6 +1638,7 @@ (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) + (declare (ignorable operation c)) nil) (defmethod explain ((operation operation) (component component)) @@ -1532,9 +1663,10 @@ (defmethod perform :after ((o compile-op) (c cl-source-file)) ;; Note how we use OUTPUT-FILES to find the binary locations ;; This allows the user to override the names. - (let* ((input (output-files o c)) - (output (compile-file-pathname (lispize-pathname (first input)) :type :fasl))) - (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=)))) + (let* ((files (output-files o c)) + (object (first files)) + (fasl (second files))) + (c:build-fasl fasl :lisp-files (list object)))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) @@ -1567,20 +1699,23 @@ (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) + (declare (ignorable operation)) (let ((p (lispize-pathname (component-pathname c)))) #-:broken-fasl-loader - (list #-ecl (compile-file-pathname p) - #+ecl (compile-file-pathname p :type :object) + (list (compile-file-pathname p #+ecl :type #+ecl :object) #+ecl (compile-file-pathname p :type :fasl)) #+:broken-fasl-loader (list p))) (defmethod perform ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) -(defmethod input-files ((op compile-op) (c static-file)) +(defmethod input-files ((operation compile-op) (c static-file)) + (declare (ignorable operation c)) nil) @@ -1602,35 +1737,60 @@ (perform operation component)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) - (let ((state :initial)) - (loop :until (or (eq state :success) - (eq state :failure)) :do - (case state - (:recompiled - (setf state :failure) - (call-next-method) - (setf state :success)) - (:failed-load - (setf state :recompiled) - (perform (make-instance 'compile-op) c)) - (t - (with-simple-restart - (try-recompiling "Recompile ~a and try loading it again" - (component-name c)) - (setf state :failed-load) - (call-next-method) - (setf state :success))))))) + (declare (ignorable o)) + (loop :with state = :initial + :until (or (eq state :success) + (eq state :failure)) :do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-load + (setf state :recompiled) + (perform (make-instance 'compile-op) c)) + (t + (with-simple-restart + (try-recompiling "Recompile ~a and try loading it again" + (component-name c)) + (setf state :failed-load) + (call-next-method) + (setf state :success)))))) + +(defmethod perform-with-restarts ((o compile-op) (c cl-source-file)) + (loop :with state = :initial + :until (or (eq state :success) + (eq state :failure)) :do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-compile + (setf state :recompiled) + (perform-with-restarts o c)) + (t + (with-simple-restart + (try-recompiling "Try recompiling ~a" + (component-name c)) + (setf state :failed-compile) + (call-next-method) + (setf state :success)))))) (defmethod perform ((operation load-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod operation-done-p ((operation load-op) (c static-file)) + (declare (ignorable operation c)) t) -(defmethod output-files ((o operation) (c component)) +(defmethod output-files ((operation operation) (c component)) + (declare (ignorable operation c)) nil) (defmethod component-depends-on ((operation load-op) (c component)) + (declare (ignorable operation)) (cons (list 'compile-op (component-name c)) (call-next-method))) @@ -1640,19 +1800,23 @@ (defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) + (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) (and (load source) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) + (declare (ignorable operation c)) nil) (defmethod output-files ((operation load-source-op) (c component)) + (declare (ignorable operation c)) nil) ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) + (declare (ignorable o)) (let ((what-would-load-op-do (cdr (assoc 'load-op (component-in-order-to c))))) (mapcar (lambda (dep) @@ -1662,6 +1826,7 @@ what-would-load-op-do))) (defmethod operation-done-p ((o load-source-op) (c source-file)) + (declare (ignorable o)) (if (or (not (component-property c 'last-loaded-as-source)) (> (safe-file-write-date (component-pathname c)) (component-property c 'last-loaded-as-source))) @@ -1674,28 +1839,34 @@ (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) + (declare (ignorable operation c)) nil) (defmethod operation-done-p ((operation test-op) (c system)) "Testing a system is _never_ done." + (declare (ignorable operation c)) nil) (defmethod component-depends-on :around ((o test-op) (c system)) + (declare (ignorable o)) (cons `(load-op ,(component-name c)) (call-next-method))) ;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations -(defun operate (operation-class system &rest args &key (verbose t) version force - &allow-other-keys) +(defgeneric operate (operation-class system &key &allow-other-keys)) + +(defmethod operate (operation-class system &rest args + &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force + &allow-other-keys) (declare (ignore force)) (let* ((*package* *package*) (*readtable* *readtable*) (op (apply #'make-instance operation-class :original-initargs args args)) - (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) (system (if (typep system 'component) system (find-system system)))) (unless (version-satisfies system version) (error 'missing-component-of-version :requires system :version version)) @@ -1704,8 +1875,9 @@ (loop :for (op . component) :in steps :do (loop (restart-case - (progn (perform-with-restarts op component) - (return)) + (progn + (perform-with-restarts op component) + (return)) (retry () :report (lambda (s) @@ -1723,7 +1895,7 @@ (return))))))) op)) -(defun oos (operation-class system &rest args &key force (verbose t) version +(defun oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) (apply #'operate operation-class system args)) @@ -1753,21 +1925,21 @@ (setf (documentation 'operate 'function) operate-docstring)) -(defun load-system (system &rest args &key force (verbose t) version +(defun load-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'load-op system args)) -(defun compile-system (system &rest args &key force (verbose t) version +(defun compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'compile-op system args)) -(defun test-system (system &rest args &key force (verbose t) version +(defun test-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." @@ -1800,13 +1972,15 @@ (defmacro defsystem (name &body options) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) - &allow-other-keys) + defsystem-depends-on &allow-other-keys) options - (let ((component-options (remove-keyword :class options))) + (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from + ,@(loop :for system :in defsystem-depends-on + :collect `(load-system ,system)) (let ((s (system-registered-p ',name))) (cond ((and s (eq (type-of (cdr s)) ',class)) (setf (car s) (get-universal-time))) @@ -1818,8 +1992,7 @@ (%set-system-source-file *load-truename* (cdr (system-registered-p ',name)))) (parse-component-form - nil (apply - #'list + nil (list* :module (coerce-name ',name) :pathname ,(determine-system-pathname pathname pathname-arg-p) @@ -1870,11 +2043,11 @@ new-tree)) -(defvar *serial-depends-on*) +(defvar *serial-depends-on* nil) (defun sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") + "~&The value specified for ~(~A~) ~A is ~S") type name value)) (defun check-component-input (type name weakly-depends-on @@ -1924,7 +2097,6 @@ (%define-component-inline-methods component rest)) (defun parse-component-form (parent options) - (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the @@ -1956,10 +2128,9 @@ (or (find-component parent name) (make-instance (class-for-type parent type))))) (when weakly-depends-on - (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) - (when (boundp '*serial-depends-on*) - (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) + (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) + (when *serial-depends-on* + (push *serial-depends-on* depends-on)) (apply #'reinitialize-instance ret :name (coerce-name name) :pathname pathname @@ -1973,28 +2144,22 @@ (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) - (loop :for c-form :in components + (loop + :for c-form :in components :for c = (parse-component-form ret c-form) + :for name = (component-name c) :collect c - :if serial - :do (push (component-name c) *serial-depends-on*)))) + :when serial :do (setf *serial-depends-on* name)))) + (compute-module-components-by-name ret)) - ;; check for duplicate names - (let ((name-hash (make-hash-table :test #'equal))) - (loop :for c in (module-components ret) :do - (if (gethash (component-name c) - name-hash) - (error 'duplicate-names :name (component-name c)) - (setf (gethash (component-name c) - name-hash) - t))))) + (setf (component-load-dependencies ret) depends-on) ;; Used by POIU (setf (component-in-order-to ret) (union-of-dependencies in-order-to `((compile-op (compile-op , at depends-on)) - (load-op (load-op , at depends-on)))) - (component-do-first ret) `((compile-op (load-op , at depends-on)))) + (load-op (load-op , at depends-on))))) + (setf (component-do-first ret) `((compile-op (load-op , at depends-on)))) (%refresh-component-inline-methods ret rest) ret))) @@ -2018,20 +2183,9 @@ output to `*verbose-out*`. Returns the shell's exit code." (let ((command (apply #'format nil control-string args))) (asdf-message "; $ ~A~%" command) - #+sbcl - (sb-ext:process-exit-code - (apply #'sb-ext:run-program - #+win32 "sh" #-win32 "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out* - #+win32 '(:search t) #-win32 nil)) - #+(or cmu scl) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) + #+abcl + (ext:run-shell-command command :output *verbose-out*) #+allegro ;; will this fail if command has embedded quotes - it seems to work @@ -2045,18 +2199,10 @@ (format *verbose-out* "~{~&; ~a~%~}~%" stdout) exit-code) - #+lispworks - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :show-cmd nil - :prefix "" - :output-stream *verbose-out*) - #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) - #+openmcl + #+clozure (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) @@ -2066,12 +2212,34 @@ #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) - #+abcl - (ext:run-shell-command command :output *verbose-out*) + #+gcl + (lisp:system command) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :show-cmd nil + :prefix "" + :output-stream *verbose-out*) - #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl abcl) - (error "RUN-SHELL-COMMAND not implemented for this Lisp") - )) + #+sbcl + (sb-ext:process-exit-code + (apply #'sb-ext:run-program + #+win32 "sh" #-win32 "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out* + #+win32 '(:search t) #-win32 nil)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) + (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) ;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname @@ -2090,9 +2258,13 @@ :defaults (system-source-file system-designator))) (defun relativize-directory (directory) - (if (eq (car directory) :absolute) - (cons :relative (cdr directory)) - directory)) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory))) (defun relativize-pathname-directory (pathspec) (let ((p (pathname pathspec))) @@ -2119,27 +2291,20 @@ (defparameter *os-features* '((:windows :mswindows :win32 :mingw32) (:solaris :sunos) + :linux ;; for GCL at least, must appear before :bsd. :macosx :darwin :apple :freebsd :netbsd :openbsd :bsd - :linux :unix)) + :unix)) (defparameter *architecture-features* '((:x86-64 :amd64 :x86_64 :x8664-target) (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) - :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc)) + :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) (defun lisp-version-string () (let ((s (lisp-implementation-version))) (declare (ignorable s)) - #+(or scl sbcl ecl armedbear cormanlisp mcl) s - #+cmu (substitute #\- #\/ s) - #+clozure (format nil "~d.~d~@[-~d~]" - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - #+ppc64-target 64 - #-ppc64-target nil) - #+lispworks (format nil "~A~@[~A~]" s - (when (member :lispworks-64bit *features*) "-64bit")) #+allegro (format nil "~A~A~A~A" excl::*common-lisp-version-number* @@ -2152,8 +2317,25 @@ (:-ics "8") (:+ics "")) (if (member :64bit *features*) "-64bit" "")) - #+(or clisp gcl) (subseq s 0 (position #\space s)) - #+digitool (subseq s 8))) + #+clisp (subseq s 0 (position #\space s)) + #+clozure (format nil "~d.~d-fasl~d" + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) + #+cmu (substitute #\- #\/ s) + #+digitool (subseq s 8) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))) + #+gcl (subseq s (1+ (position #\space s))) + #+lispworks (format nil "~A~@[~A~]" s + (when (member :lispworks-64bit *features*) "-64bit")) + ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; fasl-f-v is redundant + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+(or mcl sbcl scl) s + #-(or allegro armedbear clisp clozure cmu cormanlisp digitool + ecl gcl lispworks mcl sbcl scl) s)) (defun first-feature (features) (labels @@ -2221,28 +2403,25 @@ ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") :for dir :in (split-string dirs :separator ":") :collect (try dir "common-lisp/")) - #+windows + #+(and (or win32 windows mswindows mingw32) (not cygwin)) ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - #+(not cygwin) - ,(try (or (getenv "USERPROFILE") (user-homedir)) - "Application Data/common-lisp/config/")) + ,(try (getenv "APPDATA") "common-lisp/config/")) ,(try (user-homedir) ".config/common-lisp/"))))) (defun system-configuration-directories () (remove-if #'null (append - #+windows + #+(and (or win32 windows mswindows mingw32) (not cygwin)) (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) - `( - ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") + `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - #+(not cygwin) - ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) + ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) (list #p"/etc/")))) (defun in-first-directory (dirs x) (loop :for dir :in dirs - :thereis (and dir (ignore-errors (truename (merge-pathnames* x (ensure-directory-pathname dir))))))) + :thereis (and dir (ignore-errors + (truename (merge-pathnames* x (ensure-directory-pathname dir))))))) (defun in-user-configuration-directory (x) (in-first-directory (user-configuration-directories) x)) (defun in-system-configuration-directory (x) @@ -2299,27 +2478,16 @@ and the order is by decreasing length of namestring of the source pathname.") (defvar *user-cache* - (or - (let ((h (getenv "XDG_CACHE_HOME"))) - (and h `(,h "common-lisp" :implementation))) - #+(and windows lispworks) - (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows??? - (and h `(,h "common-lisp" "cache"))) - #+(and windows (not cygwin)) - ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache - (let ((h (or (getenv "USERPROFILE") (user-homedir)))) - (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp"))) - '(:home ".cache" "common-lisp" :implementation))) + (flet ((try (x &rest sub) (and x `(,x , at sub)))) + (or + (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + (try (getenv "APPDATA") "common-lisp" "cache" :implementation) + '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* - (or - #+(and windows lispworks) - (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows??? - (and h `(,h "common-lisp" "cache"))) - #+windows - (let ((h (or (getenv "USERPROFILE") (user-homedir)))) - (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp"))) - #+(or unix cygwin) - '("/var/cache/common-lisp" :uid :implementation))) + ;; No good default, plus there's a security problem + ;; with other users messing with such directories. + *user-cache*) (defun output-translations () (car *output-translations*)) @@ -2515,10 +2683,11 @@ #+sbcl (,(getenv "SBCL_HOME") ()) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*")) ;; All-import, here is where we want user stuff to be: :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) ;; If we want to enable the user cache by default, here would be the place: :enable-user-cache)) @@ -2706,15 +2875,16 @@ #+abcl (defun translate-jar-pathname (source wildcard) (declare (ignore wildcard)) - (let ((root (apply-output-translations - (concatenate 'string - "/:jar:file/" - (namestring (first (pathname-device - source)))))) - (entry (make-pathname :directory (pathname-directory source) - :name (pathname-name source) - :type (pathname-type source)))) - (concatenate 'string (namestring root) (namestring entry)))) + (let* ((p (pathname (first (pathname-device source)))) + (root (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device p))))) + (apply-output-translations + (merge-pathnames* + (relativize-pathname-directory source) + (merge-pathnames* + (relativize-pathname-directory (ensure-directory-pathname p)) + root))))) ;;;; ----------------------------------------------------------------- ;;;; Compatibility mode for ASDF-Binary-Locations @@ -2854,29 +3024,33 @@ (setf *source-registry* '()) (values)) +(defun probe-asd (name defaults) + (block nil + (when (directory-pathname-p defaults) + (let ((file + (make-pathname + :defaults defaults :version :newest :case :local + :name name + :type "asd"))) + (when (probe-file file) + (return file))) + #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) + (let ((shortcut + (make-pathname + :defaults defaults :version :newest :case :local + :name (concatenate 'string name ".asd") + :type "lnk"))) + (when (probe-file shortcut) + (let ((target (parse-windows-shortcut shortcut))) + (when target + (return (pathname target))))))))) + (defun sysdef-source-registry-search (system) (ensure-source-registry) - (let ((name (coerce-name system))) - (block nil - (dolist (dir (source-registry)) - (let ((defaults (eval dir))) - (when defaults - (cond ((directory-pathname-p defaults) - (let ((file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local))) - #+(and (or win32 windows) (not :clisp)) - (shortcut (make-pathname - :defaults defaults :version :newest - :name name :type "asd.lnk" :case :local))) - (when (and file (probe-file file)) - (return file)) - #+(and (or win32 windows) (not :clisp)) - (when (probe-file shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target)))))))))))))) + (loop :with name = (coerce-name system) + :for defaults :in (source-registry) + :for file = (probe-asd name defaults) + :when file :return file)) (defun validate-source-registry-directive (directive) (unless @@ -2941,10 +3115,15 @@ (defun register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (funcall collect directory) - (let* ((files (ignore-errors - (directory (merge-pathnames* *wild-asd* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+clisp #+clisp :circle t))) + (let* ((files + (handler-case + (directory (merge-pathnames* *wild-asd* directory) + #+sbcl #+sbcl :resolve-symlinks nil + #+clisp #+clisp :circle t) + (error (c) + (warn "Error while scanning system definitions under directory ~S:~%~A" + directory c) + nil))) (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) :test #'equal :from-end t))) (loop @@ -2981,17 +3160,14 @@ (datadirs (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) (dirs (cons datahome (split-string datadirs :separator ":")))) - #+(and windows (not cygwin)) - ((datahome - #+lispworks (sys:get-folder-path :common-appdata) - #-lispworks (try (or (getenv "USERPROFILE") (user-homedir)) - "Application Data")) + #+(and (or win32 windows mswindows mingw32) (not cygwin)) + ((datahome (getenv "APPDATA")) (datadir #+lispworks (sys:get-folder-path :local-appdata) #-lispworks (try (getenv "ALLUSERSPROFILE") "Application Data")) (dirs (list datahome datadir))) - #+(and (not unix) (not windows) (not cygwin)) + #-(or unix win32 windows mswindows mingw32 cygwin) ((dirs ())) (loop :for dir :in dirs :collect `(:directory ,(try dir "common-lisp/systems/")) @@ -3093,9 +3269,9 @@ (initialize-source-registry))) ;;;; ----------------------------------------------------------------- -;;;; SBCL and ClozureCL hook into REQUIRE +;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL ;;;; -#+(or sbcl clozure abcl) +#+(or abcl clozure cmu ecl sbcl) (progn (defun module-provide-asdf (name) (handler-bind @@ -3105,14 +3281,16 @@ (format *error-output* "ASDF could not load ~A because ~A.~%" name e)))) (let* ((*verbose-out* (make-broadcast-stream)) - (system (asdf:find-system name nil))) + (system (find-system name nil))) (when system - (asdf:operate 'asdf:load-op name) + (load-system name) t)))) (pushnew 'module-provide-asdf - #+sbcl sb-ext:*module-provider-functions* + #+abcl sys::*module-provider-functions* #+clozure ccl::*module-provider-functions* - #+abcl sys::*module-provider-functions*)) + #+cmu ext:*module-provider-functions* + #+ecl si:*module-provider-functions* + #+sbcl sb-ext:*module-provider-functions*)) ;;;; ------------------------------------------------------------------------- ;;;; Cleanups after hot-upgrade. Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/boot.lisp Thu May 13 17:15:07 2010 @@ -209,12 +209,4 @@ (%format t "Startup completed in ~A seconds.~%" (float (/ (ext:uptime) 1000))))) -;;; "system.lisp" contains system installation specific information -;;; (currently only the logical pathname definition for "SYS;SRC") -;;; that is not currently required for ABCL to run. Since -;;; LOAD-SYSTEM-FILE exits the JVM if its argument cannot be found, we -;;; use REQUIRE trapping any error. -(handler-case - (require 'system) - (t ())) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/clos.lisp Thu May 13 17:15:07 2010 @@ -53,6 +53,13 @@ (export '(class-precedence-list class-slots)) (defconstant +the-standard-class+ (find-class 'standard-class)) +(defconstant +the-standard-object-class+ (find-class 'standard-object)) +(defconstant +the-standard-method-class+ (find-class 'standard-method)) +(defconstant +the-standard-reader-method-class+ + (find-class 'standard-reader-method)) +(defconstant +the-standard-generic-function-class+ + (find-class 'standard-generic-function)) +(defconstant +the-T-class+ (find-class 'T)) ;; Don't use DEFVAR, because that disallows loading clos.lisp ;; after compiling it: the binding won't get assigned to T anymore @@ -556,7 +563,7 @@ direct-default-initargs &allow-other-keys) (let ((supers (or direct-superclasses - (list (find-class 'standard-object))))) + (list +the-standard-object-class+)))) (setf (class-direct-superclasses class) supers) (dolist (superclass supers) (pushnew class (class-direct-subclasses superclass)))) @@ -579,7 +586,9 @@ (defun canonical-slot-name (canonical-slot) (getf canonical-slot :name)) -(defvar *extensible-built-in-classes* (list (find-class 'sequence) (find-class 'java:java-object))) +(defvar *extensible-built-in-classes* + (list (find-class 'sequence) + (find-class 'java:java-object))) (defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) ;; Check for duplicate slots. @@ -740,8 +749,6 @@ (defun (setf classes-to-emf-table) (new-value gf) (set-generic-function-classes-to-emf-table gf new-value)) -(defvar the-class-standard-method (find-class 'standard-method)) - (defun (setf method-lambda-list) (new-value method) (set-method-lambda-list method new-value)) @@ -850,8 +857,8 @@ &rest all-keys &key lambda-list - (generic-function-class (find-class 'standard-generic-function)) - (method-class the-class-standard-method) + (generic-function-class +the-standard-generic-function-class+) + (method-class +the-standard-method-class+) (method-combination 'standard) (argument-precedence-order nil apo-p) documentation @@ -885,7 +892,7 @@ (error 'program-error :format-control "~A already names an ordinary function, macro, or special operator." :format-arguments (list function-name))) - (setf gf (apply (if (eq generic-function-class (find-class 'standard-generic-function)) + (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+) #'make-instance-standard-generic-function #'make-instance) generic-function-class @@ -898,7 +905,7 @@ (defun initial-discriminating-function (gf args) (set-funcallable-instance-function gf - (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-discriminating-function #'compute-discriminating-function) gf)) @@ -933,7 +940,7 @@ argument-precedence-order documentation) (declare (ignore generic-function-class)) - (let ((gf (std-allocate-instance (find-class 'standard-generic-function)))) + (let ((gf (std-allocate-instance +the-standard-generic-function-class+))) (%set-generic-function-name gf name) (setf (generic-function-lambda-list gf) lambda-list) (setf (generic-function-initial-methods gf) ()) @@ -1162,7 +1169,7 @@ (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf)) (setf gf (ensure-generic-function name :lambda-list method-lambda-list))) (let ((method - (if (eq (generic-function-method-class gf) the-class-standard-method) + (if (eq (generic-function-method-class gf) +the-standard-method-class+) (apply #'make-instance-standard-method gf all-keys) (apply #'make-instance (generic-function-method-class gf) all-keys)))) (%add-method gf method) @@ -1177,7 +1184,7 @@ function fast-function) (declare (ignore gf)) - (let ((method (std-allocate-instance the-class-standard-method))) + (let ((method (std-allocate-instance +the-standard-method-class+))) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) (%set-method-specializers method (canonicalize-specializers specializers)) @@ -1366,7 +1373,7 @@ (if (or (null methods) (null (%cdr methods))) methods (sort methods - (if (eq (class-of gf) (find-class 'standard-generic-function)) + (if (eq (class-of gf) +the-standard-generic-function-class+) #'(lambda (m1 m2) (std-method-more-specific-p m1 m2 required-classes (generic-function-argument-precedence-order gf))) @@ -1419,7 +1426,7 @@ (defun slow-method-lookup (gf args) (let ((applicable-methods (%compute-applicable-methods gf args))) (if applicable-methods - (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method-function #'compute-effective-method-function) gf applicable-methods))) @@ -1430,7 +1437,7 @@ (defun slow-method-lookup-1 (gf arg arg-specialization) (let ((applicable-methods (%compute-applicable-methods gf (list arg)))) (if applicable-methods - (let ((emfun (funcall (if (eq (class-of gf) (find-class 'standard-generic-function)) + (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method-function #'compute-effective-method-function) gf applicable-methods))) @@ -1516,7 +1523,7 @@ (around (let ((next-emfun (funcall - (if (eq (class-of gf) (find-class 'standard-generic-function)) + (if (eq (class-of gf) +the-standard-generic-function-class+) #'std-compute-effective-method-function #'compute-effective-method-function) gf (remove around methods)))) @@ -1766,7 +1773,7 @@ fast-function slot-name) (declare (ignore gf)) - (let ((method (std-allocate-instance (find-class 'standard-reader-method)))) + (let ((method (std-allocate-instance +the-standard-reader-method-class+))) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) (%set-method-specializers method (canonicalize-specializers specializers)) @@ -1817,7 +1824,7 @@ (ensure-method function-name :lambda-list '(new-value object) :qualifiers () - :specializers (list (find-class 't) class) + :specializers (list +the-T-class+ class) ;; :function `(function ,method-function) :function (if (autoloadp 'compile) method-function Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Thu May 13 17:15:07 2010 @@ -40,8 +40,6 @@ (defvar *output-file-pathname*) -(defvar *function-packages* nil "An alist containing mappings (function-number . package). Every time an (IN-PACKAGE pkg) form is found at top-level, (*class-number* . pkg) is pushed onto this list.") - (defun base-classname (&optional (output-file-pathname *output-file-pathname*)) (sanitize-class-name (pathname-name output-file-pathname))) @@ -133,8 +131,6 @@ (return-from process-toplevel-form)) ((IN-PACKAGE DEFPACKAGE) (note-toplevel-form form) - (if (eq operator 'in-package) - (push (cons (1+ *class-number*) (cadr form)) *function-packages*)) (setf form (precompiler:precompile-form form nil *compile-file-environment*)) (eval form) ;; Force package prefix to be used when dumping form. @@ -548,10 +544,10 @@ (*compile-file-truename* (truename in)) (*source* *compile-file-truename*) (*class-number* 0) - (*function-packages* nil) (namestring (namestring *compile-file-truename*)) (start (get-internal-real-time)) - elapsed) + elapsed + *fasl-uninterned-symbols*) (when *compile-verbose* (format t "; Compiling ~A ...~%" namestring)) (with-compilation-unit () @@ -564,7 +560,6 @@ (*package* *package*) (jvm::*functions-defined-in-current-file* '()) (*fbound-names* '()) - (*fasl-anonymous-package* (%make-package)) (*fasl-stream* out) *forms-for-output*) (jvm::with-saved-compiler-policy @@ -603,49 +598,47 @@ (write "; -*- Mode: Lisp -*-" :escape nil :stream out) (%stream-terpri out) (let ((*package* (find-package '#:cl))) - ;(count-sym (gensym))) (write (list 'init-fasl :version *fasl-version*) :stream out) (%stream-terpri out) (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) + ;; Note: Beyond this point, you can't use DUMP-FORM, + ;; because the list of uninterned symbols has been fixed now. + (when *fasl-uninterned-symbols* + (write (list 'setq '*fasl-uninterned-symbols* + (coerce (mapcar #'car + (nreverse *fasl-uninterned-symbols*)) + 'vector)) + :stream out)) + (%stream-terpri out) (when (> *class-number* 0) (let* ((basename (base-classname)) (expr `(lambda (fasl-loader fn-index) (identity fasl-loader) ;;to avoid unused arg ;;Ugly: should export & import JVM:: symbols - #|(let ((*package* *package*)) - ,(let ((x (cdr (assoc 0 *function-packages*)))) ;;in-package before any function was defined - (when x - `(in-package ,(string x))))|# (ecase fn-index ,@(loop :for i :from 1 :to *class-number* :collect (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) - `(,(1- i) (jvm::with-inline-code () - ;(jvm::emit 'jvm::ldc (jvm::pool-string (symbol-name 'sys::*fasl-loader*))) - ;(jvm::emit 'jvm::ldc (jvm::pool-string (string :system))) - ;(jvm::emit-invokestatic jvm::+lisp-class+ "internInPackage" - ;(list jvm::+java-string+ jvm::+java-string+) jvm::+lisp-symbol+) - ;(jvm::emit-push-current-thread) - ; (jvm::emit-invokevirtual jvm::+lisp-symbol-class+ "symbolValue" - ; (list jvm::+lisp-thread+) jvm::+lisp-object+) - (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" - nil jvm::+java-object+) - (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") - (jvm::emit 'jvm::dup) - (jvm::emit-push-constant-int ,(1- i)) - (jvm::emit 'jvm::new ,class) - (jvm::emit 'jvm::dup) - (jvm::emit-invokespecial-init ,class '()) - (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" - (list "I" jvm::+lisp-object+) jvm::+lisp-object+) - (jvm::emit 'jvm::pop)) - t)))))) + `(,(1- i) + (jvm::with-inline-code () + (jvm::emit 'jvm::aload 1) + (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + nil jvm::+java-object+) + (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") + (jvm::emit 'jvm::dup) + (jvm::emit-push-constant-int ,(1- i)) + (jvm::emit 'jvm::new ,class) + (jvm::emit 'jvm::dup) + (jvm::emit-invokespecial-init ,class '()) + (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" + (list "I" jvm::+lisp-object+) jvm::+lisp-object+) + (jvm::emit 'jvm::pop)) + t)))))) (classname (fasl-loader-classname)) (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") *output-file-pathname*)))) @@ -657,30 +650,12 @@ :element-type '(unsigned-byte 8) :if-exists :supersede) (jvm:compile-defun nil expr nil - classfile f nil))))) + classfile f nil)))) + (format t "~&; Wrote fasl loader ~A~%" classfile)) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader ,*class-number* - ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out) - (%stream-terpri out)) -#| (dump-form - `(dotimes (,count-sym ,*class-number*) - (java:jcall "loadFunction" *fasl-loader* - (%format nil "~A_~D" - ,(sanitize-class-name - (pathname-name output-file)) - (1+ ,count-sym)))) - out)|# - - ;;END TODO - -#| (dump-form `(dotimes (,count-sym ,*class-number*) - (function-preload - (%format nil "~A_~D.cls" - ,(sanitize-class-name - (pathname-name output-file)) - (1+ ,count-sym)))) - out)|# + ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out)) @@ -699,8 +674,11 @@ (zipfile (namestring (merge-pathnames (make-pathname :type type) output-file))) - (pathnames (list (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") - output-file))))) + (pathnames nil) + (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") + output-file)))) + (when (probe-file fasl-loader) + (push fasl-loader pathnames)) (dotimes (i *class-number*) (let* ((pathname (compute-classfile-name (1+ i)))) (when (probe-file pathname) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu May 13 17:15:07 2010 @@ -2342,7 +2342,6 @@ (java:java-object-p obj))) (let ((g (symbol-name (gensym "INSTANCE"))) saved-code) - (sys::%format t "OBJ = ~A ~S~%" (type-of obj) obj) (let* ((s (with-output-to-string (stream) (dump-form obj stream))) (*code* (if *declare-inline* *code* *static-code*))) ;; The readObjectFromString call may require evaluation of @@ -5019,7 +5018,6 @@ (compile-constant (eval (second form)) target representation)))) (defun p2-progv-node (block target representation) - (declare (ignore representation)) (let* ((form (progv-form block)) (symbols-form (cadr form)) (values-form (caddr form)) @@ -5040,7 +5038,7 @@ (list +lisp-object+ +lisp-object+ +lisp-thread+) nil) ;; Implicit PROGN. (let ((*blocks* (cons block *blocks*))) - (compile-progn-body (cdddr form) target)) + (compile-progn-body (cdddr form) target representation)) (restore-environment-and-make-handler environment-register label-START))) (defun p2-quote (form target representation) @@ -6124,8 +6122,7 @@ (emit-push-nil) (emit-invokevirtual +lisp-stream-class+ "readLine" (list "Z" +lisp-object+) +lisp-object+) - (when target - (emit-move-from-stack target))) + (emit-move-from-stack target)) (t (compile-function-call form target representation))))) (2 @@ -6140,8 +6137,7 @@ (emit-push-nil) (emit-invokevirtual +lisp-stream-class+ "readLine" (list "Z" +lisp-object+) +lisp-object+) - (when target - (emit-move-from-stack target)) + (emit-move-from-stack target) ) (t (compile-function-call form target representation))))) @@ -8580,6 +8576,18 @@ (maybe-initialize-thread-var) (setf *code* (nconc code *code*))) + (setf (abcl-class-file-superclass class-file) + (if (or *hairy-arglist-p* + (and *child-p* *closure-variables*)) + +lisp-compiled-closure-class+ + +lisp-primitive-class+)) + + (setf (abcl-class-file-lambda-list class-file) args) + (setf (method-max-locals execute-method) *registers-allocated*) + (push execute-method (abcl-class-file-methods class-file)) + + + ;;; Move here (finalize-code) (optimize-code) @@ -8593,19 +8601,12 @@ (eql (symbol-value (handler-from handler)) (symbol-value (handler-to handler)))) *handlers*)) + ;;; to here + ;;; To a separate function which is part of class file finalization + ;;; when we have a section of class-file-generation centered code - (setf (method-max-locals execute-method) *registers-allocated*) - (setf (method-handlers execute-method) (nreverse *handlers*)) - - (setf (abcl-class-file-superclass class-file) - (if (or *hairy-arglist-p* - (and *child-p* *closure-variables*)) - +lisp-compiled-closure-class+ - +lisp-primitive-class+)) - - (setf (abcl-class-file-lambda-list class-file) args) - (push execute-method (abcl-class-file-methods class-file))) + (setf (method-handlers execute-method) (nreverse *handlers*))) t) (defun p2-with-inline-code (form target representation) @@ -8805,7 +8806,6 @@ (*visible-variables* nil) (*local-functions* nil) (*pathnames-generator* (constantly nil)) - (sys::*fasl-anonymous-package* (sys::%make-package)) environment) (unless (and (consp definition) (eq (car definition) 'LAMBDA)) (let ((function definition)) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/dump-form.lisp Thu May 13 17:15:07 2010 @@ -103,6 +103,16 @@ (standard-object-p object) (java:java-object-p object)) (dump-instance object stream)) + ((and (symbolp object) ;; uninterned symbol + (null (symbol-package object))) + (let ((index (cdr (assoc object *fasl-uninterned-symbols*)))) + (unless index + (setq index (1+ (or (cdar *fasl-uninterned-symbols*) -1))) + (setq *fasl-uninterned-symbols* + (acons object index *fasl-uninterned-symbols*))) + (write-string "#" stream) + (write index :stream stream) + (write-string "?" stream))) (t (%stream-output-object object stream)))) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp Thu May 13 17:15:07 2010 @@ -325,12 +325,21 @@ (java:java-exception-cause e))))) ;;; JAVA-CLASS support +(defconstant +java-lang-object+ (jclass "java.lang.Object")) (defclass java-class (standard-class) ((jclass :initarg :java-class :initform (error "class is required") :reader java-class-jclass))) +;;init java.lang.Object class +(defconstant +java-lang-object-class+ + (%register-java-class +java-lang-object+ + (mop::ensure-class (make-symbol "java.lang.Object") + :metaclass (find-class 'java-class) + :direct-superclasses (list (find-class 'java-object)) + :java-class +java-lang-object+))) + (defun ensure-java-class (jclass) (let ((class (%find-java-class jclass))) (if class @@ -340,14 +349,45 @@ (make-symbol (jclass-name jclass)) :metaclass (find-class 'java-class) :direct-superclasses - (if (jclass-superclass-p jclass (jclass "java.lang.Object")) - (list (find-class 'java-object)) - (mapcar #'ensure-java-class - (delete nil - (concatenate 'list (list (jclass-superclass jclass)) - (jclass-interfaces jclass))))) + (let ((supers + (mapcar #'ensure-java-class + (delete nil + (concatenate 'list + (list (jclass-superclass jclass)) + (jclass-interfaces jclass)))))) + (if (jclass-interface-p jclass) + (append supers (list (find-class 'java-object))) + supers)) :java-class jclass))))) +(defmethod mop::compute-class-precedence-list ((class java-class)) + "Sort classes this way: + 1. Java classes (but not java.lang.Object) + 2. Java interfaces + 3. java.lang.Object + 4. other classes + Rationale: + 1. Concrete classes are the most specific. + 2. Then come interfaces. + So if a generic function is specialized both on an interface and a concrete class, + the concrete class comes first. + 3. because everything is an Object. + 4. to handle base CLOS classes. + Note: Java interfaces are not sorted among themselves in any way, so if a + gf is specialized on two different interfaces and you apply it to an object that + implements both, it is unspecified which method will be called." + (let ((cpl (nreverse (mop::collect-superclasses* class)))) + (flet ((score (class) + (if (not (typep class 'java-class)) + 4 + (cond + ((jcall (jmethod "java.lang.Object" "equals" "java.lang.Object") + (java-class-jclass class) +java-lang-object+) 3) + ((jclass-interface-p (java-class-jclass class)) 2) + (t 1))))) + (stable-sort cpl #'(lambda (x y) + (< (score x) (score y))))))) + (defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (error "make-instance not supported for ~S" class)) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/util/HttpHead.java Thu May 13 17:15:07 2010 @@ -92,8 +92,9 @@ return result; } - String head = "HEAD " + url + " HTTP/1.1"; + String head = "HEAD " + url.getPath() + " HTTP/1.1"; out.println(head); + out.println("Host: " + url.getAuthority()); out.println("Connection: close"); out.println(""); out.flush(); Modified: branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp (original) +++ branches/less-reflection/abcl/test/lisp/abcl/jar-pathname.lisp Thu May 13 17:15:07 2010 @@ -124,48 +124,53 @@ ;;; wrapped in PROGN for easy disabling without a network connection ;;; XXX come up with a better abstraction +(defvar *url-jar-pathname-base* + "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20100505a.jar!/") + +(defmacro load-url-relative (path) + `(load (format nil "~A~A" *url-jar-pathname-base* ,path))) + (progn (deftest jar-pathname.load.11 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo") + (load-url-relative "foo") t) (deftest jar-pathname.load.12 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar") + (load-url-relative "bar") t) (deftest jar-pathname.load.13 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar.abcl") + (load-url-relative "bar.abcl") t) (deftest jar-pathname.load.14 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek") + (load-url-relative "eek") t) (deftest jar-pathname.load.15 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek.lisp") + (load-url-relative "eek.lisp") t) (deftest jar-pathname.load.16 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/foo") + (load-url-relative "a/b/foo") t) (deftest jar-pathname.load.17 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar") + (load-url-relative "a/b/bar") t) (deftest jar-pathname.load.18 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar.abcl") + (load-url-relative "a/b/bar.abcl") t) (deftest jar-pathname.load.19 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek") + (load-url-relative "a/b/eek") t) (deftest jar-pathname.load.20 - (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp") + (load-url-relative "a/b/eek.lisp") t)) - (deftest jar-pathname.probe-file.1 (with-jar-file-init (probe-file "jar:file:baz.jar!/eek.lisp")) @@ -215,6 +220,11 @@ "jar:file:baz.jar!/foo" "/a/b/c") #p"jar:file:/a/b/baz.jar!/foo") + +;;; Under win32, we get the device in the merged path +#+windows +(push 'jar-pathname.merge-pathnames.5 *expected-failures*) + (deftest jar-pathname.merge-pathnames.5 (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp") #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp") @@ -332,11 +342,10 @@ nil) (deftest jar-pathname.translate.1 - (namestring - (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" - "jar:file:/**/*.jar!/**/*.*" - "/foo/**/*.*")) - "/foo/d/e/f.lisp") + (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" + "jar:file:/**/*.jar!/**/*.*" + "/foo/**/*.*") + #p"/foo/d/e/f.lisp") From astalla at common-lisp.net Thu May 13 21:44:55 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 13 May 2010 17:44:55 -0400 Subject: [armedbear-cvs] r12680 - branches/less-reflection/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu May 13 17:44:54 2010 New Revision: 12680 Log: Removed debug print, the branch now fails the same tests as trunk. Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Thu May 13 17:44:54 2010 @@ -650,8 +650,7 @@ :element-type '(unsigned-byte 8) :if-exists :supersede) (jvm:compile-defun nil expr nil - classfile f nil)))) - (format t "~&; Wrote fasl loader ~A~%" classfile)) + classfile f nil))))) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader ,*class-number* From ehuelsmann at common-lisp.net Thu May 13 22:06:50 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 13 May 2010 18:06:50 -0400 Subject: [armedbear-cvs] r12681 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu May 13 18:06:48 2010 New Revision: 12681 Log: Eliminate the need for two separate integer-declaring functions in the compiler; replace declare-fixnum and declare-bignum. 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 Thu May 13 18:06:48 2010 @@ -2184,50 +2184,33 @@ (setf *static-code* *code*) (setf (gethash local-function ht) g)))) -(defknown declare-fixnum (fixnum) string) -(defun declare-fixnum (n) - (declare (type fixnum n)) +(defknown declare-integer (integer) string) +(defun declare-integer (n) (declare-with-hashtable n *declared-integers* ht g + (setf g (concatenate 'string "INT_" (symbol-name (gensym)))) (let ((*code* *static-code*)) ;; no need to *declare-inline*: constants - (setf g (format nil "FIXNUM_~A~D" - (if (minusp n) "MINUS_" "") - (abs n))) (declare-field g +lisp-integer+ +field-access-private+) - (cond ((<= 0 n 255) - (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) - (emit-push-constant-int n) - (emit 'aaload)) - (t - (emit-push-constant-int n) - (convert-representation :int nil))) - (emit 'putstatic *this-class* g +lisp-integer+) - (setf *static-code* *code*) - (setf (gethash n ht) g)))) - -(defknown declare-bignum (integer) string) -(defun declare-bignum (n) - (declare-with-hashtable - n *declared-integers* ht g - (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym)))) - (let ((*code* *static-code*)) - ;; no need to *declare-inline*: constants - (declare-field g +lisp-integer+ +field-access-private+) - (cond ((<= most-negative-java-long n most-positive-java-long) -;; (setf g (format nil "BIGNUM_~A~D" -;; (if (minusp n) "MINUS_" "") -;; (abs n))) - (emit 'ldc2_w (pool-long n)) - (emit-invokestatic +lisp-bignum-class+ "getInstance" - '("J") +lisp-integer+)) - (t - (let* ((*print-base* 10) - (s (with-output-to-string (stream) (dump-form n stream)))) - (emit 'ldc (pool-string s)) - (emit-push-constant-int 10) - (emit-invokestatic +lisp-bignum-class+ "getInstance" - (list +java-string+ "I") +lisp-integer+)))) + (cond((<= 0 n 255) + (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) + (emit-push-constant-int n) + (emit 'aaload)) + ((<= most-negative-fixnum n most-positive-fixnum) + (emit-push-constant-int n) + (emit-invokestatic +lisp-fixnum-class+ "getInstance" + '("I") +lisp-fixnum+)) + ((<= most-negative-java-long n most-positive-java-long) + (emit-push-constant-long n) + (emit-invokestatic +lisp-bignum-class+ "getInstance" + '("J") +lisp-integer+)) + (t + (let* ((*print-base* 10) + (s (with-output-to-string (stream) (dump-form n stream)))) + (emit 'ldc (pool-string s)) + (emit-push-constant-int 10) + (emit-invokestatic +lisp-bignum-class+ "getInstance" + (list +java-string+ "I") +lisp-integer+)))) (emit 'putstatic *this-class* g +lisp-integer+) (setf *static-code* *code*)) (setf (gethash n ht) g))) @@ -2435,7 +2418,7 @@ (cond ((fixnump form) (emit-push-constant-int form)) ((integerp form) - (emit 'getstatic *this-class* (declare-bignum form) +lisp-integer+) + (emit 'getstatic *this-class* (declare-integer form) +lisp-integer+) (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")) (t (sys::%format t "compile-constant int representation~%") @@ -2446,7 +2429,7 @@ (cond ((<= most-negative-java-long form most-positive-java-long) (emit-push-constant-long form)) ((integerp form) - (emit 'getstatic *this-class* (declare-bignum form) +lisp-integer+) + (emit 'getstatic *this-class* (declare-integer form) +lisp-integer+) (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) (t (sys::%format t "compile-constant long representation~%") @@ -2490,20 +2473,8 @@ (emit-move-from-stack target representation) (return-from compile-constant)) ((NIL))) - (cond ((fixnump form) - (let ((translation (case form - (0 "ZERO") - (1 "ONE") - (2 "TWO") - (3 "THREE") - (-1 "MINUS_ONE")))) - (if translation - (emit 'getstatic +lisp-fixnum-class+ translation +lisp-fixnum+) - (emit 'getstatic *this-class* (declare-fixnum form) - +lisp-integer+)))) - ((integerp form) - ;; A bignum. - (emit 'getstatic *this-class* (declare-bignum form) +lisp-integer+)) + (cond ((integerp form) + (emit 'getstatic *this-class* (declare-integer form) +lisp-integer+)) ((typep form 'single-float) (emit 'getstatic *this-class* (declare-float form) +lisp-single-float+)) From ehuelsmann at common-lisp.net Sat May 15 10:20:44 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 15 May 2010 06:20:44 -0400 Subject: [armedbear-cvs] r12682 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 15 06:20:40 2010 New Revision: 12682 Log: Add APIs to access data gathered in the profiler to detect (lisp) hot spots. Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/profiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sat May 15 06:20:40 2010 @@ -284,8 +284,8 @@ ;; Profiler. (in-package "PROFILER") -(export '(*granularity* show-call-counts with-profiling)) -(autoload 'show-call-counts "profiler") +(export '(*granularity* show-call-counts show-hot-counts with-profiling)) +(autoload '(show-call-counts show-hot-counts) "profiler") (autoload-macro 'with-profiling "profiler") ;; Extensions. Modified: trunk/abcl/src/org/armedbear/lisp/profiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/profiler.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/profiler.lisp Sat May 15 06:20:40 2010 @@ -46,9 +46,10 @@ tpl::repl tpl::top-level-loop)) (defstruct (profile-info - (:constructor make-profile-info (object count))) + (:constructor make-profile-info (object full-count hot-count))) object - count) + full-count + hot-count) ;; Returns list of all symbols with non-zero call counts. (defun list-called-objects () @@ -58,16 +59,23 @@ (unless (memq sym *hidden-functions*) (when (fboundp sym) (let* ((definition (fdefinition sym)) - (count (sys:call-count definition))) - (unless (zerop count) + (full-count (sys:call-count definition)) + (hot-count (sys:hot-count definition))) + (unless (zerop full-count) (cond ((typep definition 'generic-function) - (push (make-profile-info definition count) result) - (dolist (method (mop::generic-function-methods definition)) - (setf count (sys:call-count (sys:%method-function method))) - (unless (zerop count) - (push (make-profile-info method count) result)))) + (push (make-profile-info definition + full-count hot-count) result) + (dolist (method + (mop::generic-function-methods definition)) + (let ((function (sys:%method-function method))) + (setf full-count (sys:call-count function)) + (setf hot-count (sys:hot-count function))) + (unless (zerop full-count) + (push (make-profile-info method full-count + hot-count) result)))) (t - (push (make-profile-info sym count) result))))))))) + (push (make-profile-info sym full-count hot-count) + result))))))))) (remove-duplicates result :key 'profile-info-object :test 'eq))) (defun object-name (object) @@ -90,7 +98,25 @@ (defun show-call-count (info max-count) (let* ((object (profile-info-object info)) - (count (profile-info-count info))) + (count (profile-info-full-count info))) + (if max-count + (format t "~5,1F ~8D ~S~A~%" + (/ (* count 100.0) max-count) + count + (object-name object) + (if (object-compiled-function-p object) + "" + " [interpreted function]")) + (format t "~8D ~S~A~%" + count + (object-name object) + (if (object-compiled-function-p object) + "" + " [interpreted function]"))))) + +(defun show-hot-count (info max-count) + (let* ((object (profile-info-object info)) + (count (profile-info-hot-count info))) (if max-count (format t "~5,1F ~8D ~S~A~%" (/ (* count 100.0) max-count) @@ -108,12 +134,12 @@ (defun show-call-counts () (let ((list (list-called-objects))) - (setf list (sort list #'< :key 'profile-info-count)) + (setf list (sort list #'< :key 'profile-info-full-count)) (let ((max-count nil)) (when (eq *type* :time) (let ((last-info (car (last list)))) (setf max-count (if last-info - (profile-info-count last-info) + (profile-info-full-count last-info) nil)) (when (eql max-count 0) (setf max-count nil)))) @@ -121,6 +147,21 @@ (show-call-count info max-count)))) (values)) +(defun show-hot-counts () + (let ((list (list-called-objects))) + (setf list (sort list #'< :key 'profile-info-hot-count)) + (let ((max-count nil)) + (when (eq *type* :time) + (let ((last-info (car (last list)))) + (setf max-count (if last-info + (profile-info-hot-count last-info) + nil)) + (when (eql max-count 0) + (setf max-count nil)))) + (dolist (info list) + (show-hot-count info max-count)))) + (values)) + (defun start-profiler (&key type) "Starts the profiler. :TYPE may be either :TIME (statistical sampling) or :COUNT-ONLY (exact call From ehuelsmann at common-lisp.net Sat May 15 14:14:29 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 15 May 2010 10:14:29 -0400 Subject: [armedbear-cvs] r12683 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 15 10:14:28 2010 New Revision: 12683 Log: Save a few bytes in our JAR by re-using serialized anonymous symbols, when multiple references are required. 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 May 15 10:14:28 2010 @@ -2072,11 +2072,12 @@ (declare-with-hashtable symbol *declared-symbols* ht g (cond ((null (symbol-package symbol)) - (setf g (if *file-compilation* - (declare-object-as-string symbol +lisp-symbol+ + (setf g (if *file-compilation* + (declare-object-as-string symbol +lisp-symbol+ +lisp-symbol-class+) - (declare-object symbol +lisp-symbol+ - +lisp-symbol-class+)))) + (declare-object symbol +lisp-symbol+ + +lisp-symbol-class+)) + (gethash symbol ht) g)) (t (let (saved-code) (let ((*code* (if *declare-inline* *code* *static-code*)) From mevenson at common-lisp.net Sat May 15 16:33:16 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 15 May 2010 12:33:16 -0400 Subject: [armedbear-cvs] r12684 - branches/0.20.x/abcl Message-ID: Author: mevenson Date: Sat May 15 12:33:15 2010 New Revision: 12684 Log: Backport r1267[14]: Site specific initialization code can be named by 'abcl.startup.file'. Builds of ABCL can now be customized with "site specific" startup code by setting the Ant property 'abcl.startup.file' to the path of a file containing the custom code. This code is merged into 'system.lisp' which is loaded during the boot process. Modified: branches/0.20.x/abcl/abcl.properties.in branches/0.20.x/abcl/build.xml Modified: branches/0.20.x/abcl/abcl.properties.in ============================================================================== --- branches/0.20.x/abcl/abcl.properties.in (original) +++ branches/0.20.x/abcl/abcl.properties.in Sat May 15 12:33:15 2010 @@ -10,4 +10,7 @@ #abcl.compile.lisp.skip=true # java.options sets the Java options in the abcl wrapper scripts -#java.options=-Xmx1g \ No newline at end of file +#java.options=-Xmx1g + +# Additional site specific startup code to be merged in 'system.lisp' +#abcl.startup.file=${basedir}/startup.lisp Modified: branches/0.20.x/abcl/build.xml ============================================================================== --- branches/0.20.x/abcl/build.xml (original) +++ branches/0.20.x/abcl/build.xml Sat May 15 12:33:15 2010 @@ -101,7 +101,7 @@ Compiled ABCL with Java version: ${java.version} - + Cleaning all intermediate compilation artifacts. Setting 'abcl.build.incremental' enables incremental compilation. @@ -223,9 +223,12 @@ + + Compiling Lisp system @@ -241,6 +244,9 @@ + + + abcl.hostname: ${abcl.hostname} + + + + + + + + From mevenson at common-lisp.net Sat May 15 16:35:50 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 15 May 2010 12:35:50 -0400 Subject: [armedbear-cvs] r12685 - in branches/0.20.x/abcl: . src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sat May 15 12:35:47 2010 New Revision: 12685 Log: Backport r1267[35]: Load 'system.lisp' later in boot so conditions trigger debugger. New command line option '--nosystem' omits the processing of 'system.lisp'. Modified: branches/0.20.x/abcl/build.xml branches/0.20.x/abcl/src/org/armedbear/lisp/Interpreter.java branches/0.20.x/abcl/src/org/armedbear/lisp/boot.lisp Modified: branches/0.20.x/abcl/build.xml ============================================================================== --- branches/0.20.x/abcl/build.xml (original) +++ branches/0.20.x/abcl/build.xml Sat May 15 12:35:47 2010 @@ -241,6 +241,7 @@ classname="org.armedbear.lisp.Main"> + @@ -278,12 +279,19 @@ - + + + + + + - + Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Interpreter.java ============================================================================== --- branches/0.20.x/abcl/src/org/armedbear/lisp/Interpreter.java (original) +++ branches/0.20.x/abcl/src/org/armedbear/lisp/Interpreter.java Sat May 15 12:35:47 2010 @@ -52,6 +52,7 @@ private final OutputStream outputStream; private static boolean noinit = false; + private static boolean nosystem = false; private static boolean noinform = false; public static synchronized Interpreter getInstance() @@ -92,6 +93,8 @@ } initializeLisp(); initializeTopLevel(); + if (!nosystem) + initializeSystem(); if (!noinit) processInitializationFile(); if (args != null) @@ -117,6 +120,7 @@ initializeJLisp(); initializeTopLevel(); + initializeSystem(); processInitializationFile(); return interpreter; } @@ -211,6 +215,11 @@ } } + private static synchronized void initializeSystem() + { + Load.loadSystemFile("system"); + } + // Check for --noinit; verify that arguments are supplied for --load and // --eval options. Copy all unrecognized arguments into // ext:*command-line-argument-list* @@ -224,6 +233,8 @@ String arg = args[i]; if (arg.equals("--noinit")) { noinit = true; + } else if (arg.equals("--nosystem")) { + nosystem = true; } else if (arg.equals("--noinform")) { noinform = true; } else if (arg.equals("--batch")) { Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/boot.lisp ============================================================================== --- branches/0.20.x/abcl/src/org/armedbear/lisp/boot.lisp (original) +++ branches/0.20.x/abcl/src/org/armedbear/lisp/boot.lisp Sat May 15 12:35:47 2010 @@ -209,12 +209,4 @@ (%format t "Startup completed in ~A seconds.~%" (float (/ (ext:uptime) 1000))))) -;;; "system.lisp" contains system installation specific information -;;; (currently only the logical pathname definition for "SYS;SRC") -;;; that is not currently required for ABCL to run. Since -;;; LOAD-SYSTEM-FILE exits the JVM if its argument cannot be found, we -;;; use REQUIRE trapping any error. -(handler-case - (require 'system) - (t ())) From mevenson at common-lisp.net Sat May 15 16:38:25 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 15 May 2010 12:38:25 -0400 Subject: [armedbear-cvs] r12686 - branches/0.20.x/abcl Message-ID: Author: mevenson Date: Sat May 15 12:38:24 2010 New Revision: 12686 Log: Backportr 12676: Muffle warning from Ant 1.8.1 about includeantruntime not being set. Modified: branches/0.20.x/abcl/build.xml Modified: branches/0.20.x/abcl/build.xml ============================================================================== --- branches/0.20.x/abcl/build.xml (original) +++ branches/0.20.x/abcl/build.xml Sat May 15 12:38:24 2010 @@ -176,6 +176,7 @@ From mevenson at common-lisp.net Sat May 15 18:57:00 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 15 May 2010 14:57:00 -0400 Subject: [armedbear-cvs] r12687 - trunk/abcl Message-ID: Author: mevenson Date: Sat May 15 14:56:59 2010 New Revision: 12687 Log: Updates in preparation for abcl-0.20. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES (original) +++ trunk/abcl/CHANGES Sat May 15 14:56:59 2010 @@ -7,60 +7,83 @@ Features -------- -* [svn r12576] Support for CLOS METACLASS feature +* [svn r12576] Support for CLOS METACLASS feature. -* [svn r12591-602] Consolidation of copy/paste code in the readers +* [svn r12591-602] Consolidation of copy/paste code in the readers. -* [svn r12619] Update included ASDF (to ASDF2) +* [svn r12619] Update to ASDF2 (specifically to ASDF 1.719). -* [svn r12620] Use interpreted function in FASL when compilation fails +* [svn r12620] Use interpreted function in FASL when compilation fails. -* [ticket 95] Pathname functions work with URLs and JARs +* [ticket #95] PATHNAME-JAR and PATHNAME-URL subtypes now handle jar + and URL references working for OPEN, LOAD, PROBE-FILE, + FILE-WRITE-DATE, DIRECTORY, et. al. -* Many small speed improvements (by marking functions 'final') +* Many small speed improvements (by marking functions 'final'). * [ticket #91] Threads started through MAKE-THREAD now have a - thread-termination restart available in their debugger + thread-termination restart available in their debugger. -* [svn r12663] JCLASS supports an optional class-loader argument +* [svn r12663] JCLASS supports an optional class-loader argument. -* [svn r12634] THREADS:THREAD-JOIN implemented +* [svn r12634] THREADS:THREAD-JOIN implemented. + +* [svn r12671] Site specific initialization code can be included in + builds via the 'abcl.startup.file' Ant property. Fixes ----- -* [ticket 89] Inlining of READ-LINE broken when the return value - is unused +* [ticket #89] Inlining of READ-LINE broken when the return value + is unused. * [svn r12636] Java class verification error when compiling PROGV in a context wanting an unboxed return value (typically a - logical expression) + logical expression). * [svn r12635] ABCL loads stale fasls instead of updated source - even when LOAD is called with a file name without extension + even when LOAD is called with a file name without extension. * [ticket #92] Codepoints between #xD800 and #xDFFF are incorrectly - returned as characters from CODE-CHAR + returned as characters from CODE-CHAR. * [ticket #93] Reader doesn't handle zero returned values from - macro functions correctly + macro functions correctly. * [ticket #79] Different, yet similarly named, uninterned symbols are incorrectly coalesced into the same object in a fasl. * [ticket #86] No restarts available to kill a thread, if none - bound by user code + bound by user code. * [svn r12586] Increased function dispatch speed by eliminating - FIND-CLASS calls (replacing them by constant references) + FIND-CLASS calls (replacing them by constant references). + +* [svn r12656] PATHNAME-JAR now properly uses HTTP/1.1 HEAD requests + to detect if remote resource has been changed. + +* [svn r12643] PATHNAME-JAR now properly references Windows drive + letters on DEVICE other than the default. + +* [svn r12621] Missing 'build-from-lisp.sh' referenced in README now + included in source release. Other ----- * [svn r12581] LispCharacter() constructors made private, in favor - of getInstance() for better re-use of pre-constructed characters + of getInstance() for better re-use of pre-constructed characters. -* [svn r12583] JAVA-CLASS reimplemented in Lisp +* [svn r12583] JAVA-CLASS reimplemented in Lisp. + +* [svn r12673] Load 'system.lisp' moved later in boot sequence so + unhandled conditions drop to debugger. + +* [svn r12675] '--nosystem' commandline option inhibits loading of + 'system.lisp'. + +* [svn r12642] Under Windows, pathname TYPE components can now contain + embedded periods iff they end in '.lnk' to support shortcuts. Version 0.19 @@ -543,3 +566,4 @@ * All static fields declared 'final' * Add support for java.lang.Long based on Bignum to our FFI + From mevenson at common-lisp.net Sat May 15 18:58:14 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sat, 15 May 2010 14:58:14 -0400 Subject: [armedbear-cvs] r12688 - branches/0.20.x/abcl Message-ID: Author: mevenson Date: Sat May 15 14:58:14 2010 New Revision: 12688 Log: Backport r12687: Update CHANGES for release. Modified: branches/0.20.x/abcl/CHANGES Modified: branches/0.20.x/abcl/CHANGES ============================================================================== --- branches/0.20.x/abcl/CHANGES (original) +++ branches/0.20.x/abcl/CHANGES Sat May 15 14:58:14 2010 @@ -7,60 +7,83 @@ Features -------- -* [svn r12576] Support for CLOS METACLASS feature +* [svn r12576] Support for CLOS METACLASS feature. -* [svn r12591-602] Consolidation of copy/paste code in the readers +* [svn r12591-602] Consolidation of copy/paste code in the readers. -* [svn r12619] Update included ASDF (to ASDF2) +* [svn r12619] Update to ASDF2 (specifically to ASDF 1.719). -* [svn r12620] Use interpreted function in FASL when compilation fails +* [svn r12620] Use interpreted function in FASL when compilation fails. -* [ticket 95] Pathname functions work with URLs and JARs +* [ticket #95] PATHNAME-JAR and PATHNAME-URL subtypes now handle jar + and URL references working for OPEN, LOAD, PROBE-FILE, + FILE-WRITE-DATE, DIRECTORY, et. al. -* Many small speed improvements (by marking functions 'final') +* Many small speed improvements (by marking functions 'final'). * [ticket #91] Threads started through MAKE-THREAD now have a - thread-termination restart available in their debugger + thread-termination restart available in their debugger. -* [svn r12663] JCLASS supports an optional class-loader argument +* [svn r12663] JCLASS supports an optional class-loader argument. -* [svn r12634] THREADS:THREAD-JOIN implemented +* [svn r12634] THREADS:THREAD-JOIN implemented. + +* [svn r12671] Site specific initialization code can be included in + builds via the 'abcl.startup.file' Ant property. Fixes ----- -* [ticket 89] Inlining of READ-LINE broken when the return value - is unused +* [ticket #89] Inlining of READ-LINE broken when the return value + is unused. * [svn r12636] Java class verification error when compiling PROGV in a context wanting an unboxed return value (typically a - logical expression) + logical expression). * [svn r12635] ABCL loads stale fasls instead of updated source - even when LOAD is called with a file name without extension + even when LOAD is called with a file name without extension. * [ticket #92] Codepoints between #xD800 and #xDFFF are incorrectly - returned as characters from CODE-CHAR + returned as characters from CODE-CHAR. * [ticket #93] Reader doesn't handle zero returned values from - macro functions correctly + macro functions correctly. * [ticket #79] Different, yet similarly named, uninterned symbols are incorrectly coalesced into the same object in a fasl. * [ticket #86] No restarts available to kill a thread, if none - bound by user code + bound by user code. * [svn r12586] Increased function dispatch speed by eliminating - FIND-CLASS calls (replacing them by constant references) + FIND-CLASS calls (replacing them by constant references). + +* [svn r12656] PATHNAME-JAR now properly uses HTTP/1.1 HEAD requests + to detect if remote resource has been changed. + +* [svn r12643] PATHNAME-JAR now properly references Windows drive + letters on DEVICE other than the default. + +* [svn r12621] Missing 'build-from-lisp.sh' referenced in README now + included in source release. Other ----- * [svn r12581] LispCharacter() constructors made private, in favor - of getInstance() for better re-use of pre-constructed characters + of getInstance() for better re-use of pre-constructed characters. -* [svn r12583] JAVA-CLASS reimplemented in Lisp +* [svn r12583] JAVA-CLASS reimplemented in Lisp. + +* [svn r12673] Load 'system.lisp' moved later in boot sequence so + unhandled conditions drop to debugger. + +* [svn r12675] '--nosystem' commandline option inhibits loading of + 'system.lisp'. + +* [svn r12642] Under Windows, pathname TYPE components can now contain + embedded periods iff they end in '.lnk' to support shortcuts. Version 0.19 @@ -543,3 +566,4 @@ * All static fields declared 'final' * Add support for java.lang.Long based on Bignum to our FFI + From mevenson at common-lisp.net Sun May 16 09:09:46 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 16 May 2010 05:09:46 -0400 Subject: [armedbear-cvs] r12689 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Sun May 16 05:09:43 2010 New Revision: 12689 Log: Thunk through URL.toURI() for getting URL authority. Fixes loading from OSGi context with 'bundleresource:' for which the java.net.URL object is incorrectly returning 'SECURITY_CHECKED' from getAuthority(). Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Sun May 16 05:09:43 2010 @@ -355,7 +355,16 @@ return; } Debug.assertTrue(scheme != null); - String authority = url.getAuthority(); + // String authority = url.getAuthority(); + URI uri = null; + try { + uri = url.toURI().normalize(); + } catch (URISyntaxException e) { + error(new LispError("Could not URI escape characters in " + + "'" + url + "'" + + " because: " + e)); + } + String authority = uri.getAuthority(); Debug.assertTrue(authority != null); host = NIL; @@ -367,15 +376,6 @@ device = NIL; // URI encode necessary characters - URI uri = null; - try { - uri = url.toURI().normalize(); - } catch (URISyntaxException e) { - error(new LispError("Could not URI escape characters in " - + "'" + url + "'" - + " because: " + e)); - } - String path = uri.getRawPath(); if (path == null) { path = ""; From ehuelsmann at common-lisp.net Sun May 16 15:06:33 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 16 May 2010 11:06:33 -0400 Subject: [armedbear-cvs] r12690 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 16 11:06:32 2010 New Revision: 12690 Log: Replace serialization related DECLARE-* functions with a single API: EXTERNALIZE-OBJECT, which builds upon a set of SERIALIZE-* functions. The intent is to make building blocks which allow - at a later stage - serialization without utilizing the reader for restoring. With this commit, the compiler stops generating meaningful field names; instead it just uses a type ("STR") and a sequence number. Note: A number of DECLARE-* functions remain in place, these don't have to do with serialization, though; most have caching characteristics. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm.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 May 16 11:06:32 2010 @@ -1,4 +1,4 @@ -;;; compiler-pass2.lisp +?;;; compiler-pass2.lisp ;;; ;;; Copyright (C) 2003-2008 Peter Graves ;;; Copyright (C) 2008 Ville Voutilainen @@ -2065,42 +2065,174 @@ , at body) ,item-var)) +;; The protocol of the serialize-* functions is to serialize +;; the type to which they apply and emit code which leaves the +;; restored object on the stack. + +;; The functions may generate only Java code, or decide to defer +;; some of the process of restoring the object to the reader. The +;; latter is generally applicable to more complex structures. + +;; This way, the serialize-* functions can be used to depend on +;; each other to serialize nested constructs. They are also the +;; building blocks of the EXTERNALIZE-OBJECT function, which is +;; called from the compiler. + +(defun serialize-integer (n) + "Generates code to restore a serialized integer." + (cond((<= 0 n 255) + (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+) + (emit-push-constant-int n) + (emit 'aaload)) + ((<= most-negative-fixnum n most-positive-fixnum) + (emit-push-constant-int n) + (emit-invokestatic +lisp-fixnum-class+ "getInstance" + '("I") +lisp-fixnum+)) + ((<= most-negative-java-long n most-positive-java-long) + (emit-push-constant-long n) + (emit-invokestatic +lisp-bignum-class+ "getInstance" + '("J") +lisp-integer+)) + (t + (let* ((*print-base* 10) + (s (with-output-to-string (stream) (dump-form n stream)))) + (emit 'ldc (pool-string s)) + (emit-push-constant-int 10) + (emit-invokestatic +lisp-bignum-class+ "getInstance" + (list +java-string+ "I") +lisp-integer+))))) + +(defun serialize-character (c) + "Generates code to restore a serialized character." + (emit-push-constant-int (char-code c)) + (emit-invokestatic +lisp-character-class+ "getInstance" '("C") + +lisp-character+)) + +(defun serialize-float (s) + "Generates code to restore a serialized single-float." + (emit 'new +lisp-single-float-class+) + (emit 'dup) + (emit 'ldc (pool-float s)) + (emit-invokespecial-init +lisp-single-float-class+ '("F"))) + +(defun serialize-double (d) + "Generates code to restore a serialized double-float." + (emit 'new +lisp-double-float-class+) + (emit 'dup) + (emit 'ldc2_w (pool-double d)) + (emit-invokespecial-init +lisp-double-float-class+ '("D"))) + +(defun serialize-string (string) + "Generate code to restore a serialized string." + (emit 'new +lisp-simple-string-class+) + (emit 'dup) + (emit 'ldc (pool-string string)) + (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))) + +(defun serialize-package (pkg) + "Generate code to restore a serialized package." + (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \"" + (package-name pkg) "\")"))) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+)) + +(defun serialize-object (object) + "Generate code to restore a serialized object which is not of any +of the other types." + (let ((s (with-output-to-string (stream) + (dump-form object stream)))) + (emit 'ldc (pool-string s)) + (emit-invokestatic +lisp-class+ "readObjectFromString" + (list +java-string+) +lisp-object+))) + +(defun serialize-symbol (symbol) + "Generate code to restore a serialized symbol." + (cond + ((null (symbol-package symbol)) + ;; we need to read the #? syntax for uninterned symbols + + ;; TODO: we could use the byte code variant of + ;; Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(LispThread.currentThread()) + ;; .aref( Author: vvoutilainen Date: Sun May 16 12:58:26 2010 New Revision: 12691 Log: Remove a BOM from the beginning of the 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 May 16 12:58:26 2010 @@ -1,4 +1,4 @@ -?;;; compiler-pass2.lisp +;;; compiler-pass2.lisp ;;; ;;; Copyright (C) 2003-2008 Peter Graves ;;; Copyright (C) 2008 Ville Voutilainen From ehuelsmann at common-lisp.net Sun May 16 19:45:42 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 16 May 2010 15:45:42 -0400 Subject: [armedbear-cvs] r12692 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 16 15:45:41 2010 New Revision: 12692 Log: Replace lookup-or-declare-symbol - which was used to load a symbol in all cases - with the easier paradigm EMIT-LOAD-SYMBOL. 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 May 16 15:45:41 2010 @@ -750,10 +750,7 @@ (emit 'aaload)))) (defun emit-push-variable-name (variable) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol (variable-name variable)) - (emit 'getstatic class name +lisp-symbol+))) + (emit-load-symbol (variable-name variable))) (defknown generate-instanceof-type-check-for-variable (t t) t) (defun generate-instanceof-type-check-for-variable (variable expected-type) @@ -2234,15 +2231,14 @@ (declare-object symbol +lisp-symbol+ +lisp-symbol-class+)) (t (externalize-object symbol)))) -(defun lookup-or-declare-symbol (symbol) - "Returns the value-pair (VALUES field class) from which -the Java object representing SYMBOL can be retrieved." +(defun emit-load-symbol (symbol) + "Loads a symbol, optionally after externalizing it." (multiple-value-bind (name class) (lookup-known-symbol symbol) (if name - (values name class) - (values (declare-symbol symbol) *this-class*)))) + (emit 'getstatic class name +lisp-symbol+) + (emit 'getstatic *this-class* (declare-symbol symbol) +lisp-symbol+)))) (defknown declare-function (symbol &optional setf) string) (defun declare-function (symbol &optional setf) @@ -2256,7 +2252,15 @@ (declare-field f +lisp-object+ +field-access-private+) (multiple-value-bind (name class) - (lookup-or-declare-symbol symbol) + (lookup-known-symbol symbol) + ;; This is a work-around for the fact that + ;; EMIT-LOAD-SYMBOL can't be used due to the fact that + ;; here we won't know where to send the code yet (the LET + ;; selects between *code* and *static-code*, while + ;; EMIT-LOAD-SYMBOL wants to modify those specials too + (unless name + (setf name (declare-symbol symbol) + class *this-class*)) (let (saved-code) (let ((*code* (if *declare-inline* *code* *static-code*))) (emit 'getstatic class name +lisp-symbol+) @@ -3030,16 +3034,10 @@ (emit-push-current-thread)) (cond ((eq op (compiland-name *current-compiland*)) ; recursive call (if (notinline-p op) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol op) - (emit 'getstatic class name +lisp-symbol+)) + (emit-load-symbol op) (aload 0))) (t - (multiple-value-bind - (name class) - (lookup-or-declare-symbol op) - (emit 'getstatic class name +lisp-symbol+)))) + (emit-load-symbol op))) (process-args args) (if (or (<= *speed* *debug*) *require-stack-frame*) (emit-call-thread-execute numargs) @@ -5024,10 +5022,7 @@ (emit 'iconst_1) (emit-move-from-stack target representation)) ((symbolp obj) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol obj) - (emit 'getstatic class name +lisp-symbol+)) + (emit-load-symbol obj) (emit-move-from-stack target representation)) ((listp obj) (let ((g (if *file-compilation* @@ -5267,10 +5262,7 @@ (declare-function name) +lisp-object+) (emit-move-from-stack target)) (t - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+)) + (emit-load-symbol name) (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" nil +lisp-object+) (emit-move-from-stack target)))) @@ -5309,10 +5301,7 @@ (declare-object (fdefinition name)) +lisp-object+) (emit-move-from-stack target)) (t - (multiple-value-bind - (name class) - (lookup-or-declare-symbol (cadr name)) - (emit 'getstatic class name +lisp-symbol+)) + (emit-load-symbol (cadr name)) (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" nil +lisp-object+) @@ -7525,10 +7514,7 @@ (eq (variable-compiland variable) *current-compiland*) (not (enclosed-by-runtime-bindings-creating-block-p (variable-block variable)))) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+))) + (emit-load-symbol name)) (cond ((constantp name) ;; "... a reference to a symbol declared with DEFCONSTANT always ;; refers to its global value." @@ -7631,19 +7617,13 @@ ;; (push thing *special*) => (setq *special* (cons thing *special*)) ;; (format t "compiling pushSpecial~%") (emit-push-current-thread) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+)) + (emit-load-symbol name) (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) (emit-invokevirtual +lisp-thread-class+ "pushSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-object+)) (t (emit-push-current-thread) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol name) - (emit 'getstatic class name +lisp-symbol+)) + (emit-load-symbol name) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+))) @@ -8128,10 +8108,7 @@ (:boolean (emit 'iconst_1)) ((nil) - (multiple-value-bind - (name class) - (lookup-or-declare-symbol form) - (emit 'getstatic class name +lisp-symbol+)))) + (emit-load-symbol form))) (emit-move-from-stack target representation)) (t ;; Shouldn't happen. From ehuelsmann at common-lisp.net Sun May 16 20:56:33 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 16 May 2010 16:56:33 -0400 Subject: [armedbear-cvs] r12693 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 16 16:56:32 2010 New Revision: 12693 Log: Fix reader dispatch macro functions defined in Lisp, trying to return no values (ie: (VALUES)). Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sun May 16 16:56:32 2010 @@ -735,20 +735,21 @@ final LispThread thread = LispThread.currentThread(); final Readtable rt = rta.rt(thread); LispObject fun = rt.getDispatchMacroCharacter(dispChar, c); - if (fun instanceof DispatchMacroFunction) - return ((DispatchMacroFunction)fun).execute(this, c, numArg); if (fun != NIL) { - LispObject result = - thread.execute(fun, this, LispCharacter.getInstance(c), - (numArg < 0) ? NIL : Fixnum.getInstance(numArg)); - LispObject[] values = thread._values; - if (values != null && values.length == 0) - result = null; + LispObject result; + thread._values = null; - return result; + if (fun instanceof DispatchMacroFunction) + return ((DispatchMacroFunction)fun).execute(this, c, numArg); + else + return + thread.execute(fun, this, LispCharacter.getInstance(c), + (numArg < 0) ? NIL : Fixnum.getInstance(numArg)); } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) return null; + return error(new ReaderError("No dispatch function defined for #\\" + c, this)); } From astalla at common-lisp.net Sun May 16 21:13:13 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 16 May 2010 17:13:13 -0400 Subject: [armedbear-cvs] r12694 - branches/0.20.x/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sun May 16 17:13:12 2010 New Revision: 12694 Log: Backported r12693 to 0.20 branch Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Stream.java Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/0.20.x/abcl/src/org/armedbear/lisp/Stream.java (original) +++ branches/0.20.x/abcl/src/org/armedbear/lisp/Stream.java Sun May 16 17:13:12 2010 @@ -735,20 +735,21 @@ final LispThread thread = LispThread.currentThread(); final Readtable rt = rta.rt(thread); LispObject fun = rt.getDispatchMacroCharacter(dispChar, c); - if (fun instanceof DispatchMacroFunction) - return ((DispatchMacroFunction)fun).execute(this, c, numArg); if (fun != NIL) { - LispObject result = - thread.execute(fun, this, LispCharacter.getInstance(c), - (numArg < 0) ? NIL : Fixnum.getInstance(numArg)); - LispObject[] values = thread._values; - if (values != null && values.length == 0) - result = null; + LispObject result; + thread._values = null; - return result; + if (fun instanceof DispatchMacroFunction) + return ((DispatchMacroFunction)fun).execute(this, c, numArg); + else + return + thread.execute(fun, this, LispCharacter.getInstance(c), + (numArg < 0) ? NIL : Fixnum.getInstance(numArg)); } + if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) return null; + return error(new ReaderError("No dispatch function defined for #\\" + c, this)); } From mevenson at common-lisp.net Mon May 17 17:27:29 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 17 May 2010 13:27:29 -0400 Subject: [armedbear-cvs] r12695 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 17 13:27:28 2010 New Revision: 12695 Log: Change messages from trace to warn for failing InputStream. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon May 17 13:27:28 2010 @@ -2102,13 +2102,13 @@ if (entry == null) { Debug.trace("Failed to get InputStream for " + "'" + getNamestring() + "'"); - + // XXX should this be fatal? Debug.assertTrue(false); } try { result = jarFile.getInputStream(entry); } catch (IOException e) { - Debug.trace("Failed to get InputStream from " + Debug.warn("Failed to get InputStream from " + "'" + getNamestring() + "'" + ": " + e); } @@ -2118,7 +2118,7 @@ try { result = url.openStream(); } catch (IOException e) { - Debug.trace("Failed to get InputStream from " + Debug.warn("Failed to get InputStream from " + "'" + getNamestring() + "'" + ": " + e); } @@ -2127,7 +2127,7 @@ try { result = new FileInputStream(file); } catch (IOException e) { - Debug.trace("Failed to get InputStream from " + Debug.warn("Failed to get InputStream from " + "'" + getNamestring() + "'" + ": " + e); } From mevenson at common-lisp.net Mon May 17 17:27:56 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 17 May 2010 13:27:56 -0400 Subject: [armedbear-cvs] r12696 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 17 13:27:55 2010 New Revision: 12696 Log: TRUENAME for URL-PATHNAME ambigiously either a directory or file now (mostly) normalizes to the directory. If there is no type, query or fragment in a URL-PATHNAME passed to TRUENAME, it contains a NAME compoment, there is a resource accessible (via java.net.URL.openConnection()), and there is a resource similarly accessible via appending a "/" to the namestring, we return a pathname that refers to the latter resource. We do this to overcome the bug that autoloading ABCL from a *LISP-HOME* that is a URL-PATHNAME fails for calls such as (autoload 'jclass-fields "java") as Load.findLoadableFile() returns a pathname for which java.net.URL actually opens "<*LISP-HOME*>/java/". There is no way from the java.net.URL implementation to determine that this is a directory without reading from the stream. The more correct solution would be to program a restart which if the load fails it would retry with another possible URL, but we hope that this heuristic will cover the vast majority of usage as providers of URL references used as a filesystem usually avoid such ambiguous references. Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java Modified: trunk/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Pathname.java Mon May 17 13:27:55 2010 @@ -355,12 +355,11 @@ return; } Debug.assertTrue(scheme != null); - // String authority = url.getAuthority(); URI uri = null; try { uri = url.toURI().normalize(); } catch (URISyntaxException e) { - error(new LispError("Could not URI escape characters in " + error(new LispError("Could form URI from " + "'" + url + "'" + " because: " + e)); } @@ -1977,7 +1976,18 @@ } } else if (pathname.isURL()) { if (pathname.getInputStream() != null) { - return pathname; + // If there is no type, query or fragment, we check to + // see if there is URL available "underneath". + if (pathname.name != NIL + && pathname.type == NIL + && Symbol.GETF.execute(pathname.host, QUERY, NIL) == NIL + && Symbol.GETF.execute(pathname.host, FRAGMENT, NIL) == NIL) { + Pathname p = new Pathname(pathname.getNamestring() + "/"); + if (p.getInputStream() != null) { + return p; + } + } + return pathname; } } else jarfile: { From mevenson at common-lisp.net Mon May 17 18:33:13 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 17 May 2010 14:33:13 -0400 Subject: [armedbear-cvs] r12697 - branches/0.20.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon May 17 14:33:12 2010 New Revision: 12697 Log: Backport r12695: Change messages from trace to warn for failing InputStream. Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java Mon May 17 14:33:12 2010 @@ -2102,13 +2102,13 @@ if (entry == null) { Debug.trace("Failed to get InputStream for " + "'" + getNamestring() + "'"); - + // XXX should this be fatal? Debug.assertTrue(false); } try { result = jarFile.getInputStream(entry); } catch (IOException e) { - Debug.trace("Failed to get InputStream from " + Debug.warn("Failed to get InputStream from " + "'" + getNamestring() + "'" + ": " + e); } @@ -2118,7 +2118,7 @@ try { result = url.openStream(); } catch (IOException e) { - Debug.trace("Failed to get InputStream from " + Debug.warn("Failed to get InputStream from " + "'" + getNamestring() + "'" + ": " + e); } @@ -2127,7 +2127,7 @@ try { result = new FileInputStream(file); } catch (IOException e) { - Debug.trace("Failed to get InputStream from " + Debug.warn("Failed to get InputStream from " + "'" + getNamestring() + "'" + ": " + e); } From astalla at common-lisp.net Mon May 17 18:53:43 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 17 May 2010 14:53:43 -0400 Subject: [armedbear-cvs] r12698 - branches/less-reflection/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon May 17 14:53:41 2010 New Revision: 12698 Log: Load class bytes on demand for disassemble. Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/FaslClassLoader.java Mon May 17 14:53:41 2010 @@ -59,8 +59,7 @@ protected Class findClass(String name) throws ClassNotFoundException { try { - Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); - byte[] b = readFunctionBytes(pathname); + byte[] b = getFunctionClassBytes(name); return defineClass(name, b, 0, b.length); } catch(Throwable e) { //TODO handle this better, readFunctionBytes uses Debug.assert() but should return null e.printStackTrace(); @@ -69,6 +68,21 @@ } } + public byte[] getFunctionClassBytes(String name) { + Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); + return readFunctionBytes(pathname); + } + + public byte[] getFunctionClassBytes(Class functionClass) { + return getFunctionClassBytes(functionClass.getName()); + } + + public byte[] getFunctionClassBytes(Function f) { + byte[] b = getFunctionClassBytes(f.getClass()); + f.setClassBytes(b); + return b; + } + public LispObject loadFunction(int fnNumber) { try { //Function name is fnIndex + 1 Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/Function.java Mon May 17 14:53:41 2010 @@ -175,6 +175,34 @@ new JavaObject(bytes)); } + public final LispObject getClassBytes() { + LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL); + if(o != NIL) { + return o; + } else { + ClassLoader c = getClass().getClassLoader(); + if(c instanceof FaslClassLoader) { + return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); + } else { + return NIL; + } + } + } + + public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes(); + public static final class pf_function_class_bytes extends Primitive { + public pf_function_class_bytes() { + super("function-class-bytes", PACKAGE_SYS, false, "function"); + } + @Override + public LispObject execute(LispObject arg) { + if (arg instanceof Function) { + return ((Function) arg).getClassBytes(); + } + return type_error(arg, Symbol.FUNCTION); + } + } + @Override public LispObject execute() { Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Mon May 17 14:53:41 2010 @@ -615,42 +615,7 @@ (%stream-terpri out) (when (> *class-number* 0) - (let* ((basename (base-classname)) - (expr `(lambda (fasl-loader fn-index) - (identity fasl-loader) ;;to avoid unused arg - ;;Ugly: should export & import JVM:: symbols - (ecase fn-index - ,@(loop - :for i :from 1 :to *class-number* - :collect - (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) - `(,(1- i) - (jvm::with-inline-code () - (jvm::emit 'jvm::aload 1) - (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" - nil jvm::+java-object+) - (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") - (jvm::emit 'jvm::dup) - (jvm::emit-push-constant-int ,(1- i)) - (jvm::emit 'jvm::new ,class) - (jvm::emit 'jvm::dup) - (jvm::emit-invokespecial-init ,class '()) - (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" - (list "I" jvm::+lisp-object+) jvm::+lisp-object+) - (jvm::emit 'jvm::pop)) - t)))))) - (classname (fasl-loader-classname)) - (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") - *output-file-pathname*)))) - (jvm::with-saved-compiler-policy - (jvm::with-file-compilation - (with-open-file - (f classfile - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (jvm:compile-defun nil expr nil - classfile f nil))))) + (generate-loader-function) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader ,*class-number* @@ -700,6 +665,43 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) +(defun generate-loader-function () + (let* ((basename (base-classname)) + (expr `(lambda (fasl-loader fn-index) + (identity fasl-loader) ;;to avoid unused arg + (ecase fn-index + ,@(loop + :for i :from 1 :to *class-number* + :collect + (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) + `(,(1- i) + (jvm::with-inline-code () + (jvm::emit 'jvm::aload 1) + (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" + nil jvm::+java-object+) + (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") + (jvm::emit 'jvm::dup) + (jvm::emit-push-constant-int ,(1- i)) + (jvm::emit 'jvm::new ,class) + (jvm::emit 'jvm::dup) + (jvm::emit-invokespecial-init ,class '()) + (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" + (list "I" jvm::+lisp-object+) jvm::+lisp-object+) + (jvm::emit 'jvm::pop)) + t)))))) + (classname (fasl-loader-classname)) + (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") + *output-file-pathname*)))) + (jvm::with-saved-compiler-policy + (jvm::with-file-compilation + (with-open-file + (f classfile + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (jvm:compile-defun nil expr nil + classfile f nil)))))) + (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/disassemble.lisp Mon May 17 14:53:41 2010 @@ -47,14 +47,15 @@ (when (functionp function) (unless (compiled-function-p function) (setf function (compile nil function))) - (when (getf (function-plist function) 'class-bytes) - (with-input-from-string - (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes))) - (loop - (let ((line (read-line stream nil))) - (unless line (return)) - (write-string "; ") - (write-string line) - (terpri)))) - (return-from disassemble))) - (%format t "; Disassembly is not available.~%"))) + (let ((class-bytes (function-class-bytes function))) + (when class-bytes + (with-input-from-string + (stream (disassemble-class-bytes class-bytes)) + (loop + (let ((line (read-line stream nil))) + (unless line (return)) + (write-string "; ") + (write-string line) + (terpri)))) + (return-from disassemble))) + (%format t "; Disassembly is not available.~%")))) From ehuelsmann at common-lisp.net Mon May 17 20:33:30 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 17 May 2010 16:33:30 -0400 Subject: [armedbear-cvs] r12699 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 17 16:33:29 2010 New Revision: 12699 Log: Refactor EXTERNALIZE-OBJECT into EMIT-LOAD-EXTERNALIZED-OBJECT. In order to be able to do so, integrate DECLARE-SYMBOL into its only call site: DECLARE-FUNCTION. Simplify COMPILE-CONSTANT now that the commonalities between the different COND branches is apparent. 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 May 17 16:33:29 2010 @@ -2072,8 +2072,8 @@ ;; This way, the serialize-* functions can be used to depend on ;; each other to serialize nested constructs. They are also the -;; building blocks of the EXTERNALIZE-OBJECT function, which is -;; called from the compiler. +;; building blocks of the EMIT-LOAD-EXTERNALIZED-OBJECT function, +;; which is called from the compiler. (defun serialize-integer (n) "Generates code to restore a serialized integer." @@ -2180,8 +2180,8 @@ 4. The function to dispatch serialization to 5. The type of the field to save the serialized result to") -(defknown externalize-object (t) string) -(defun externalize-object (object) +(defknown emit-load-externalized-object (t) string) +(defun emit-load-externalized-object (object &optional cast) "Externalizes `object' for use in a FASL. Returns the name of the field (in `*this-class*') from which @@ -2205,7 +2205,10 @@ (declare (ignore type)) ;; the type has been used in the selection process (let ((existing (assoc object *externalized-objects* :test similarity-fn))) (when existing - (return-from externalize-object (cdr existing)))) + (emit 'getstatic *this-class* (cdr existing) field-type) + (when cast + (emit 'checkcast cast)) + (return-from emit-load-externalized-object field-type))) ;; We need to set up the serialized value (let ((field-name (symbol-name (gensym prefix)))) @@ -2221,15 +2224,10 @@ (emit 'putstatic *this-class* field-name field-type) (setf *static-code* *code*))) - field-name))) - -(defknown declare-symbol (symbol) string) -(defun declare-symbol (symbol) - (cond - ((and (not *file-compilation*) - (null (symbol-package symbol))) - (declare-object symbol +lisp-symbol+ +lisp-symbol-class+)) - (t (externalize-object symbol)))) + (emit 'getstatic *this-class* field-name field-type) + (when cast + (emit 'checkcast cast)) + field-type))) (defun emit-load-symbol (symbol) "Loads a symbol, optionally after externalizing it." @@ -2238,7 +2236,7 @@ (lookup-known-symbol symbol) (if name (emit 'getstatic class name +lisp-symbol+) - (emit 'getstatic *this-class* (declare-symbol symbol) +lisp-symbol+)))) + (emit-load-externalized-object symbol)))) (defknown declare-function (symbol &optional setf) string) (defun declare-function (symbol &optional setf) @@ -2259,11 +2257,17 @@ ;; selects between *code* and *static-code*, while ;; EMIT-LOAD-SYMBOL wants to modify those specials too (unless name - (setf name (declare-symbol symbol) + (setf name (if *file-compilation* + (declare-object-as-string symbol) + (declare-object symbol)) class *this-class*)) (let (saved-code) (let ((*code* (if *declare-inline* *code* *static-code*))) - (emit 'getstatic class name +lisp-symbol+) + (if (eq class *this-class*) + (progn ;; generated by the DECLARE-OBJECT*'s above + (emit 'getstatic class name +lisp-object+) + (emit 'checkcast +lisp-symbol-class+)) + (emit 'getstatic class name +lisp-symbol+)) (emit-invokevirtual +lisp-symbol-class+ (if setf "getSymbolSetfFunctionOrDie" @@ -2306,12 +2310,12 @@ (defknown declare-object-as-string (t) string) (defun declare-object-as-string (obj) - ;; TODO: replace with externalize-object + ;; TODO: replace with emit-load-externalized-object ;; just replacing won't work however: ;; field identification in Java includes the field type ;; and we're not letting the caller know about the type of - ;; field we're creating in externalize-object. - ;; The solution is te rewrite externalize-object to + ;; field we're creating in emit-load-externalized-object. + ;; The solution is to rewrite externalize-object to ;; EMIT-LOAD-EXTERNALIZED-OBJECT, which serializes *and* ;; emits the right loading code (not just de-serialization anymore) (let (saved-code @@ -2432,8 +2436,7 @@ (cond ((fixnump form) (emit-push-constant-int form)) ((integerp form) - (emit 'getstatic *this-class* (externalize-object form) - +lisp-integer+) + (emit-load-externalized-object form) (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")) (t (sys::%format t "compile-constant int representation~%") @@ -2444,8 +2447,7 @@ (cond ((<= most-negative-java-long form most-positive-java-long) (emit-push-constant-long form)) ((integerp form) - (emit 'getstatic *this-class* (externalize-object form) - +lisp-integer+) + (emit-load-externalized-object form) (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")) (t (sys::%format t "compile-constant long representation~%") @@ -2489,47 +2491,23 @@ (emit-move-from-stack target representation) (return-from compile-constant)) ((NIL))) - (cond ((integerp form) - (emit 'getstatic *this-class* (externalize-object form) - +lisp-integer+)) - ((typep form 'single-float) - (emit 'getstatic *this-class* - (externalize-object form) +lisp-single-float+)) - ((typep form 'double-float) - (emit 'getstatic *this-class* - (externalize-object form) +lisp-double-float+)) - ((numberp form) - ;; A number, but not a fixnum. - (emit 'getstatic *this-class* - (declare-object-as-string form) +lisp-object+)) - ((stringp form) + (cond ((or (numberp form) + (typep form 'single-float) + (typep form 'double-float) + (characterp form)) + (emit-load-externalized-object form)) + ((or (stringp form) + (packagep form) + (pathnamep form) + (vectorp form)) (if *file-compilation* - (emit 'getstatic *this-class* - (externalize-object form) +lisp-simple-string+) + (emit-load-externalized-object form) (emit 'getstatic *this-class* (declare-object form) +lisp-object+))) - ((vectorp form) - (if *file-compilation* - (emit 'getstatic *this-class* - (declare-object-as-string form) +lisp-object+) - (emit 'getstatic *this-class* - (declare-object form) +lisp-object+))) - ((characterp form) - (emit 'getstatic *this-class* - (externalize-object form) +lisp-character+)) - ((or (hash-table-p form) (typep form 'generic-function)) + ((or (hash-table-p form) + (typep form 'generic-function)) (emit 'getstatic *this-class* (declare-object form) +lisp-object+)) - ((pathnamep form) - (let ((g (if *file-compilation* - (declare-object-as-string form) - (declare-object form)))) - (emit 'getstatic *this-class* g +lisp-object+))) - ((packagep form) - (let ((g (if *file-compilation* - (externalize-object form) - (declare-object form)))) - (emit 'getstatic *this-class* g +lisp-object+))) ((or (structure-object-p form) (standard-object-p form) (java:java-object-p form)) From mevenson at common-lisp.net Tue May 18 05:17:10 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 18 May 2010 01:17:10 -0400 Subject: [armedbear-cvs] r12700 - branches/0.20.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue May 18 01:17:07 2010 New Revision: 12700 Log: Backport r12696: TRUENAME for URL-PATHNAME ambigiously either a directory or file now (mostly) normalizes to the directory. If there is no type, query or fragment in a URL-PATHNAME passed to TRUENAME, it contains a NAME compoment, there is a resource accessible (via java.net.URL.openConnection()), and there is a resource similarly accessible via appending a "/" to the namestring, we return a pathname that refers to the latter resource. We do this to overcome the bug that autoloading ABCL from a *LISP-HOME* that is a URL-PATHNAME fails for calls such as (autoload 'jclass-fields "java") as Load.findLoadableFile() returns a pathname for which java.net.URL actually opens "<*LISP-HOME*>/java/". There is no way from the java.net.URL implementation to determine that this is a directory without reading from the stream. The more correct solution would be to program a restart which if the load fails it would retry with another possible URL, but we hope that this heuristic will cover the vast majority of usage as providers of URL references used as a filesystem usually avoid such ambiguous references. Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java (original) +++ branches/0.20.x/abcl/src/org/armedbear/lisp/Pathname.java Tue May 18 01:17:07 2010 @@ -355,7 +355,15 @@ return; } Debug.assertTrue(scheme != null); - String authority = url.getAuthority(); + URI uri = null; + try { + uri = url.toURI().normalize(); + } catch (URISyntaxException e) { + error(new LispError("Could not form URI from " + + "'" + url + "'" + + " because: " + e)); + } + String authority = uri.getAuthority(); Debug.assertTrue(authority != null); host = NIL; @@ -367,15 +375,6 @@ device = NIL; // URI encode necessary characters - URI uri = null; - try { - uri = url.toURI().normalize(); - } catch (URISyntaxException e) { - error(new LispError("Could not URI escape characters in " - + "'" + url + "'" - + " because: " + e)); - } - String path = uri.getRawPath(); if (path == null) { path = ""; @@ -1977,7 +1976,18 @@ } } else if (pathname.isURL()) { if (pathname.getInputStream() != null) { - return pathname; + // If there is no type, query or fragment, we check to + // see if there is URL available "underneath". + if (pathname.name != NIL + && pathname.type == NIL + && Symbol.GETF.execute(pathname.host, QUERY, NIL) == NIL + && Symbol.GETF.execute(pathname.host, FRAGMENT, NIL) == NIL) { + Pathname p = new Pathname(pathname.getNamestring() + "/"); + if (p.getInputStream() != null) { + return p; + } + } + return pathname; } } else jarfile: { From ehuelsmann at common-lisp.net Tue May 18 19:38:34 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 May 2010 15:38:34 -0400 Subject: [armedbear-cvs] r12701 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 18 15:38:30 2010 New Revision: 12701 Log: Fix weird indenting. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Tue May 18 15:38:30 2010 @@ -848,8 +848,7 @@ return error(new ReaderError("Can't read #. when *READ-EVAL* is NIL.", this)); else - return eval(read(true, NIL, true, thread, - rta), + return eval(read(true, NIL, true, thread, rta), new Environment(), thread); } From ehuelsmann at common-lisp.net Tue May 18 21:44:12 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 May 2010 17:44:12 -0400 Subject: [armedbear-cvs] r12702 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 18 17:44:11 2010 New Revision: 12702 Log: Merge DECLARE-OBJECT functionality ("serialization" of objects for in-memory [non compile-file] compilation) into EMIT-LOAD-EXTERNALIZED-OBJECT. 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 May 18 17:44:11 2010 @@ -234,6 +234,7 @@ (defconstant +lisp-abstract-bit-vector-class+ "org/armedbear/lisp/AbstractBitVector") (defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector") (defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString") +(defconstant +lisp-abstract-string+ "Lorg/armedbear/lisp/AbstractString;") (defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector") (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString") (defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;") @@ -2168,7 +2169,8 @@ (character "CHR" ,#'eql ,#'serialize-character ,+lisp-character+) (single-float "FLT" ,#'eql ,#'serialize-float ,+lisp-single-float+) (double-float "DBL" ,#'eql ,#'serialize-double ,+lisp-double-float+) - (string "STR" ,#'equal ,#'serialize-string ,+lisp-simple-string+) + (string "STR" ,#'equal ,#'serialize-string + ,+lisp-abstract-string+) ;; because of (not compile-file) (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+) (symbol "SYM" ,#'eq ,#'serialize-symbol ,+lisp-symbol+) (T "OBJ" ,#'eq ,#'serialize-object ,+lisp-object+)) @@ -2203,6 +2205,8 @@ (typep object x)) serialization-table) (declare (ignore type)) ;; the type has been used in the selection process + (when (not *file-compilation*) ;; in-memory compilation wants object EQ-ness + (setf similarity-fn #'eq)) (let ((existing (assoc object *externalized-objects* :test similarity-fn))) (when existing (emit 'getstatic *this-class* (cdr existing) field-type) @@ -2215,14 +2219,25 @@ (declare-field field-name field-type +field-access-private+) (push (cons object field-name) *externalized-objects*) - (if *declare-inline* - (progn - (funcall dispatch-fn object) - (emit 'putstatic *this-class* field-name field-type)) - (let ((*code* *static-code*)) - (funcall dispatch-fn object) - (emit 'putstatic *this-class* field-name field-type) - (setf *static-code* *code*))) + (cond + ((not *file-compilation*) + (let ((*code* *static-code*)) + (remember field-name object) + (emit 'ldc (pool-string field-name)) + (emit-invokestatic +lisp-class+ "recall" + (list +java-string+) +lisp-object+) + (when (string/= field-type +lisp-object+) + (emit 'checkcast (subseq field-type 1 (1- (length field-type))))) + (emit 'putstatic *this-class* field-name field-type) + (setf *static-code* *code*))) + (*declare-inline* + (funcall dispatch-fn object) + (emit 'putstatic *this-class* field-name field-type)) + (t ;; *file-compilation* and (not *declare-inline*) + (let ((*code* *static-code*)) + (funcall dispatch-fn object) + (emit 'putstatic *this-class* field-name field-type) + (setf *static-code* *code*)))) (emit 'getstatic *this-class* field-name field-type) (when cast @@ -2494,16 +2509,17 @@ (cond ((or (numberp form) (typep form 'single-float) (typep form 'double-float) - (characterp form)) + (characterp form) + (stringp form) + (packagep form) + (pathnamep form) + (vectorp form)) (emit-load-externalized-object form)) ((or (stringp form) (packagep form) (pathnamep form) (vectorp form)) - (if *file-compilation* - (emit-load-externalized-object form) - (emit 'getstatic *this-class* - (declare-object form) +lisp-object+))) + (emit-load-externalized-object form)) ((or (hash-table-p form) (typep form 'generic-function)) (emit 'getstatic *this-class* @@ -2518,8 +2534,7 @@ (t (if *file-compilation* (error "COMPILE-CONSTANT unhandled case ~S" form) - (emit 'getstatic *this-class* - (declare-object form) +lisp-object+)))) + (emit-load-externalized-object form)))) (emit-move-from-stack target representation)) (defparameter *unary-operators* nil) @@ -3173,14 +3188,10 @@ ((local-function-environment local-function) (assert (local-function-references-allowed-p local-function)) (assert (not *file-compilation*)) - (emit 'getstatic *this-class* - (declare-object (local-function-environment local-function) - +lisp-environment+ - +lisp-environment-class+) - +lisp-environment+) - (emit 'getstatic *this-class* - (declare-object (local-function-name local-function)) - +lisp-object+) + (emit-load-externalized-object + (local-function-environmont local-function) + +lisp-environment-class+) + (emit-load-externalized-object (local-function-name local-function)) (emit-invokevirtual +lisp-environment-class+ "lookupFunction" (list +lisp-object+) +lisp-object+)) @@ -4355,11 +4366,8 @@ (emit 'putfield +closure-binding-class+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) - (emit 'getstatic *this-class* - (declare-object (variable-environment variable) - +lisp-environment+ - +lisp-environment-class+) - +lisp-environment+) + (emit-load-externalized-object (variable-environment variable) + +lisp-environment-class+) (emit 'swap) (emit-push-variable-name variable) (emit 'swap) @@ -4390,11 +4398,8 @@ (emit 'getfield +closure-binding-class+ "value" +lisp-object+)) ((variable-environment variable) (assert (not *file-compilation*)) - (emit 'getstatic *this-class* - (declare-object (variable-environment variable) - +lisp-environment+ - +lisp-environment-class+) - +lisp-environment+) + (emit-load-externalized-object (variable-environment variable) + +lisp-environment-class+) (emit-push-variable-name variable) (emit-invokevirtual +lisp-environment-class+ "lookup" (list +lisp-object+) @@ -4662,11 +4667,7 @@ (dolist (tag (remove-if-not #'tag-used-non-locally (tagbody-tags block))) (aload tag-register) - (emit 'getstatic *this-class* - (if *file-compilation* - (declare-object-as-string (tag-label tag)) - (declare-object (tag-label tag))) - +lisp-object+) + (emit-load-externalized-object (tag-label tag)) ;; Jump if EQ. (emit 'if_acmpeq (tag-label tag))) (label RETHROW) @@ -4724,11 +4725,7 @@ (return-from p2-go)) ;; Non-local GO. (emit-push-variable (tagbody-id-variable tag-block)) - (emit 'getstatic *this-class* - (if *file-compilation* - (declare-object-as-string (tag-label tag)) - (declare-object (tag-label tag))) - +lisp-object+) ; Tag. + (emit-load-externalized-object (tag-label tag)) ; Tag. (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2) +lisp-object+) ;; Following code will not be reached, but is needed for JVM stack @@ -4898,11 +4895,7 @@ ;; Non-local RETURN. (aver (block-non-local-return-p block)) (emit-push-variable (block-id-variable block)) - (emit 'getstatic *this-class* - (if *file-compilation* - (declare-object-as-string (block-name block)) - (declare-object (block-name block))) - +lisp-object+) + (emit-load-externalized-object (block-name block)) (emit-clear-values) (compile-form result-form 'stack nil) (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3) @@ -5003,11 +4996,8 @@ (emit-load-symbol obj) (emit-move-from-stack target representation)) ((listp obj) - (let ((g (if *file-compilation* - (declare-object-as-string obj) - (declare-object obj)))) - (emit 'getstatic *this-class* g +lisp-object+) - (emit-move-from-stack target representation))) + (emit-load-externalized-object obj) + (emit-move-from-stack target representation)) ((constantp obj) (compile-constant obj target representation)) (t @@ -5187,10 +5177,8 @@ (with-open-stream (stream (sys::%make-byte-array-output-stream)) (compile-and-write-to-stream (compiland-class-file compiland) compiland stream) - (emit 'getstatic *this-class* - (declare-object (load-compiled-function - (sys::%get-output-stream-bytes stream))) - +lisp-object+)))) + (emit-load-externalized-object (load-compiled-function + (sys::%get-output-stream-bytes stream)))))) (cond ((null *closure-variables*)) ; Nothing to do. ((compiland-closure-register *current-compiland*) (duplicate-closure-array *current-compiland*) @@ -5275,8 +5263,7 @@ ((and (null *file-compilation*) (fboundp name) (fdefinition name)) - (emit 'getstatic *this-class* - (declare-object (fdefinition name)) +lisp-object+) + (emit-load-externalized-object (fdefinition name)) (emit-move-from-stack target)) (t (emit-load-symbol (cadr name)) From ehuelsmann at common-lisp.net Tue May 18 21:47:19 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 May 2010 17:47:19 -0400 Subject: [armedbear-cvs] r12703 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 18 17:47:19 2010 New Revision: 12703 Log: DECLARE-OBJECT of non-serializable data (hashtable and generic methods) is handled by the T clause of the COND statement already (including a check for (not *file-compilation*). 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 May 18 17:47:19 2010 @@ -2520,10 +2520,6 @@ (pathnamep form) (vectorp form)) (emit-load-externalized-object form)) - ((or (hash-table-p form) - (typep form 'generic-function)) - (emit 'getstatic *this-class* - (declare-object form) +lisp-object+)) ((or (structure-object-p form) (standard-object-p form) (java:java-object-p form)) From ehuelsmann at common-lisp.net Tue May 18 21:48:43 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 May 2010 17:48:43 -0400 Subject: [armedbear-cvs] r12704 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 18 17:48:42 2010 New Revision: 12704 Log: Fix typo. 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 May 18 17:48:42 2010 @@ -3185,7 +3185,7 @@ (assert (local-function-references-allowed-p local-function)) (assert (not *file-compilation*)) (emit-load-externalized-object - (local-function-environmont local-function) + (local-function-environment local-function) +lisp-environment-class+) (emit-load-externalized-object (local-function-name local-function)) (emit-invokevirtual +lisp-environment-class+ "lookupFunction" From ehuelsmann at common-lisp.net Tue May 18 22:30:54 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 May 2010 18:30:54 -0400 Subject: [armedbear-cvs] r12705 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 18 18:30:53 2010 New Revision: 12705 Log: Eliminate DECLARE-INSTANCE as it has the same effect as DECLARE-OBJECT-AS-STRING; which is in the process of being replaced by EMIT-LOAD-EXTERNALIZED-OBJECT. 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 May 18 18:30:53 2010 @@ -2373,32 +2373,6 @@ (setf *code* saved-code)) g)) -(defknown declare-instance (t) t) -(defun declare-instance (obj) - (aver (not (null *file-compilation*))) - (aver (or (structure-object-p obj) (standard-object-p obj) - (java:java-object-p obj))) - (let ((g (symbol-name (gensym "INSTANCE"))) - saved-code) - (let* ((s (with-output-to-string (stream) (dump-form obj stream))) - (*code* (if *declare-inline* *code* *static-code*))) - ;; The readObjectFromString call may require evaluation of - ;; lisp code in the string (think #.() syntax), of which the outcome - ;; may depend on something which was declared inline - (declare-field g +lisp-object+ +field-access-private+) - (emit 'ldc (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" - (list +java-string+) +lisp-object+) - (emit-invokestatic +lisp-class+ "loadTimeValue" - (lisp-object-arg-types 1) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*))) - (when *declare-inline* - (setf *code* saved-code)) - g)) - (declaim (ftype (function (t &optional t) string) declare-object)) (defun declare-object (obj &optional (obj-ref +lisp-object+) obj-class) @@ -2523,10 +2497,7 @@ ((or (structure-object-p form) (standard-object-p form) (java:java-object-p form)) - (let ((g (if *file-compilation* - (declare-instance form) - (declare-object form)))) - (emit 'getstatic *this-class* g +lisp-object+))) + (emit-load-externalized-object form)) (t (if *file-compilation* (error "COMPILE-CONSTANT unhandled case ~S" form) From astalla at common-lisp.net Tue May 18 22:39:44 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 18 May 2010 18:39:44 -0400 Subject: [armedbear-cvs] r12706 - branches/less-reflection/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue May 18 18:39:43 2010 New Revision: 12706 Log: Split potentially huge CASE in the fasl-loader in multiple smaller sub-CASEs to avoid stack overflow in the precompiler for big FASLs. Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Modified: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp ============================================================================== --- branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp (original) +++ branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp Tue May 18 18:39:43 2010 @@ -665,11 +665,23 @@ (namestring output-file) elapsed)))) (values (truename output-file) warnings-p failure-p))) +(defmacro ncase (expr min max &rest clauses) + "A CASE where all test clauses are numbers ranging from a minimum to a maximum." + ;;Expr is subject to multiple evaluation, but since we only use ncase for + ;;fn-index below, let's ignore it. + (let* ((half (floor (/ (- max min) 2))) + (middle (+ min half))) + (if (> (- max min) 10) + `(if (< ,expr ,middle) + (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) + (ncase ,expr ,middle ,max ,@(subseq clauses half))) + `(case ,expr , at clauses)))) + (defun generate-loader-function () (let* ((basename (base-classname)) (expr `(lambda (fasl-loader fn-index) (identity fasl-loader) ;;to avoid unused arg - (ecase fn-index + (ncase fn-index 0 ,(1- *class-number*) ,@(loop :for i :from 1 :to *class-number* :collect From ehuelsmann at common-lisp.net Tue May 18 22:45:33 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Tue, 18 May 2010 18:45:33 -0400 Subject: [armedbear-cvs] r12707 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue May 18 18:45:33 2010 New Revision: 12707 Log: Simplify COMPILE-CONSTANT. 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 May 18 18:45:33 2010 @@ -2487,14 +2487,12 @@ (stringp form) (packagep form) (pathnamep form) - (vectorp form)) - (emit-load-externalized-object form)) - ((or (stringp form) + (vectorp form) + (stringp form) (packagep form) (pathnamep form) - (vectorp form)) - (emit-load-externalized-object form)) - ((or (structure-object-p form) + (vectorp form) + (structure-object-p form) (standard-object-p form) (java:java-object-p form)) (emit-load-externalized-object form)) From ehuelsmann at common-lisp.net Wed May 19 20:02:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 May 2010 16:02:21 -0400 Subject: [armedbear-cvs] r12708 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 19 16:02:19 2010 New Revision: 12708 Log: Remove unused function DECLARE-LAMBDA. 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 Wed May 19 16:02:19 2010 @@ -2394,28 +2394,6 @@ (setf *static-code* *code*) g))) -(defun declare-lambda (obj) - (let (saved-code - (g (symbol-name (gensym "LAMBDA")))) - (let* ((*print-level* nil) - (*print-length* nil) - (s (format nil "~S" obj)) - (*code* (if *declare-inline* *code* *static-code*))) - (declare-field g +lisp-object+ +field-access-private+) - (emit 'ldc - (pool-string s)) - (emit-invokestatic +lisp-class+ "readObjectFromString" - (list +java-string+) +lisp-object+) - (emit-invokestatic +lisp-class+ "coerceToFunction" - (lisp-object-arg-types 1) +lisp-object+) - (emit 'putstatic *this-class* g +lisp-object+) - (if *declare-inline* - (setf saved-code *code*) - (setf *static-code* *code*))) - (when *declare-inline* - (setf *code* saved-code)) - g)) - (defknown compile-constant (t t t) t) (defun compile-constant (form target representation) (unless target From ehuelsmann at common-lisp.net Wed May 19 21:14:04 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 May 2010 17:14:04 -0400 Subject: [armedbear-cvs] r12709 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 19 17:14:03 2010 New Revision: 12709 Log: Merge EMIT-LOAD-SYMBOL into EMIT-LOAD-EXTERNALIZED-OBJECT. 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 Wed May 19 17:14:03 2010 @@ -751,7 +751,7 @@ (emit 'aaload)))) (defun emit-push-variable-name (variable) - (emit-load-symbol (variable-name variable))) + (emit-load-externalized-object (variable-name variable))) (defknown generate-instanceof-type-check-for-variable (t t) t) (defun generate-instanceof-type-check-for-variable (variable expected-type) @@ -2143,26 +2143,31 @@ (defun serialize-symbol (symbol) "Generate code to restore a serialized symbol." - (cond - ((null (symbol-package symbol)) - ;; we need to read the #? syntax for uninterned symbols - - ;; TODO: we could use the byte code variant of - ;; Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(LispThread.currentThread()) - ;; .aref( syntax for uninterned symbols + + ;; TODO: we could use the byte code variant of + ;; Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(LispThread.currentThread()) + ;; .aref( (setq *special* (cons thing *special*)) ;; (format t "compiling pushSpecial~%") (emit-push-current-thread) - (emit-load-symbol name) + (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) (emit-invokevirtual +lisp-thread-class+ "pushSpecial" (list +lisp-symbol+ +lisp-object+) +lisp-object+)) (t (emit-push-current-thread) - (emit-load-symbol name) + (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values value-form 'stack nil) (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" (list +lisp-symbol+ +lisp-object+) +lisp-object+))) @@ -8016,7 +8012,7 @@ (:boolean (emit 'iconst_1)) ((nil) - (emit-load-symbol form))) + (emit-load-externalized-object form))) (emit-move-from-stack target representation)) (t ;; Shouldn't happen. From ehuelsmann at common-lisp.net Wed May 19 22:27:22 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 May 2010 18:27:22 -0400 Subject: [armedbear-cvs] r12710 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 19 18:27:21 2010 New Revision: 12710 Log: Move access to uninterned symbols array to Load.java for future use by the compiler. Modified: trunk/abcl/src/org/armedbear/lisp/FaslReader.java trunk/abcl/src/org/armedbear/lisp/Load.java Modified: trunk/abcl/src/org/armedbear/lisp/FaslReader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/FaslReader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/FaslReader.java Wed May 19 18:27:21 2010 @@ -286,26 +286,7 @@ @Override public LispObject execute(Stream stream, char c, int n) { - LispThread thread = LispThread.currentThread(); - LispObject uninternedSymbols = - Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(thread); - - if (! (uninternedSymbols instanceof Cons)) // it must be a vector - return uninternedSymbols.AREF(n); - - // During normal loading, we won't get to this bit, however, - // with eval-when processing, we may need to fall back to - // *FASL-UNINTERNED-SYMBOLS* being an alist structure - LispObject label = LispInteger.getInstance(n); - while (uninternedSymbols != NIL) - { - LispObject item = uninternedSymbols.car(); - if (label.eql(item.cdr())) - return item.car(); - - uninternedSymbols = uninternedSymbols.cdr(); - } - return error(new LispError("No entry for uninterned symbol.")); + return Load.getUninternedSymbol(n); } }; Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Wed May 19 18:27:21 2010 @@ -380,6 +380,31 @@ public static final Symbol _FASL_UNINTERNED_SYMBOLS_ = internSpecial("*FASL-UNINTERNED-SYMBOLS*", PACKAGE_SYS, NIL); + // Function to access the uninterned symbols "array" + public final static LispObject getUninternedSymbol(int n) { + LispThread thread = LispThread.currentThread(); + LispObject uninternedSymbols = + Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(thread); + + if (! (uninternedSymbols instanceof Cons)) // it must be a vector + return uninternedSymbols.AREF(n); + + // During normal loading, we won't get to this bit, however, + // with eval-when processing, we may need to fall back to + // *FASL-UNINTERNED-SYMBOLS* being an alist structure + LispObject label = LispInteger.getInstance(n); + while (uninternedSymbols != NIL) + { + LispObject item = uninternedSymbols.car(); + if (label.eql(item.cdr())) + return item.car(); + + uninternedSymbols = uninternedSymbols.cdr(); + } + return error(new LispError("No entry for uninterned symbol.")); + } + + // ### init-fasl &key version private static final Primitive INIT_FASL = new init_fasl(); private static class init_fasl extends Primitive { From ehuelsmann at common-lisp.net Wed May 19 22:29:04 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Wed, 19 May 2010 18:29:04 -0400 Subject: [armedbear-cvs] r12711 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed May 19 18:29:03 2010 New Revision: 12711 Log: No longer use the reader to load "stand alone" uninterned symbols, instead, inline calls to the array element 'getter'. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/dump-form.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 Wed May 19 18:29:03 2010 @@ -213,6 +213,7 @@ (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject") (defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread") (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") +(defconstant +lisp-load-class+ "org/armedbear/lisp/Load") (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;") (defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger") @@ -2150,13 +2151,9 @@ (name (emit 'getstatic class name +lisp-symbol+)) ((null (symbol-package symbol)) - ;; we need to read the #? syntax for uninterned symbols - - ;; TODO: we could use the byte code variant of - ;; Load._FASL_UNINTERNED_SYMBOLS_.symbolValue(LispThread.currentThread()) - ;; .aref( Author: mevenson Date: Wed May 19 18:59:02 2010 New Revision: 12712 Log: Fix bug that prevented SHADOWING-IMPORT from being able to be re-invoked with the same symbols. [Alan Ruttenberg reported][1] this error. [1]: http://article.gmane.org/gmane.lisp.armedbear.devel/1200 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 Wed May 19 18:59:02 2010 @@ -592,6 +592,11 @@ if (shadowingSymbols != null) shadowingSymbols.remove(symbolName); unintern(sym); + } else if (where == Keyword.INTERNAL) { + // Assert rgument is already correctly a shadowing import + Debug.assertTrue(shadowingSymbols != null); + Debug.assertTrue(shadowingSymbols.get(symbolName) != null); + return; } } } From astalla at common-lisp.net Thu May 20 17:58:14 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 20 May 2010 13:58:14 -0400 Subject: [armedbear-cvs] r12713 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu May 20 13:58:13 2010 New Revision: 12713 Log: Serialization support for some Lisp types. For symbols and packages, only the "identity" is serialized, i.e. package name + symbol name. For packages, it is expected that a package of the same name exists "at the other side". For symbols, the deserialized symbol is interned in its home package. Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java trunk/abcl/src/org/armedbear/lisp/Cons.java trunk/abcl/src/org/armedbear/lisp/LispInteger.java trunk/abcl/src/org/armedbear/lisp/Nil.java trunk/abcl/src/org/armedbear/lisp/Package.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/AbstractArray.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/AbstractArray.java (original) +++ trunk/abcl/src/org/armedbear/lisp/AbstractArray.java Thu May 20 13:58:13 2010 @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -public abstract class AbstractArray extends LispObject +public abstract class AbstractArray extends LispObject implements java.io.Serializable { @Override public LispObject typep(LispObject type) Modified: trunk/abcl/src/org/armedbear/lisp/Cons.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Cons.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Cons.java Thu May 20 13:58:13 2010 @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -public final class Cons extends LispObject +public final class Cons extends LispObject implements java.io.Serializable { public LispObject car; public LispObject cdr; Modified: trunk/abcl/src/org/armedbear/lisp/LispInteger.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispInteger.java (original) +++ trunk/abcl/src/org/armedbear/lisp/LispInteger.java Thu May 20 13:58:13 2010 @@ -36,7 +36,7 @@ /** This class merely serves as the super class for * Fixnum and Bignum */ -public class LispInteger extends LispObject +public class LispInteger extends LispObject implements java.io.Serializable { public static LispInteger getInstance(long l) { Modified: trunk/abcl/src/org/armedbear/lisp/Nil.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Nil.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Nil.java Thu May 20 13:58:13 2010 @@ -164,4 +164,9 @@ return "|COMMON-LISP|::|NIL|"; return "NIL"; } + + public Object readResolve() throws java.io.ObjectStreamException { + return NIL; + } + } 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 May 20 13:58:13 2010 @@ -40,20 +40,20 @@ import java.util.Iterator; import java.util.List; -public final class Package extends LispObject +public final class Package extends LispObject implements java.io.Serializable { private String name; - private SimpleString lispName; + private transient SimpleString lispName; - private LispObject propertyList; + private transient LispObject propertyList; - private final SymbolHashTable internalSymbols = new SymbolHashTable(16); - private final SymbolHashTable externalSymbols = new SymbolHashTable(16); + private transient final SymbolHashTable internalSymbols = new SymbolHashTable(16); + private transient final SymbolHashTable externalSymbols = new SymbolHashTable(16); - private HashMap shadowingSymbols; - private ArrayList nicknames; - private LispObject useList = null; - private ArrayList usedByList = null; + private transient HashMap shadowingSymbols; + private transient ArrayList nicknames; + private transient LispObject useList = null; + private transient ArrayList usedByList = null; // Anonymous package. public Package() @@ -848,4 +848,13 @@ } else return unreadableString("PACKAGE"); } + + public Object readResolve() throws java.io.ObjectStreamException { + Package pkg = Packages.findPackage(name); + if(pkg != null) { + return pkg; + } else { + return error(new PackageError(name + " is not the name of a package.")); + } + } } 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 May 20 13:58:13 2010 @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -public class Symbol extends LispObject +public class Symbol extends LispObject implements java.io.Serializable { // Bit flags. private static final int FLAG_SPECIAL = 0x0001; @@ -55,11 +55,11 @@ /** To be accessed by LispThread only: * used to find the index in the LispThread.specials array */ - int specialIndex = LispThread.UNASSIGNED_SPECIAL_INDEX; + transient int specialIndex = LispThread.UNASSIGNED_SPECIAL_INDEX; private LispObject pkg; // Either a package object or NIL. - private LispObject value; - private LispObject function; - private LispObject propertyList; + private transient LispObject value; + private transient LispObject function; + private transient LispObject propertyList; private int flags; // Construct an uninterned symbol. @@ -908,6 +908,15 @@ function.incrementHotCount(); } + public Object readResolve() throws java.io.ObjectStreamException { + if(pkg instanceof Package) { + Symbol s = ((Package) pkg).intern(name.getStringValue()); + return s; + } else { + return this; + } + } + // External symbols in CL package. public static final Symbol AND_ALLOW_OTHER_KEYS = From vvoutilainen at common-lisp.net Fri May 21 20:56:00 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Fri, 21 May 2010 16:56:00 -0400 Subject: [armedbear-cvs] r12714 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Fri May 21 16:55:58 2010 New Revision: 12714 Log: Remove commented-out code. 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 May 21 16:55:58 2010 @@ -478,7 +478,6 @@ (defmacro defsubst (name lambda-list &rest body) (let* ((block-name (fdefinition-block-name name)) (expansion (generate-inline-expansion block-name lambda-list body))) -;; (format t "expansion = ~S~%" expansion) `(progn (%defun ',name (lambda ,lambda-list (block ,block-name , at body))) (precompile ',name) @@ -904,8 +903,6 @@ (declare (optimize speed)) (dolist (form forms) (unless (single-valued-p form) -;; (let ((*print-structure* nil)) -;; (format t "Not single-valued: ~S~%" form)) (ensure-thread-var-initialized) (emit 'clear-values) (return)))) @@ -1241,14 +1238,9 @@ ;; ldc2_w (define-resolver 20 (instruction) -;; (format t "resolving ldc2_w...~%") (let* ((args (instruction-args instruction))) -;; (format t "args = ~S~%" args) (unless (= (length args) 1) (error "Wrong number of args for LDC2_W.")) -;; (if (> (car args) 255) -;; (inst 19 (u2 (car args))) ; LDC_W -;; (inst 18 args)))) (inst 20 (u2 (car args))))) ;; getfield, putfield class-name field-name type-name @@ -1298,26 +1290,6 @@ (t (vector-push-extend (resolve-instruction instruction) vector))))))) -;; (defconstant +branch-opcodes+ -;; '(153 ; IFEQ -;; 154 ; IFNE -;; 155 ; IFLT -;; 156 ; IFGE -;; 157 ; IFGT -;; 158 ; IFLE -;; 159 ; IF_ICMPEQ -;; 160 ; IF_ICMPNE -;; 161 ; IF_ICMPLT -;; 162 ; IF_ICMPGE -;; 163 ; IF_ICMPGT -;; 164 ; IF_ICMPLE -;; 165 ; IF_ACMPEQ -;; 166 ; IF_ACMPNE -;; 167 ; GOTO -;; 168 ; JSR -;; 198 ; IFNULL -;; )) - (declaim (ftype (function (t) t) branch-opcode-p)) (declaim (inline branch-opcode-p)) (defun branch-opcode-p (opcode) @@ -1392,11 +1364,6 @@ (instruction-depth (instruction-depth instruction))) (when instruction-depth (setf max-stack (max max-stack (the fixnum instruction-depth)))))) -;; (when *compiler-debug* -;; (sys::%format t "compiland name = ~S~%" (compiland-name *current-compiland*)) -;; (sys::%format t "max-stack = ~D~%" max-stack) -;; (sys::%format t "----- after stack analysis -----~%") -;; (print-code)) max-stack))) @@ -1427,14 +1394,11 @@ (declaim (ftype (function (t) boolean) label-p)) (defun label-p (instruction) -;; (declare (optimize safety)) -;; (declare (type instruction instruction)) (and instruction (= (the fixnum (instruction-opcode (the instruction instruction))) 202))) (declaim (ftype (function (t) t) instruction-label)) (defun instruction-label (instruction) -;; (declare (optimize safety)) (and instruction (= (instruction-opcode (the instruction instruction)) 202) (car (instruction-args instruction)))) @@ -1492,8 +1456,7 @@ ;; unreachable. (setf (aref code j) nil) (setf changed t)) - (;;(equal next-instruction instruction) - (eq (car (instruction-args next-instruction)) + ((eq (car (instruction-args next-instruction)) (car (instruction-args instruction))) ;; We've reached another GOTO to the same destination. ;; We don't need the first GOTO; we can just fall @@ -1938,7 +1901,6 @@ (setf *code* (append *static-code* *code*)) (emit 'return) (finalize-code) - ;;(optimize-code) (setf *code* (resolve-instructions *code*)) (setf (method-max-stack constructor) (analyze-stack)) (setf (method-code constructor) (code-bytes *code*)) @@ -2235,7 +2197,7 @@ (*declare-inline* (funcall dispatch-fn object) (emit 'putstatic *this-class* field-name field-type)) - (t ;; *file-compilation* and (not *declare-inline*) + (t (let ((*code* *static-code*)) (funcall dispatch-fn object) (emit 'putstatic *this-class* field-name field-type) @@ -3044,30 +3006,6 @@ (t form))) -;; (define-source-transform min (&whole form &rest args) -;; (cond ((= (length args) 2) -;; (let* ((arg1 (%car args)) -;; (arg2 (%cadr args)) -;; (sym1 (gensym)) -;; (sym2 (gensym))) -;; `(let ((,sym1 ,arg1) -;; (,sym2 ,arg2)) -;; (if (<= ,sym1 ,sym2) ,sym1 ,sym2)))) -;; (t -;; form))) - -;; (define-source-transform max (&whole form &rest args) -;; (cond ((= (length args) 2) -;; (let* ((arg1 (%car args)) -;; (arg2 (%cadr args)) -;; (sym1 (gensym)) -;; (sym2 (gensym))) -;; `(let ((,sym1 ,arg1) -;; (,sym2 ,arg2)) -;; (if (>= ,sym1 ,sym2) ,sym1 ,sym2)))) -;; (t -;; form))) - (defknown p2-funcall (t t t) t) (defun p2-funcall (form target representation) (unless (> (length form) 1) @@ -3078,9 +3016,6 @@ (return-from p2-funcall (compile-function-call form target representation))) (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil) (compile-call (cddr form)) -;; (case representation -;; (:int (emit-unbox-fixnum)) -;; (:char (emit-unbox-character))) (fix-boxing representation nil) (emit-move-from-stack target)) @@ -3293,7 +3228,6 @@ (defun initialize-p2-test-handlers () (let ((ht (make-hash-table :test 'eq))) (dolist (pair '( -;; (CHAR= p2-test-char=) (/= p2-test-/=) (< p2-test-numeric-comparison) (<= p2-test-numeric-comparison) @@ -3588,11 +3522,9 @@ 'ifeq))))) (defun p2-test-equality (form) -;; (format t "p2-test-equality ~S~%" (%car form)) (when (check-arg-count form 2) (let* ((op (%car form)) (translated-op (ecase op -;; (EQL "eql") (EQUAL "equal") (EQUALP "equalp"))) (arg1 (%cadr form)) @@ -3797,19 +3729,8 @@ (p2-if (list 'IF (%car args) consequent alternate) target representation)) (t (dolist (arg args) -;; (let ((type (derive-compiler-type arg))) -;; (cond -;; ((eq type 'BOOLEAN) (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean) (emit 'ifeq LABEL1) -;; ) -;; (t -;; (compile-form arg 'stack nil) -;; (maybe-emit-clear-values arg) -;; (emit-push-nil) -;; (emit 'if_acmpeq LABEL1)) -;; ) -;; ) ) (compile-form consequent target representation) (emit 'goto LABEL2) @@ -3819,17 +3740,11 @@ (defknown p2-if-not-and (t t t) t) (defun p2-if-not-and (form target representation) -;; (format t "p2-if-not-and~%") -;; (aver (eq (first form) 'IF)) -;; (aver (consp (second form))) -;; (aver (memq (first (second form)) '(NOT NULL))) -;; (aver (eq (first (second (second form))) 'AND)) (let* ((inverted-test (second (second form))) (consequent (third form)) (alternate (fourth form)) (LABEL1 (gensym)) (LABEL2 (gensym))) -;; (aver (and (consp inverted-test) (eq (car inverted-test) 'AND))) (let* ((args (cdr inverted-test))) (case (length args) (0 @@ -4006,7 +3921,6 @@ ;; Generates code to bind variable to value at top of runtime stack. (declaim (ftype (function (t) t) compile-binding)) (defun compile-binding (variable) -;; (dump-1-variable variable) (cond ((variable-register variable) (astore (variable-register variable))) ((variable-special-p variable) @@ -4055,16 +3969,12 @@ (defun restore-dynamic-environment (register) (emit-push-current-thread) (aload register) -;; (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" -;; +lisp-special-binding+) (emit-invokevirtual +lisp-thread-class+ "resetSpecialBindings" (list +lisp-special-bindings-mark+) nil) ) (defun save-dynamic-environment (register) (emit-push-current-thread) -;; (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" -;; +lisp-special-binding+) (emit-invokevirtual +lisp-thread-class+ "markSpecialBindings" nil +lisp-special-bindings-mark+) (astore register) @@ -4575,8 +4485,6 @@ (compile-form subform nil nil) (unless must-clear-values (unless (single-valued-p subform) -;; (let ((*print-structure* nil)) -;; (format t "not single-valued: ~S~%" subform)) (setf must-clear-values t)))))) (label END-BLOCK) (emit 'goto EXIT) @@ -4819,8 +4727,6 @@ ;; inside the block we're returning from? (unless (enclosed-by-protected-block-p block) (unless (compiland-single-valued-p *current-compiland*) -;; (format t "compiland not single-valued: ~S~%" -;; (compiland-name *current-compiland*)) (emit-clear-values)) (compile-form result-form (block-target block) nil) (when (and (block-needs-environment-restoration block) @@ -5225,10 +5131,6 @@ (high2 (and (fixnum-type-p type2) (integer-type-high type2))) (constant-shift (fixnum-constant-value type2)) (result-type (derive-compiler-type form))) -;; (format t "~&p2-ash type1 = ~S~%" type1) -;; (format t "p2-ash type2 = ~S~%" type2) -;; (format t "p2-ash result-type = ~S~%" result-type) -;; (format t "p2-ash representation = ~S~%" representation) (cond ((and (integerp arg1) (integerp arg2)) (compile-constant (ash arg1 arg2) target representation)) ((and constant-shift @@ -5300,24 +5202,17 @@ (emit 'lshr) (convert-representation :long representation)) (t -;; (format t "p2-ash call to LispObject.ash(int)~%") -;; (format t "p2-ash type1 = ~S type2 = ~S~%" type1 type2) -;; (format t "p2-ash result-type = ~S~%" result-type) (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) (fix-boxing representation result-type))) (emit-move-from-stack target representation)) (t -;; (format t "p2-ash full call~%") (compile-function-call form target representation))))) (defknown p2-logand (t t t) t) (defun p2-logand (form target representation) - (let* ((args (cdr form)) -;; (len (length args)) - ) -;; (cond ((= len 2) + (let* ((args (cdr form))) (case (length args) (2 (let* ((arg1 (%car args)) @@ -5325,13 +5220,6 @@ (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2)) (result-type (derive-compiler-type form))) - ;; (let ((*print-structure* nil)) - ;; (format t "~&p2-logand arg1 = ~S~%" arg1) - ;; (format t "p2-logand arg2 = ~S~%" arg2)) - ;; (format t "~&p2-logand type1 = ~S~%" type1) - ;; (format t "p2-logand type2 = ~S~%" type2) - ;; (format t "p2-logand result-type = ~S~%" result-type) - ;; (format t "p2-logand representation = ~S~%" representation) (cond ((and (integerp arg1) (integerp arg2)) (compile-constant (logand arg1 arg2) target representation)) ((and (integer-type-p type1) (eql arg2 0)) @@ -5344,7 +5232,6 @@ (compile-forms-and-maybe-emit-clear-values arg1 target representation arg2 nil nil)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) - ;; (format t "p2-logand fixnum case~%") ;; Both arguments are fixnums. (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack :int) @@ -5379,14 +5266,12 @@ (convert-representation :long representation) (emit-move-from-stack target representation)) ((fixnum-type-p type2) - ;; (format t "p2-logand LispObject.LOGAND(int) 1~%") (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack :int) (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+) (fix-boxing representation result-type) (emit-move-from-stack target representation)) ((fixnum-type-p type1) - ;; (format t "p2-logand LispObject.LOGAND(int) 2~%") ;; arg1 is a fixnum, but arg2 is not (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack nil) @@ -5396,7 +5281,6 @@ (fix-boxing representation result-type) (emit-move-from-stack target representation)) (t - ;; (format t "p2-logand LispObject.LOGAND(LispObject)~%") (compile-forms-and-maybe-emit-clear-values arg1 'stack nil arg2 'stack nil) (emit-invokevirtual +lisp-object-class+ "LOGAND" @@ -5508,7 +5392,6 @@ arg2 'stack :int) (emit 'ixor)) ((and (fixnum-type-p type1) (fixnum-type-p type2)) -;; (format t "p2-logxor case 2~%") (compile-forms-and-maybe-emit-clear-values arg1 'stack :int arg2 'stack :int) (emit 'ixor) @@ -5650,36 +5533,6 @@ (fix-boxing representation nil) ; FIXME use derived result type (emit-move-from-stack target representation))))) -;; (defknown p2-integerp (t t t) t) -;; (defun p2-integerp (form target representation) -;; (unless (check-arg-count form 1) -;; (compile-function-call form target representation) -;; (return-from p2-integerp)) -;; (let ((arg (cadr form))) -;; (compile-form arg 'stack nil) -;; (maybe-emit-clear-values arg) -;; (case representation -;; (:boolean -;; (emit-invokevirtual +lisp-object-class+ "integerp" nil "Z")) -;; (t -;; (emit-invokevirtual +lisp-object-class+ "INTEGERP" nil +lisp-object+))) -;; (emit-move-from-stack target representation))) - -;; (defknown p2-listp (t t t) t) -;; (defun p2-listp (form target representation) -;; (unless (check-arg-count form 1) -;; (compile-function-call form target representation) -;; (return-from p2-listp)) -;; (let ((arg (cadr form))) -;; (compile-form arg 'stack nil) -;; (maybe-emit-clear-values arg) -;; (case representation -;; (:boolean -;; (emit-invokevirtual +lisp-object-class+ "listp" nil "Z")) -;; (t -;; (emit-invokevirtual +lisp-object-class+ "LISTP" nil +lisp-object+))) -;; (emit-move-from-stack target representation))) - (defknown p2-zerop (t t t) t) (define-inlined-function p2-zerop (form target representation) ((aver (or (null representation) (eq representation :boolean))) @@ -5968,7 +5821,6 @@ (compile-function-call form target representation))))) (defun p2-read-line (form target representation) -;; (format t "p2-read-line~%") (let* ((args (cdr form)) (len (length args))) (case len @@ -5976,7 +5828,6 @@ (let* ((arg1 (%car args)) (type1 (derive-compiler-type arg1))) (cond ((compiler-subtypep type1 'stream) -;; (format t "p2-read-line optimized case 1~%") (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit 'checkcast +lisp-stream-class+) (emit-push-constant-int 1) @@ -5991,7 +5842,6 @@ (type1 (derive-compiler-type arg1)) (arg2 (%cadr args))) (cond ((and (compiler-subtypep type1 'stream) (null arg2)) -;; (format t "p2-read-line optimized case 2~%") (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit 'checkcast +lisp-stream-class+) (emit-push-constant-int 0) @@ -6097,23 +5947,17 @@ (setf result-low 0) (setf result-high (if (and high1 high2) (min high1 high2) - (or high1 high2))) -;; (setf result-type (make-integer-type (list 'INTEGER result-low result-high))) - ) + (or high1 high2)))) ((and low1 (>= low1 0)) ;; arg1 is non-negative (dformat t "arg1 is non-negative~%") (setf result-low 0) - (setf result-high high1) -;; (setf result-type (make-integer-type (list 'INTEGER 0 high1))) - ) + (setf result-high high1)) ((and low2 (>= low2 0)) ;; arg2 is non-negative (dformat t "arg2 is non-negative~%") (setf result-low 0) - (setf result-high high2) -;; (setf result-type (make-integer-type (list 'INTEGER 0 high2))) - )) + (setf result-high high2))) (dformat t "result-low = ~S~%" result-low) (dformat t "result-high = ~S~%" result-high) (setf result-type (make-integer-type (list 'INTEGER result-low result-high))) @@ -6438,10 +6282,6 @@ (derive-type-min form)) (READ-CHAR (derive-type-read-char form)) -;; (SETQ -;; (if (= (length form) 3) -;; (derive-type (third form)) -;; t)) ((THE TRULY-THE) (second form)) (t @@ -6670,7 +6510,6 @@ (convert-representation result-rep representation) (emit-move-from-stack target representation)) ((fixnump arg2) -;; (format t "p2-times case 3~%") (compile-forms-and-maybe-emit-clear-values arg1 'stack nil) (emit-push-int arg2) (emit-invokevirtual +lisp-object-class+ "multiplyBy" '("I") +lisp-object+) @@ -6753,14 +6592,6 @@ (type2 (derive-compiler-type arg2)) (result-type (derive-compiler-type form)) (result-rep (type-representation result-type))) -;; (let ((*print-structure* nil)) -;; (format t "~&p2-plus arg1 = ~S~%" arg1) -;; (format t "p2-plus arg2 = ~S~%" arg2)) -;; (format t "~&p2-plus type1 = ~S~%" type1) -;; (format t "p2-plus type2 = ~S~%" type2) -;; (format t "p2-plus result-type = ~S~%" result-type) -;; (format t "p2-plus result-rep = ~S~%" result-rep) -;; (format t "p2-plus representation = ~S~%" representation) (cond ((and (numberp arg1) (numberp arg2)) (compile-constant (+ arg1 arg2) target representation)) ((and (numberp arg1) (eql arg1 0)) @@ -6935,9 +6766,6 @@ (type1 (derive-compiler-type arg1)) (type2 (derive-compiler-type arg2)) (type3 (derive-compiler-type arg3))) -;; (format t "p2-set-char/schar type1 = ~S~%" type1) -;; (format t "p2-set-char/schar type2 = ~S~%" type2) -;; (format t "p2-set-char/schar type3 = ~S~%" type3) (cond ((and (< *safety* 3) (or (null representation) (eq representation :char)) (compiler-subtypep type1 'STRING) @@ -6962,7 +6790,6 @@ (convert-representation :char representation) (emit-move-from-stack target representation)))) (t -;; (format t "p2-set-char/schar not optimized~%") (compile-function-call form target representation))))) @@ -7083,31 +6910,12 @@ (arg3 (third args)) (type3 (derive-compiler-type arg3)) (*register* *register*) - (value-register (unless (null target) (allocate-register))) -;; (array-derived-type t) - ) - -;; (format t "p2-aset type3 = ~S~%" type3) - -;; (when (symbolp arg1) -;; (let ((variable (find-visible-variable (second form)))) -;; (when variable -;; (setf array-derived-type (derive-type variable))))) + (value-register (unless (null target) (allocate-register)))) ;; array (compile-form arg1 'stack nil) ;; index (compile-form arg2 'stack :int) ;; value -;; (cond ((subtypep array-derived-type '(array (unsigned-byte 8))) -;; (compile-form (fourth form) 'stack :int) -;; (when value-register -;; (emit 'dup) -;; (emit-move-from-stack value-register :int))) -;; (t -;; (compile-form (fourth form) 'stack nil) -;; (when value-register -;; (emit 'dup) -;; (emit-move-from-stack value-register nil)))) (cond ((fixnum-type-p type3) (compile-form arg3 'stack :int) (when value-register @@ -7118,15 +6926,8 @@ (when value-register (emit 'dup) (emit-move-from-stack value-register nil)))) - -;; (unless (and (single-valued-p (second form)) -;; (single-valued-p (third form)) -;; (single-valued-p (fourth form))) -;; (emit-clear-values)) (maybe-emit-clear-values arg1 arg2 arg3) - - (cond (;;(subtypep array-derived-type '(array (unsigned-byte 8))) - (fixnum-type-p type3) + (cond ((fixnum-type-p type3) (emit-invokevirtual +lisp-object-class+ "aset" '("I" "I") nil)) (t (emit-invokevirtual +lisp-object-class+ "aset" (list "I" +lisp-object+) nil))) @@ -7498,8 +7299,6 @@ (when (neq new-form form) (return-from p2-setq (compile-form (p1 new-form) target representation)))) ;; We're setting a special variable. -;; (let ((*print-structure* nil)) -;; (format t "p2-setq name = ~S value-form = ~S~%" name value-form)) (cond ((and variable (variable-binding-register variable) (eq (variable-compiland variable) *current-compiland*) @@ -7515,8 +7314,6 @@ (= (length value-form) 3) (var-ref-p (third value-form)) (eq (variable-name (var-ref-variable (third value-form))) name)) - ;; (push thing *special*) => (setq *special* (cons thing *special*)) -;; (format t "compiling pushSpecial~%") (emit-push-current-thread) (emit-load-externalized-object name) (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil) @@ -7689,8 +7486,6 @@ (defun p2-the (form target representation) (let ((type-form (second form)) (value-form (third form))) -;; (let ((*print-structure* nil)) -;; (format t "p2-the type-form = ~S value-form = ~S~%" type-form value-form)) (cond ((and (subtypep type-form 'FIXNUM) (consp value-form) (eq (car value-form) 'structure-ref)) @@ -8185,9 +7980,7 @@ (when (memq (type-representation (variable-declared-type variable)) '(:int :long)) (emit-push-variable variable) -;; (sys::%format t "declared type: ~S~%" (variable-declared-type variable)) (derive-variable-representation variable nil) -;; (sys::%format t "representation: ~S~%" (variable-representation variable)) (when (< 1 (representation-size (variable-representation variable))) (allocate-variable-register variable)) (convert-representation nil (variable-representation variable)) @@ -8196,7 +7989,6 @@ (defknown p2-compiland (t) t) (defun p2-compiland (compiland) -;; (format t "p2-compiland name = ~S~%" (compiland-name compiland)) (let* ((p1-result (compiland-p1-result compiland)) (class-file (compiland-class-file compiland)) (*this-class* (abcl-class-file-class class-file)) From astalla at common-lisp.net Fri May 21 22:54:58 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 21 May 2010 18:54:58 -0400 Subject: [armedbear-cvs] r12715 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Fri May 21 18:54:55 2010 New Revision: 12715 Log: Support for custom defclass options for user-defined metaclasses. Introduced variable java:*classloader* which holds the classloader used by jclass and friends, and primitives to create new classloaders and (untested) add new URLs to the classloader at runtime. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Java.java trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/java.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri May 21 18:54:55 2010 @@ -513,6 +513,7 @@ autoload(PACKAGE_JAVA, "%jredefine-method", "RuntimeClass"); autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler"); autoload(PACKAGE_JAVA, "%load-java-class-from-byte-array", "RuntimeClass"); + autoload(PACKAGE_JAVA, "get-default-classloader", "JavaClassLoader"); autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false); autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); Modified: trunk/abcl/src/org/armedbear/lisp/Java.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Java.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Java.java Fri May 21 18:54:55 2010 @@ -59,6 +59,20 @@ return lc.subclassp(java_exception); } + private static final Primitive ENSURE_JAVA_OBJECT = new pf_ensure_java_object(); + private static final class pf_ensure_java_object extends Primitive + { + pf_ensure_java_object() + { + super("ensure-java-object", PACKAGE_JAVA, true, "obj"); + } + + @Override + public LispObject execute(LispObject obj) { + return obj instanceof JavaObject ? obj : new JavaObject(obj); + } + }; + // ### register-java-exception exception-name condition-symbol => T private static final Primitive REGISTER_JAVA_EXCEPTION = new pf_register_java_exception(); private static final class pf_register_java_exception extends Primitive @@ -119,6 +133,7 @@ private static final Primitive JCLASS = new pf_jclass(); private static final class pf_jclass extends Primitive { + pf_jclass() { super(Symbol.JCLASS, "name-or-class-ref &optional class-loader", @@ -128,18 +143,14 @@ @Override public LispObject execute(LispObject arg) { - return JavaObject.getInstance(javaClass(arg)); + return JavaObject.getInstance(javaClass(arg, JavaClassLoader.getCurrentClassLoader())); } @Override public LispObject execute(LispObject className, LispObject classLoader) { ClassLoader loader = (ClassLoader) classLoader.javaInstance(ClassLoader.class); - if(loader != null) { - return JavaObject.getInstance(javaClass(className, loader)); - } else { - return JavaObject.getInstance(javaClass(className)); - } + return JavaObject.getInstance(javaClass(className, loader)); } }; @@ -1176,7 +1187,7 @@ } private static Class javaClass(LispObject obj) { - return javaClass(obj, null); + return javaClass(obj, JavaClassLoader.getCurrentClassLoader()); } // Supports Java primitive types too. @@ -1202,11 +1213,7 @@ return Double.TYPE; // Not a primitive Java type. Class c; - if(classLoader != null) { - c = classForName(s, classLoader); - } else { - c = classForName(s); - } + c = classForName(s, classLoader); if (c == null) error(new LispError(s + " does not designate a Java class.")); Modified: trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java (original) +++ trunk/abcl/src/org/armedbear/lisp/JavaClassLoader.java Fri May 21 18:54:55 2010 @@ -38,8 +38,9 @@ import java.util.Collections; import java.util.HashSet; import java.util.Set; +import java.net.URL; -public class JavaClassLoader extends ClassLoader { +public class JavaClassLoader extends java.net.URLClassLoader { private static JavaClassLoader persistentInstance; @@ -47,7 +48,15 @@ public JavaClassLoader() { - super(JavaClassLoader.class.getClassLoader()); + this(JavaClassLoader.class.getClassLoader()); + } + + public JavaClassLoader(ClassLoader parent) { + super(new URL[] {}, parent); + } + + public JavaClassLoader(URL[] classpath, ClassLoader parent) { + super(classpath, parent); } public static JavaClassLoader getPersistentInstance() @@ -117,4 +126,57 @@ } return null; } + + @Override + public void addURL(URL url) { + super.addURL(url); + } + + public static final Symbol CLASSLOADER = PACKAGE_JAVA.intern("*CLASSLOADER*"); + + private static final Primitive GET_DEFAULT_CLASSLOADER = new pf_get_default_classloader(); + private static final class pf_get_default_classloader extends Primitive { + + private final LispObject defaultClassLoader = new JavaObject(new JavaClassLoader()); + + pf_get_default_classloader() { + super("get-default-classloader", PACKAGE_JAVA, true, ""); + } + + @Override + public LispObject execute() { + return defaultClassLoader; + } + }; + + private static final Primitive MAKE_CLASSLOADER = new pf_make_classloader(); + private static final class pf_make_classloader extends Primitive + { + pf_make_classloader() + { + super("make-classloader", PACKAGE_JAVA, true, "&optional parent"); + } + + @Override + public LispObject execute() { + return new JavaObject(new JavaClassLoader(getCurrentClassLoader())); + } + + @Override + public LispObject execute(LispObject parent) { + return new JavaObject(new JavaClassLoader((ClassLoader) parent.javaInstance(ClassLoader.class))); + } + }; + + public static ClassLoader getCurrentClassLoader() { + LispObject classLoader = CLASSLOADER.symbolValueNoThrow(); + if(classLoader != null) { + return (ClassLoader) classLoader.javaInstance(ClassLoader.class); + } else { + return Lisp.class.getClassLoader(); + } + } + + + } Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri May 21 18:54:55 2010 @@ -251,10 +251,10 @@ (cdr option)))))) ((:documentation :report) (list (car option) `',(cadr option))) - (t - (error 'program-error - :format-control "invalid DEFCLASS option ~S" - :format-arguments (list (car option)))))) + (t (list (car option) `(quote ,(cdr option)))))) +; (error 'program-error +; :format-control "invalid DEFCLASS option ~S" +; :format-arguments (list (car option)))))) (defun make-initfunction (initform) `(function (lambda () ,initform))) @@ -541,12 +541,13 @@ (eq (%slot-definition-allocation slot) :instance)) (defun make-instance-standard-class (metaclass + &rest initargs &key name direct-superclasses direct-slots direct-default-initargs - documentation - &allow-other-keys) + documentation) (declare (ignore metaclass)) (let ((class (std-allocate-instance +the-standard-class+))) + (check-initargs class t initargs) (%set-class-name name class) (%set-class-layout nil class) (%set-class-direct-subclasses () class) @@ -634,6 +635,7 @@ (t ;; We're redefining the class. (%make-instances-obsolete old-class) + (check-initargs old-class t all-keys) (apply #'std-after-initialization-for-classes old-class all-keys) old-class))) (t @@ -2376,6 +2378,7 @@ (dolist (option options) (when (eq (car option) :report) (setf report (cadr option)) + (setf options (delete option options :test #'equal)) (return))) (typecase report (null Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/java.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/java.lisp Fri May 21 18:54:55 2010 @@ -34,6 +34,15 @@ (require "CLOS") (require "PRINT-OBJECT") +(defvar *classloader* (get-default-classloader)) + +(defun add-url-to-classpath (url &optional (classloader *classloader*)) + (jcall "addUrl" classloader url)) + +(defun add-urls-to-classpath (&rest urls) + (dolist (url urls) + (add-url-to-classpath url))) + (defun jregister-handler (object event handler &key data count) (%jregister-handler object event handler data count)) @@ -191,6 +200,14 @@ (setf (apply #'jarray-ref jarray (row-major-to-index dimensions i)) (row-major-aref array i)) (apply #'(setf jarray-ref) (row-major-aref array i) jarray (row-major-to-index dimensions i)))))) +(defun jnew-array-from-list (element-type list) + (let ((jarray (jnew-array element-type (length list))) + (i 0)) + (dolist (x list) + (setf (jarray-ref jarray i) x + i (1+ i))) + jarray)) + (defun jclass-constructors (class) "Returns a vector of constructors for CLASS" (jcall (jmethod "java.lang.Class" "getConstructors") (jclass class))) From ehuelsmann at common-lisp.net Sat May 22 20:38:19 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 May 2010 16:38:19 -0400 Subject: [armedbear-cvs] r12716 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 22 16:38:16 2010 New Revision: 12716 Log: Delete unused private function. 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 Sat May 22 16:38:16 2010 @@ -561,12 +561,6 @@ } private static final LispObject loadStream(Stream in, boolean print, - LispThread thread) - { - return loadStream(in, print, thread, false); - } - - private static final LispObject loadStream(Stream in, boolean print, LispThread thread, boolean returnLastResult) { From ehuelsmann at common-lisp.net Sat May 22 20:51:09 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sat, 22 May 2010 16:51:09 -0400 Subject: [armedbear-cvs] r12717 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat May 22 16:51:09 2010 New Revision: 12717 Log: Remove convenience method which "prevents" typing of 1 boolean value. Modified: trunk/abcl/src/org/armedbear/lisp/Interpreter.java trunk/abcl/src/org/armedbear/lisp/Load.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 Sat May 22 16:51:09 2010 @@ -177,7 +177,7 @@ } catch (ClassNotFoundException e) { } // FIXME: what to do? - Load.loadSystemFile("j.lisp"); + Load.loadSystemFile("j.lisp", false); // not being autoloaded initialized = true; } @@ -217,7 +217,7 @@ private static synchronized void initializeSystem() { - Load.loadSystemFile("system"); + Load.loadSystemFile("system", false); // not being autoloaded } // Check for --noinit; verify that arguments are supplied for --load and @@ -308,7 +308,7 @@ false, false, true); else - Load.loadSystemFile(args[i + 1]); + Load.loadSystemFile(args[i + 1], false); // not being autoloaded ++i; } else { // Shouldn't happen. Modified: trunk/abcl/src/org/armedbear/lisp/Load.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Load.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Load.java Sat May 22 16:51:09 2010 @@ -216,16 +216,6 @@ } } - public static final LispObject loadSystemFile(String filename) - - { - final LispThread thread = LispThread.currentThread(); - return loadSystemFile(filename, - Symbol.LOAD_VERBOSE.symbolValue(thread) != NIL, - Symbol.LOAD_PRINT.symbolValue(thread) != NIL, - false); - } - public static final LispObject loadSystemFile(String filename, boolean auto) { From mevenson at common-lisp.net Sun May 23 05:29:40 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 23 May 2010 01:29:40 -0400 Subject: [armedbear-cvs] r12718 - in trunk/abcl/examples: . abcl abcl/abcl_appengine abcl/interface_implementation_in_lisp abcl/java_exception_in_lisp abcl/javacall_from_lisp abcl/jsr-223 abcl/lispcall_from_java_simple abcl/lispcall_from_java_with_params_and_return google-app-engine java-exception java-interface java-to-lisp-1 java-to-lisp-2 jsr-223 lisp-to-java Message-ID: Author: mevenson Date: Sun May 23 01:29:38 2010 New Revision: 12718 Log: Reorganization of examples: delete references to J. Added: trunk/abcl/examples/README - copied unchanged from r12715, /trunk/abcl/examples/abcl/README trunk/abcl/examples/dotabclrc - copied unchanged from r12715, /trunk/abcl/examples/.abclrc trunk/abcl/examples/google-app-engine/ - copied from r12715, /trunk/abcl/examples/abcl/abcl_appengine/ trunk/abcl/examples/java-exception/ - copied from r12715, /trunk/abcl/examples/abcl/java_exception_in_lisp/ trunk/abcl/examples/java-interface/ - copied from r12715, /trunk/abcl/examples/abcl/interface_implementation_in_lisp/ trunk/abcl/examples/java-to-lisp-1/ - copied from r12715, /trunk/abcl/examples/abcl/lispcall_from_java_simple/ trunk/abcl/examples/java-to-lisp-2/ - copied from r12715, /trunk/abcl/examples/abcl/lispcall_from_java_with_params_and_return/ trunk/abcl/examples/jsr-223/ - copied from r12715, /trunk/abcl/examples/abcl/jsr-223/ trunk/abcl/examples/lisp-to-java/ - copied from r12715, /trunk/abcl/examples/abcl/javacall_from_lisp/ Removed: trunk/abcl/examples/.abclrc trunk/abcl/examples/abcl/README trunk/abcl/examples/abcl/abcl_appengine/ trunk/abcl/examples/abcl/interface_implementation_in_lisp/ trunk/abcl/examples/abcl/java_exception_in_lisp/ trunk/abcl/examples/abcl/javacall_from_lisp/ trunk/abcl/examples/abcl/jsr-223/ trunk/abcl/examples/abcl/lispcall_from_java_simple/ trunk/abcl/examples/abcl/lispcall_from_java_with_params_and_return/ trunk/abcl/examples/complete.lisp trunk/abcl/examples/init.lisp trunk/abcl/examples/key-pressed.lisp From mevenson at common-lisp.net Sun May 23 05:43:14 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 23 May 2010 01:43:14 -0400 Subject: [armedbear-cvs] r12719 - trunk/abcl/examples/abcl Message-ID: Author: mevenson Date: Sun May 23 01:43:13 2010 New Revision: 12719 Log: Example reorganzation: delete 'abcl' directory. Removed: trunk/abcl/examples/abcl/ From mevenson at common-lisp.net Sun May 23 06:02:33 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 23 May 2010 02:02:33 -0400 Subject: [armedbear-cvs] r12720 - trunk/abcl/examples/misc Message-ID: Author: mevenson Date: Sun May 23 02:02:33 2010 New Revision: 12720 Log: Examples reorganization: misc for code snippets. Added: trunk/abcl/examples/misc/ From mevenson at common-lisp.net Sun May 23 06:06:07 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 23 May 2010 02:06:07 -0400 Subject: [armedbear-cvs] r12721 - in trunk/abcl/examples: . java-exception java-interface java-to-lisp-1 java-to-lisp-2 jsr-223 lisp-to-java misc Message-ID: Author: mevenson Date: Sun May 23 02:06:06 2010 New Revision: 12721 Log: Examples reorganization: move snippets to misc, adjust local READMEs. Added: trunk/abcl/examples/java-exception/README trunk/abcl/examples/java-interface/README trunk/abcl/examples/java-to-lisp-1/README trunk/abcl/examples/java-to-lisp-2/README trunk/abcl/examples/jsr-223/README trunk/abcl/examples/lisp-to-java/README trunk/abcl/examples/misc/dotabclrc - copied unchanged from r12718, /trunk/abcl/examples/dotabclrc trunk/abcl/examples/misc/hello.java - copied unchanged from r12718, /trunk/abcl/examples/hello.java trunk/abcl/examples/misc/update-check-enabled.lisp - copied unchanged from r12718, /trunk/abcl/examples/update-check-enabled.lisp Removed: trunk/abcl/examples/dotabclrc trunk/abcl/examples/hello.java trunk/abcl/examples/update-check-enabled.lisp Added: trunk/abcl/examples/java-exception/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-exception/README Sun May 23 02:06:06 2010 @@ -0,0 +1,29 @@ +ABCL Examples Building and Running Instructions +=============================================== + +To compile + + cmd$ javac -cp ../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + +where "Main" is the initial class to run in your Java program. + + Added: trunk/abcl/examples/java-interface/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-interface/README Sun May 23 02:06:06 2010 @@ -0,0 +1,29 @@ +ABCL Examples Building and Running Instructions +=============================================== + +To compile + + cmd$ javac -cp ../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + +where "Main" is the initial class to run in your Java program. + + Added: trunk/abcl/examples/java-to-lisp-1/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-to-lisp-1/README Sun May 23 02:06:06 2010 @@ -0,0 +1,29 @@ +ABCL Examples Building and Running Instructions +=============================================== + +To compile + + cmd$ javac -cp ../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + +where "Main" is the initial class to run in your Java program. + + Added: trunk/abcl/examples/java-to-lisp-2/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/java-to-lisp-2/README Sun May 23 02:06:06 2010 @@ -0,0 +1,29 @@ +ABCL Examples Building and Running Instructions +=============================================== + +To compile + + cmd$ javac -cp ../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + +where "Main" is the initial class to run in your Java program. + + Added: trunk/abcl/examples/jsr-223/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/jsr-223/README Sun May 23 02:06:06 2010 @@ -0,0 +1,28 @@ +ABCL Examples Building and Running Instructions +=============================================== + +To compile: + + cmd$ javac -cp ../../dist/abcl.jar JSR223Example.java + +where the "../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. JSR223Example + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. JSR223Example + +where "Main" is the initial class to run in your Java program. + Added: trunk/abcl/examples/lisp-to-java/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/lisp-to-java/README Sun May 23 02:06:06 2010 @@ -0,0 +1,29 @@ +ABCL Examples Building and Running Instructions +=============================================== + +To compile + + cmd$ javac -cp ../../dist/abcl.jar Main.java + +where the "../../../dist/abcl.jar" represents the path to your +abcl.jar file, which is built via the Ant based build. This path +could be slightly different depending on how the system was +constructed, and possibly due to operating system conventions for +specifying relative paths. However you resolve this locally, we'll +refer to this as '$ABCL_ROOT/dist/abcl.jar' for the rest of these +instructions. + +This compiles the Java source file "Main.java" into a JVM runtime or +class file named "Main.class". + +To run the example (Main.class for example) from a Unix-like OS use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main + +or in Windows use: + + cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + +where "Main" is the initial class to run in your Java program. + + From mevenson at common-lisp.net Sun May 23 06:16:51 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Sun, 23 May 2010 02:16:51 -0400 Subject: [armedbear-cvs] r12722 - in trunk/abcl/examples: . google-app-engine Message-ID: Author: mevenson Date: Sun May 23 02:16:50 2010 New Revision: 12722 Log: Examples reorganization: Top-level README, GAE specific README. Added: trunk/abcl/examples/google-app-engine/README Modified: trunk/abcl/examples/README Modified: trunk/abcl/examples/README ============================================================================== --- trunk/abcl/examples/README (original) +++ trunk/abcl/examples/README Sun May 23 02:16:50 2010 @@ -1,44 +1,48 @@ -ABCL Examples Building and Running Instructions -=============================================== +ABCL Examples +============= -code by Ville Voutilainen -(abcl_appengine code by Alex Muscar) -instructions by Blake McBride -updated by Mark Evenson +Contributions from: + Ville Voutilainen, Alex Muscar, Blake McBride, and 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 +google-app-engine + + This example shows how to run a ABCL in a Java Servlet context in + general and in Google App Engine (GAE) in particular. -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". +java-exception -To run the example (Main.class for example) from a Unix-like OS use: + Handling Java exceptions with the Lisp condition system. - cmd$ java -cp $ABCL_ROOT/dist/abcl.jar:. Main -or in Windows use: +java-interface - cmd$ java -cp $ABCL_ROOT/dist/abcl.jar;. Main + Implementing a Java interface with Lisp. -where "Main" is the initial class to run in your Java program. +java-to-lisp-1 -abcl_appengine -============== + Simple examples of calling Lisp from Java. -This example shows how to run your servlet off ABCL in general -and in Google App Engine (GAE) in particular. -When uploading your code to the server, be sure to put abcl.jar -in war/WEB-INF/lib. +java-to-lisp-2 + + More involved example of calling Lisp from Java including + parameters and return values. + + +jsr-223 + + Using the implementation of the JSR-223 interface to use Common + Lisp as a pluggable scripting language on the JVM. + + +lisp-to-java + + Calling Java code from Lisp. + + +misc + + Code snippets currently without documentation. \ No newline at end of file Added: trunk/abcl/examples/google-app-engine/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/google-app-engine/README Sun May 23 02:16:50 2010 @@ -0,0 +1,16 @@ +Google App Engine +================= + +Alex Muscar + +Running ABCL in a Google App Engine container. + +This example shows how to run your servlet off ABCL in general +and in Google App Engine (GAE) in particular. + +When uploading your code to the server, be sure to put abcl.jar +in war/WEB-INF/lib. + + + + From ehuelsmann at common-lisp.net Sun May 23 09:31:34 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 May 2010 05:31:34 -0400 Subject: [armedbear-cvs] r12723 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 23 05:31:32 2010 New Revision: 12723 Log: Style nit: I like tables and loops for their compactness. 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 Sun May 23 05:31:32 2010 @@ -430,6 +430,12 @@ in, verbose, print, auto, false); } + private static Symbol[] savedSpecials = + new Symbol[] { // CLHS Specified + Symbol.CURRENT_READTABLE, Symbol._PACKAGE_, + // Compiler policy + _SPEED_, _SPACE_, _SAFETY_, _DEBUG_, _EXPLAIN_ }; + // A nil TRUENAME signals a load from stream which has no possible path private static final LispObject loadFileFromStream(LispObject pathname, LispObject truename, @@ -443,18 +449,12 @@ long start = System.currentTimeMillis(); final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); - // "LOAD binds *READTABLE* and *PACKAGE* to the values they held before - // loading the file." - thread.bindSpecialToCurrentValue(Symbol.CURRENT_READTABLE); - thread.bindSpecialToCurrentValue(Symbol._PACKAGE_); + + for (Symbol special : savedSpecials) + thread.bindSpecialToCurrentValue(special); + int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue(thread)); thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth)); - // Compiler policy. - thread.bindSpecialToCurrentValue(_SPEED_); - thread.bindSpecialToCurrentValue(_SPACE_); - thread.bindSpecialToCurrentValue(_SAFETY_); - thread.bindSpecialToCurrentValue(_DEBUG_); - thread.bindSpecialToCurrentValue(_EXPLAIN_); final String prefix = getLoadVerbosePrefix(loadDepth); try { thread.bindSpecial(Symbol.LOAD_PATHNAME, pathname); From ehuelsmann at common-lisp.net Sun May 23 09:45:51 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Sun, 23 May 2010 05:45:51 -0400 Subject: [armedbear-cvs] r12724 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun May 23 05:45:50 2010 New Revision: 12724 Log: Remove access specifier from 2 interpreter specific functions (now defaulting to package access), because they use a type which is also package level. Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun May 23 05:45:50 2010 @@ -701,9 +701,8 @@ * * This version is used by the interpreter. */ - public static final LispObject nonLocalGo(Binding binding, - LispObject tag) - + static final LispObject nonLocalGo(Binding binding, + LispObject tag) { if (binding.env.inactive) return error(new ControlError("Unmatched tag " @@ -738,10 +737,9 @@ * * This version is used by the interpreter. */ - public static final LispObject nonLocalReturn(Binding binding, - Symbol block, - LispObject result) - + static final LispObject nonLocalReturn(Binding binding, + Symbol block, + LispObject result) { if (binding == null) { From vvoutilainen at common-lisp.net Sun May 23 17:59:52 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 23 May 2010 13:59:52 -0400 Subject: [armedbear-cvs] r12725 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun May 23 13:59:51 2010 New Revision: 12725 Log: Make Readtable functions final where possible. Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java Modified: trunk/abcl/src/org/armedbear/lisp/Readtable.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Readtable.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Readtable.java Sun May 23 13:59:51 2010 @@ -171,19 +171,19 @@ } @Override - public LispObject typeOf() + public final LispObject typeOf() { return Symbol.READTABLE; } @Override - public LispObject classOf() + public final LispObject classOf() { return BuiltInClass.READTABLE; } @Override - public LispObject typep(LispObject type) + public final LispObject typep(LispObject type) { if (type == Symbol.READTABLE) return T; @@ -193,27 +193,27 @@ } @Override - public String toString() + public final String toString() { return unreadableString("READTABLE"); } - public LispObject getReadtableCase() + public final LispObject getReadtableCase() { return readtableCase; } - public boolean isWhitespace(char c) + public final boolean isWhitespace(char c) { return getSyntaxType(c) == SYNTAX_TYPE_WHITESPACE; } - public byte getSyntaxType(char c) + public final byte getSyntaxType(char c) { return syntax.get(c); } - public boolean isInvalid(char c) + public final boolean isInvalid(char c) { switch (c) { @@ -230,7 +230,7 @@ } } - public void checkInvalid(char c, Stream stream) + public final void checkInvalid(char c, Stream stream) { // "... no mechanism is provided for changing the constituent trait of a // character." (2.1.4.2) @@ -247,12 +247,12 @@ } } - public LispObject getReaderMacroFunction(char c) + public final LispObject getReaderMacroFunction(char c) { return readerMacroFunctions.get(c); } - LispObject getMacroCharacter(char c) + final LispObject getMacroCharacter(char c) { LispObject function = getReaderMacroFunction(c); LispObject non_terminating_p; @@ -271,7 +271,7 @@ return LispThread.currentThread().setValues(function, non_terminating_p); } - void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) + final void makeDispatchMacroCharacter(char dispChar, LispObject non_terminating_p) { byte syntaxType; if (non_terminating_p != NIL) @@ -284,7 +284,7 @@ dispatchTables.put(dispChar, new DispatchTable()); } - public LispObject getDispatchMacroCharacter(char dispChar, char subChar) + public final LispObject getDispatchMacroCharacter(char dispChar, char subChar) { DispatchTable dispatchTable = dispatchTables.get(dispChar); @@ -299,7 +299,7 @@ return (function != null) ? function : NIL; } - public void setDispatchMacroCharacter(char dispChar, char subChar, + public final void setDispatchMacroCharacter(char dispChar, char subChar, LispObject function) { From vvoutilainen at common-lisp.net Sun May 23 18:20:49 2010 From: vvoutilainen at common-lisp.net (Ville Voutilainen) Date: Sun, 23 May 2010 14:20:49 -0400 Subject: [armedbear-cvs] r12726 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: vvoutilainen Date: Sun May 23 14:20:48 2010 New Revision: 12726 Log: Use BitSet's bulk set operation. Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java Modified: trunk/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Stream.java (original) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Sun May 23 14:20:48 2010 @@ -1138,8 +1138,7 @@ sb.setLength(0); sb.append(readMultipleEscape(rt)); flags = new BitSet(sb.length()); - for (int i = sb.length(); i-- > 0;) - flags.set(i); + flags.set(0, sb.length()); } else if (rt.isInvalid(c)) { rt.checkInvalid(c, this); // Signals a reader-error. } else if (readtableCase == Keyword.UPCASE) { @@ -1180,8 +1179,7 @@ int end = sb.length(); if (flags == null) flags = new BitSet(sb.length()); - for (int i = begin; i < end; i++) - flags.set(i); + flags.set(begin, end); continue; } if (readtableCase == Keyword.UPCASE) From ehuelsmann at common-lisp.net Mon May 24 09:07:21 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 24 May 2010 05:07:21 -0400 Subject: [armedbear-cvs] r12727 - in tags/0.20.0: . abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 24 05:07:18 2010 New Revision: 12727 Log: Tag 0.20.0. Added: tags/0.20.0/ - copied from r12726, /branches/0.20.x/ Modified: tags/0.20.0/abcl/src/org/armedbear/lisp/Version.java Modified: tags/0.20.0/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- /branches/0.20.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ tags/0.20.0/abcl/src/org/armedbear/lisp/Version.java Mon May 24 05:07:18 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.20.0-dev"; + return "0.20.0"; } public static void main(String args[]) { From ehuelsmann at common-lisp.net Mon May 24 09:08:15 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Mon, 24 May 2010 05:08:15 -0400 Subject: [armedbear-cvs] r12728 - branches/0.20.x/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon May 24 05:08:15 2010 New Revision: 12728 Log: Increase branch version. Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/0.20.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/0.20.x/abcl/src/org/armedbear/lisp/Version.java (original) +++ branches/0.20.x/abcl/src/org/armedbear/lisp/Version.java Mon May 24 05:08:15 2010 @@ -41,7 +41,7 @@ public static String getVersion() { - return "0.20.0-dev"; + return "0.20.1-dev"; } public static void main(String args[]) { From mevenson at common-lisp.net Mon May 24 16:38:10 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Mon, 24 May 2010 12:38:10 -0400 Subject: [armedbear-cvs] r12729 - in trunk/abcl/examples/google-app-engine: . src/abcl_ae Message-ID: Author: mevenson Date: Mon May 24 12:38:08 2010 New Revision: 12729 Log: Restore buildable state. Modified: trunk/abcl/examples/google-app-engine/build.xml trunk/abcl/examples/google-app-engine/src/abcl_ae/AbclInit.java trunk/abcl/examples/google-app-engine/src/abcl_ae/HelloWorldServlet.java Modified: trunk/abcl/examples/google-app-engine/build.xml ============================================================================== --- trunk/abcl/examples/google-app-engine/build.xml (original) +++ trunk/abcl/examples/google-app-engine/build.xml Mon May 24 12:38:08 2010 @@ -1,6 +1,9 @@ - - + + + + @@ -10,6 +13,7 @@ + - + @@ -29,7 +33,8 @@ - @@ -41,8 +46,14 @@ srcdir="src" destdir="war/WEB-INF/classes" classpathref="project.classpath" + includeantruntime="false" debug="on" /> + + + + + Modified: trunk/abcl/examples/google-app-engine/src/abcl_ae/AbclInit.java ============================================================================== --- trunk/abcl/examples/google-app-engine/src/abcl_ae/AbclInit.java (original) +++ trunk/abcl/examples/google-app-engine/src/abcl_ae/AbclInit.java Mon May 24 12:38:08 2010 @@ -8,7 +8,6 @@ import org.armedbear.lisp.Interpreter; import org.armedbear.lisp.Symbol; import org.armedbear.lisp.Pathname; -import org.armedbear.lisp.ConditionThrowable; public final class AbclInit { static private Object lock = new Object(); Modified: trunk/abcl/examples/google-app-engine/src/abcl_ae/HelloWorldServlet.java ============================================================================== --- trunk/abcl/examples/google-app-engine/src/abcl_ae/HelloWorldServlet.java (original) +++ trunk/abcl/examples/google-app-engine/src/abcl_ae/HelloWorldServlet.java Mon May 24 12:38:08 2010 @@ -9,6 +9,7 @@ import org.armedbear.lisp.Lisp; import org.armedbear.lisp.Symbol; import org.armedbear.lisp.SpecialBinding; +import org.armedbear.lisp.SpecialBindingsMark; import org.armedbear.lisp.Load; import org.armedbear.lisp.Stream; @@ -30,7 +31,8 @@ SpecialBindingsMark mark = currentThread.markSpecialBindings(); currentThread.bindSpecial( Symbol.STANDARD_OUTPUT, - new Stream(resp.getOutputStream(), Symbol.CHARACTER, false)); + new Stream(Symbol.SYSTEM_STREAM, resp.getOutputStream(), + Symbol.CHARACTER, false)); try { currentThread.execute(doGet); From mevenson at common-lisp.net Tue May 25 09:19:02 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 25 May 2010 05:19:02 -0400 Subject: [armedbear-cvs] r12730 - in trunk/abcl: examples/gui nbproject Message-ID: Author: mevenson Date: Tue May 25 05:18:58 2010 New Revision: 12730 Log: Place for holding AWT/Swing example code from tree. Added: trunk/abcl/examples/gui/ Modified: trunk/abcl/nbproject/build-impl.xml trunk/abcl/nbproject/genfiles.properties Modified: trunk/abcl/nbproject/build-impl.xml ============================================================================== --- trunk/abcl/nbproject/build-impl.xml (original) +++ trunk/abcl/nbproject/build-impl.xml Tue May 25 05:18:58 2010 @@ -20,6 +20,13 @@ --> + + + + + + + @@ -152,14 +190,23 @@ - + + - + + + + + + + + - + + @@ -198,7 +245,7 @@ - + @@ -213,6 +260,7 @@ + @@ -269,8 +317,11 @@ + + + @@ -287,12 +338,16 @@ + + + + - + @@ -316,7 +371,22 @@ COMPILATION SECTION =================== --> - + + + + + + + + + + + + + + + + @@ -332,10 +402,15 @@ - + + + + + + - + @@ -352,7 +427,7 @@ Must select some files in the IDE or set javac.includes - + @@ -372,10 +447,10 @@ - + - + @@ -418,11 +493,53 @@ java -jar "${dist.jar.resolved}" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + Modified: trunk/abcl/nbproject/genfiles.properties ============================================================================== --- trunk/abcl/nbproject/genfiles.properties (original) +++ trunk/abcl/nbproject/genfiles.properties Tue May 25 05:18:58 2010 @@ -4,8 +4,8 @@ # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml. # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you. nbproject/build-impl.xml.data.CRC32=742204ce -nbproject/build-impl.xml.script.CRC32=b7bf05a5 -nbproject/build-impl.xml.stylesheet.CRC32=65b8de21 +nbproject/build-impl.xml.script.CRC32=29122cc4 +nbproject/build-impl.xml.stylesheet.CRC32=576378a2 at 1.32.1.45 nbproject/profiler-build-impl.xml.data.CRC32=71623fcd nbproject/profiler-build-impl.xml.script.CRC32=abda56ed nbproject/profiler-build-impl.xml.stylesheet.CRC32=42cb6bcf From mevenson at common-lisp.net Tue May 25 12:42:18 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 25 May 2010 08:42:18 -0400 Subject: [armedbear-cvs] r12731 - in trunk/abcl: examples/gui examples/gui/awt examples/gui/swing src/org/armedbear/lisp/java src/org/armedbear/lisp/java/awt src/org/armedbear/lisp/java/swing Message-ID: Author: mevenson Date: Tue May 25 08:42:15 2010 New Revision: 12731 Log: Move unused GUI code to examples hierarchy. Added: trunk/abcl/examples/gui/DialogPromptStream.java - copied, changed from r12729, /trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java trunk/abcl/examples/gui/awt/ - copied from r12729, /trunk/abcl/src/org/armedbear/lisp/java/awt/ trunk/abcl/examples/gui/swing/ - copied from r12729, /trunk/abcl/src/org/armedbear/lisp/java/swing/ Removed: trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java trunk/abcl/src/org/armedbear/lisp/java/awt/ trunk/abcl/src/org/armedbear/lisp/java/swing/ Modified: trunk/abcl/examples/gui/awt/ActionListener.java trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java trunk/abcl/examples/gui/awt/ComponentAdapter.java trunk/abcl/examples/gui/awt/ItemListener.java trunk/abcl/examples/gui/awt/KeyAdapter.java trunk/abcl/examples/gui/awt/MouseAdapter.java trunk/abcl/examples/gui/awt/MouseMotionAdapter.java trunk/abcl/examples/gui/awt/WindowAdapter.java trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java Copied: trunk/abcl/examples/gui/DialogPromptStream.java (from r12729, /trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java) ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/DialogPromptStream.java (original) +++ trunk/abcl/examples/gui/DialogPromptStream.java Tue May 25 08:42:15 2010 @@ -1,4 +1,3 @@ -package org.armedbear.lisp.java; import java.io.IOException; import java.io.Reader; @@ -6,12 +5,17 @@ import java.io.StringWriter; import org.armedbear.lisp.Stream; + /** - * A bidirectional stream that captures input from a modal dialog. The dialog reports a label (prompt line) - * which shows to the user everything that has been printed to the stream up to the moment when the dialog - * became visible. It is usable as a drop-in replacement for e.g. *debug-io*.
- * This is an abstract class that does not depend on any GUI library. Subclasses are expected to provide - * the actual code to show the dialog and read input from the user. + * A bidirectional stream that captures input from a modal dialog. The + * dialog reports a label (prompt line) which shows to the user + * everything that has been printed to the stream up to the moment + * when the dialog became visible. It is usable as a drop-in + * replacement for e.g. *debug-io*.
This is an abstract class + * that does not depend on any GUI library. Subclasses are expected to + * provide the actual code to show the dialog and read input from the + * user. + * * @author Alessio Stalla * */ Modified: trunk/abcl/examples/gui/awt/ActionListener.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/ActionListener.java (original) +++ trunk/abcl/examples/gui/awt/ActionListener.java Tue May 25 08:42:15 2010 @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import org.armedbear.lisp.JHandler; import java.awt.event.ActionEvent; Modified: trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/AwtDialogPromptStream.java (original) +++ trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java Tue May 25 08:42:15 2010 @@ -1,4 +1,4 @@ -package org.armedbear.lisp.java.awt; +package awt; import java.awt.BorderLayout; import java.awt.Dialog; @@ -12,8 +12,6 @@ import javax.swing.JButton; -import org.armedbear.lisp.java.DialogPromptStream; - public class AwtDialogPromptStream extends DialogPromptStream { Dialog dialog = new Dialog((Frame)null, true); Modified: trunk/abcl/examples/gui/awt/ComponentAdapter.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/ComponentAdapter.java (original) +++ trunk/abcl/examples/gui/awt/ComponentAdapter.java Tue May 25 08:42:15 2010 @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import org.armedbear.lisp.JHandler; import java.awt.Component; Modified: trunk/abcl/examples/gui/awt/ItemListener.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/ItemListener.java (original) +++ trunk/abcl/examples/gui/awt/ItemListener.java Tue May 25 08:42:15 2010 @@ -19,7 +19,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import java.awt.Checkbox; import java.awt.CheckboxMenuItem; Modified: trunk/abcl/examples/gui/awt/KeyAdapter.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/KeyAdapter.java (original) +++ trunk/abcl/examples/gui/awt/KeyAdapter.java Tue May 25 08:42:15 2010 @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import org.armedbear.lisp.JHandler; import java.awt.Component; Modified: trunk/abcl/examples/gui/awt/MouseAdapter.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/MouseAdapter.java (original) +++ trunk/abcl/examples/gui/awt/MouseAdapter.java Tue May 25 08:42:15 2010 @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import org.armedbear.lisp.JHandler; import java.awt.Component; Modified: trunk/abcl/examples/gui/awt/MouseMotionAdapter.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/MouseMotionAdapter.java (original) +++ trunk/abcl/examples/gui/awt/MouseMotionAdapter.java Tue May 25 08:42:15 2010 @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import org.armedbear.lisp.JHandler; import java.awt.Component; Modified: trunk/abcl/examples/gui/awt/WindowAdapter.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/awt/WindowAdapter.java (original) +++ trunk/abcl/examples/gui/awt/WindowAdapter.java Tue May 25 08:42:15 2010 @@ -18,7 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -package org.armedbear.lisp.java.awt; +package awt; import org.armedbear.lisp.JHandler; import java.awt.Window; Modified: trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java ============================================================================== --- /trunk/abcl/src/org/armedbear/lisp/java/swing/SwingDialogPromptStream.java (original) +++ trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java Tue May 25 08:42:15 2010 @@ -1,4 +1,4 @@ -package org.armedbear.lisp.java.swing; +package swing; import java.awt.BorderLayout; import java.awt.FlowLayout; From mevenson at common-lisp.net Tue May 25 13:00:59 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 25 May 2010 09:00:59 -0400 Subject: [armedbear-cvs] r12732 - in trunk/abcl/examples/gui: . abcl awt swing Message-ID: Author: mevenson Date: Tue May 25 09:00:59 2010 New Revision: 12732 Log: Make GUI examples buildable; putative attempt at a README. Added: trunk/abcl/examples/gui/README trunk/abcl/examples/gui/abcl/ (props changed) trunk/abcl/examples/gui/abcl/DialogPromptStream.java - copied, changed from r12731, /trunk/abcl/examples/gui/DialogPromptStream.java trunk/abcl/examples/gui/build.xml (contents, props changed) Removed: trunk/abcl/examples/gui/DialogPromptStream.java trunk/abcl/examples/gui/awt/.cvsignore Modified: trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java trunk/abcl/examples/gui/swing/ (props changed) trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java Added: trunk/abcl/examples/gui/README ============================================================================== --- (empty file) +++ trunk/abcl/examples/gui/README Tue May 25 09:00:59 2010 @@ -0,0 +1,23 @@ +Graphical User Interface +======================== + +abcl.DialogPromptStream +swing.SwingDialogPromptStream +awt.AwtDialogPromptStream + + Provides an example of a GUI abstraction that serves as a drop-in + replacement for *DEBUG-IO*. The concrete classes + SwingDialogPromptStream and AwtDialogPromptStream provide + implemntations in Swing and AWT respectively. + + +awt.ActionListener +awt.ComponentAdapter +awt.KeyAdaptor +awt.MouseAdaptor +awt.MotionMouseAdaptor +awt.WindowAdaptor + + How to map standard AWT listeners and adaptors to Lisp by using the + org.armedbear.lisp.JHandler callback mechanism. + Copied: trunk/abcl/examples/gui/abcl/DialogPromptStream.java (from r12731, /trunk/abcl/examples/gui/DialogPromptStream.java) ============================================================================== --- /trunk/abcl/examples/gui/DialogPromptStream.java (original) +++ trunk/abcl/examples/gui/abcl/DialogPromptStream.java Tue May 25 09:00:59 2010 @@ -1,3 +1,4 @@ +package abcl; import java.io.IOException; import java.io.Reader; Modified: trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java ============================================================================== --- trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java (original) +++ trunk/abcl/examples/gui/awt/AwtDialogPromptStream.java Tue May 25 09:00:59 2010 @@ -1,3 +1,5 @@ +// $Id$ + package awt; import java.awt.BorderLayout; @@ -10,6 +12,8 @@ import java.awt.event.ActionEvent; import java.awt.event.ActionListener; +import abcl.DialogPromptStream; + import javax.swing.JButton; public class AwtDialogPromptStream extends DialogPromptStream { Added: trunk/abcl/examples/gui/build.xml ============================================================================== --- (empty file) +++ trunk/abcl/examples/gui/build.xml Tue May 25 09:00:59 2010 @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + + \ No newline at end of file Modified: trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java ============================================================================== --- trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java (original) +++ trunk/abcl/examples/gui/swing/SwingDialogPromptStream.java Tue May 25 09:00:59 2010 @@ -12,7 +12,7 @@ import javax.swing.JPanel; import javax.swing.JTextField; -import org.armedbear.lisp.java.DialogPromptStream; +import abcl.DialogPromptStream; public class SwingDialogPromptStream extends DialogPromptStream { From mevenson at common-lisp.net Tue May 25 13:03:23 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 25 May 2010 09:03:23 -0400 Subject: [armedbear-cvs] r12733 - trunk/abcl/examples Message-ID: Author: mevenson Date: Tue May 25 09:03:22 2010 New Revision: 12733 Log: Mention gui subdirectory in README. Modified: trunk/abcl/examples/README Modified: trunk/abcl/examples/README ============================================================================== --- trunk/abcl/examples/README (original) +++ trunk/abcl/examples/README Tue May 25 09:03:22 2010 @@ -10,6 +10,10 @@ This example shows how to run a ABCL in a Java Servlet context in general and in Google App Engine (GAE) in particular. +gui + + Examples of how to interact with Swing/AWT GUI elements. + java-exception From mevenson at common-lisp.net Tue May 25 13:20:12 2010 From: mevenson at common-lisp.net (Mark Evenson) Date: Tue, 25 May 2010 09:20:12 -0400 Subject: [armedbear-cvs] r12734 - trunk/abcl/src/org/armedbear/lisp/java/swing Message-ID: Author: mevenson Date: Tue May 25 09:20:11 2010 New Revision: 12734 Log: REPLConsole provides a minimal Swing GUI Console with a REPL. Orignally written by Alessio Stalla for Snow, but judged useful to have in the base distribution as the point for embedding ABCL in other tools (like Eclipse RCP elements for Protege). Added: trunk/abcl/src/org/armedbear/lisp/java/swing/ trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java (contents, props changed) Added: trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java ============================================================================== --- (empty file) +++ trunk/abcl/src/org/armedbear/lisp/java/swing/REPLConsole.java Tue May 25 09:20:11 2010 @@ -0,0 +1,318 @@ +/* + * ConsoleDocument.java + * + * Copyright (C) 2008-2009 Alessio Stalla + * + * $Id$ + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp.java.swing; + +import java.awt.Window; +import java.awt.event.WindowAdapter; +import java.awt.event.WindowEvent; +import java.io.BufferedReader; +import java.io.BufferedWriter; +import java.lang.RuntimeException; +import java.io.Reader; +import java.io.Writer; + +import javax.swing.JFrame; +import javax.swing.JScrollPane; +import javax.swing.JTextArea; +import javax.swing.SwingUtilities; +import javax.swing.event.DocumentEvent; +import javax.swing.event.DocumentListener; +import javax.swing.text.AttributeSet; +import javax.swing.text.BadLocationException; +import javax.swing.text.DefaultStyledDocument; +import javax.swing.text.JTextComponent; +import org.armedbear.lisp.Function; +import org.armedbear.lisp.Interpreter; +import org.armedbear.lisp.LispObject; +import org.armedbear.lisp.LispThread; +import org.armedbear.lisp.SpecialBindingsMark; +import org.armedbear.lisp.Stream; +import org.armedbear.lisp.Symbol; +import org.armedbear.lisp.TwoWayStream; + +import static org.armedbear.lisp.Lisp.*; + +public class REPLConsole extends DefaultStyledDocument { + + private StringBuffer inputBuffer = new StringBuffer(); + + private Reader reader = new Reader() { + + @Override + public void close() throws RuntimeException {} + + @Override + public synchronized int read(char[] cbuf, int off, int len) throws RuntimeException { + try { + int length = Math.min(inputBuffer.length(), len); + while(length <= 0) { + wait(); + length = Math.min(inputBuffer.length(), len); + } + inputBuffer.getChars(0, length, cbuf, off); + inputBuffer.delete(0, length); + return length; + } catch (InterruptedException e) { + throw new RuntimeException(e); + } + } + }; + + private Writer writer = new Writer() { + + @Override + public void close() throws RuntimeException {} + + @Override + public void flush() throws RuntimeException {} + + @Override + public void write(final char[] cbuf, final int off, final int len) throws RuntimeException { + try { + final int insertOffs; + synchronized(reader) { + if(inputBuffer.toString().matches("^\\s*$")) { + int length = inputBuffer.length(); + inputBuffer.delete(0, length); + } + insertOffs = getLength() - inputBuffer.length(); + reader.notifyAll(); + } + Runnable r = new Runnable() { + public void run() { + synchronized(reader) { + try { + superInsertString(insertOffs, + new String(cbuf, off, len), + null); + } catch(Exception e) { + assert(false); //BadLocationException should not happen here + } + } + } + }; + SwingUtilities.invokeAndWait(r); + } catch (Exception e) { + throw new RuntimeException(e); + } + } + }; + + private boolean disposed = false; + private final Thread replThread; + + public REPLConsole(LispObject replFunction) { + final LispObject replWrapper = makeReplWrapper(new Stream(Symbol.SYSTEM_STREAM, new BufferedReader(reader)), + new Stream(Symbol.SYSTEM_STREAM, new BufferedWriter(writer)), + replFunction); + replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) { + public void run() { + while(true) { + replWrapper.execute(); + yield(); + } + } + }; + replThread.start(); + } + + @Override + public void insertString(int offs, String str, AttributeSet a) + throws BadLocationException { + synchronized(reader) { + int bufferStart = getLength() - inputBuffer.length(); + if(offs < bufferStart) { + throw new BadLocationException("Can only insert after " + bufferStart, offs); + } + superInsertString(offs, str, a); + inputBuffer.insert(offs - bufferStart, str); + if(processInputP(inputBuffer, str)) { + reader.notifyAll(); + } + } + } + + protected void superInsertString(int offs, String str, AttributeSet a) + throws BadLocationException { + super.insertString(offs, str, a); + } + + /** + * Guaranteed to run with exclusive access to the buffer. + * @param sb NB sb MUST NOT be destructively modified!! + * @return + */ + protected boolean processInputP(StringBuffer sb, String str) { + if(str.indexOf("\n") == -1) { + return false; + } + int parenCount = 0; + int len = sb.length(); + for(int i = 0; i < len; i++) { + char c = sb.charAt(i); + if(c == '(') { + parenCount++; + } else if(c == ')') { + parenCount--; + if(parenCount == 0) { + return true; + } + } + } + return parenCount <= 0; + } + + @Override + public void remove(int offs, int len) throws BadLocationException { + synchronized(reader) { + int bufferStart = getLength() - inputBuffer.length(); + if(offs < bufferStart) { + throw new BadLocationException("Can only remove after " + bufferStart, offs); + } + super.remove(offs, len); + inputBuffer.delete(offs - bufferStart, offs - bufferStart + len); + } + } + + public Reader getReader() { + return reader; + } + + public Writer getWriter() { + return writer; + } + + public void setupTextComponent(final JTextComponent txt) { + addDocumentListener(new DocumentListener() { + + // @Override + public void changedUpdate(DocumentEvent e) { + } + + // @Override + public void insertUpdate(DocumentEvent e) { + int len = getLength(); + if(len - e.getLength() == e.getOffset()) { //The insert was at the end of the document + txt.setCaretPosition(getLength()); + } + } + + // @Override + public void removeUpdate(DocumentEvent e) { + } + }); + txt.setCaretPosition(getLength()); + } + + public void dispose() { + disposed = true; + for(DocumentListener listener : getDocumentListeners()) { + removeDocumentListener(listener); + } + try { + reader.close(); + writer.close(); + } catch (Exception e) { + throw new RuntimeException(e); + } + replThread.interrupt(); //really? + } + + private final LispObject debuggerHook = new Function() { + + @Override + public LispObject execute(LispObject condition, LispObject debuggerHook) { + if(disposed) { + return PACKAGE_SYS.findSymbol("%DEBUGGER-HOOK-FUNCTION").execute(condition, debuggerHook); + } else { + return NIL; + } + } + + }; + + public LispObject makeReplWrapper(final Stream in, final Stream out, final LispObject fn) { + return new Function() { + @Override + public LispObject execute() { + SpecialBindingsMark lastSpecialBinding = LispThread.currentThread().markSpecialBindings(); + try { + TwoWayStream ioStream = new TwoWayStream(in, out); + LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook); + LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in); + LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out); + LispThread.currentThread().bindSpecial(Symbol.ERROR_OUTPUT, out); + LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream); + LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream); + LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream); + return fn.execute(); + } finally { + LispThread.currentThread().resetSpecialBindings(lastSpecialBinding); + } + } + + }; + } + + public void disposeOnClose(final Window parent) { + parent.addWindowListener(new WindowAdapter() { + @Override + public void windowClosing(WindowEvent e) { + dispose(); + parent.removeWindowListener(this); + } + }); + } + + public static void main(String[] args) { + LispObject repl = null; + try { + repl = Interpreter.createInstance().eval("#'top-level::top-level-loop"); + } catch (Throwable e) { + e.printStackTrace(); + System.exit(1); + } + final REPLConsole d = new REPLConsole(repl); + final JTextComponent txt = new JTextArea(d); + d.setupTextComponent(txt); + JFrame f = new JFrame(); + f.add(new JScrollPane(txt)); + d.disposeOnClose(f); + f.setDefaultCloseOperation(f.EXIT_ON_CLOSE); + f.pack(); + f.setVisible(true); + } + +} From astalla at common-lisp.net Tue May 25 19:38:19 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 25 May 2010 15:38:19 -0400 Subject: [armedbear-cvs] r12735 - public_html Message-ID: Author: astalla Date: Tue May 25 15:38:17 2010 New Revision: 12735 Log: Draft release notes for the 0.20 release. Added: public_html/release-notes-0.20.shtml Added: public_html/release-notes-0.20.shtml ============================================================================== --- (empty file) +++ public_html/release-notes-0.20.shtml Tue May 25 15:38:17 2010 @@ -0,0 +1,52 @@ + + + + + ABCL - Release notes v0.20 + + + + + +
+

ABCL - Release notes for version 0.20

+
+ + + +
+ +

Most notable changes in ABCL 0.20

+ + +

Release notes for older releases.

+ +
+
Support for metaclasses
+
ABCL now supports user-defined CLOS metaclasses. The MOP has been improved and extended to accomodate for this new feature. This is the first funded feature added to ABCL: funds were provided to implement it and the relative tests. As a consequence of the addition of this important feature, the JAVA-CLASS built-in metaclass has been reimplemented in Lisp and has been improved in the process.
+
Support for URLs as pathnames
+
Pathnames can now be used to represent URLs: PATHNAME-JAR and PATHNAME-URL subtypes now handle Jar and URL references working for OPEN, LOAD, PROBE-FILE, FILE-WRITE-DATE, DIRECTORY, et. al. See Ticket #95 for more details.
+
ASDF2
+
The version of ASDF included in ABCL has been updated to ASDF2 (specifically to ASDF 1.719). This version of ASDF is integrated with URL support in pathnames (see the previous point) and is thus capable of loading Lisp systems directly from Jar archives.
+
Multithreading enhancements
+
Threads started through MAKE-THREAD now have a thread-termination restart available, and the THREADS:THREAD-JOIN primitive has been implemented.
+
Bug fixes and speed improvements
+
Several bugs have been fixed and many small speed improvements have been introduced.
+
+ + + + + +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id: release-notes-0.16.shtml 12246 2009-11-04 22:00:47Z ehuelsmann $
+
+ + From astalla at common-lisp.net Tue May 25 19:44:06 2010 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 25 May 2010 15:44:06 -0400 Subject: [armedbear-cvs] r12736 - public_html Message-ID: Author: astalla Date: Tue May 25 15:44:04 2010 New Revision: 12736 Log: Release notes correction. Modified: public_html/release-notes-0.20.shtml Modified: public_html/release-notes-0.20.shtml ============================================================================== --- public_html/release-notes-0.20.shtml (original) +++ public_html/release-notes-0.20.shtml Tue May 25 15:44:04 2010 @@ -24,7 +24,7 @@
Support for metaclasses
-
ABCL now supports user-defined CLOS metaclasses. The MOP has been improved and extended to accomodate for this new feature. This is the first funded feature added to ABCL: funds were provided to implement it and the relative tests. As a consequence of the addition of this important feature, the JAVA-CLASS built-in metaclass has been reimplemented in Lisp and has been improved in the process.
+
ABCL now supports user-defined CLOS metaclasses. The MOP has been improved and extended to accomodate for this new feature. This is the first funded feature added to ABCL: funds were provided to implement it and the relevant tests. As a consequence of the addition of this important feature, the JAVA-CLASS built-in metaclass has been reimplemented in Lisp and has been improved in the process.
Support for URLs as pathnames
Pathnames can now be used to represent URLs: PATHNAME-JAR and PATHNAME-URL subtypes now handle Jar and URL references working for OPEN, LOAD, PROBE-FILE, FILE-WRITE-DATE, DIRECTORY, et. al. See Ticket #95 for more details.
ASDF2
From ehuelsmann at common-lisp.net Thu May 27 19:39:03 2010 From: ehuelsmann at common-lisp.net (Erik Huelsmann) Date: Thu, 27 May 2010 15:39:03 -0400 Subject: [armedbear-cvs] r12737 - in public_html: . releases Message-ID: Author: ehuelsmann Date: Thu May 27 15:38:59 2010 New Revision: 12737 Log: Update front page and publish release binaries. Added: public_html/releases/abcl-bin-0.20.0.tar.gz (contents, props changed) public_html/releases/abcl-bin-0.20.0.tar.gz.asc public_html/releases/abcl-bin-0.20.0.zip (contents, props changed) public_html/releases/abcl-bin-0.20.0.zip.asc public_html/releases/abcl-src-0.20.0.tar.gz (contents, props changed) public_html/releases/abcl-src-0.20.0.tar.gz.asc public_html/releases/abcl-src-0.20.0.zip (contents, props changed) public_html/releases/abcl-src-0.20.0.zip.asc Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml (original) +++ public_html/index.shtml Thu May 27 15:38:59 2010 @@ -61,24 +61,24 @@ Binary - abcl-bin-0.19.1.tar.gz - (pgp) + abcl-bin-0.20.0.tar.gz + (pgp) - abcl-bin-0.19.1.zip - (pgp) + abcl-bin-0.20.0.zip + (pgp) Source - abcl-src-0.19.1.tar.gz - (pgp) + abcl-src-0.20.0.tar.gz + (pgp) - abcl-src-0.19.1.zip - (pgp) + abcl-src-0.20.0.zip + (pgp) Added: public_html/releases/abcl-bin-0.20.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.20.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.20.0.tar.gz.asc Thu May 27 15:38:59 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkv9jDYACgkQi5O0Epaz9TlppgCfbdKSdlm0JI81Iy2i8Bi0y9Nu +L+cAnitP4hlFeL9n9x7q1t+h5BaXbbgj +=bXdW +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-bin-0.20.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-bin-0.20.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-bin-0.20.0.zip.asc Thu May 27 15:38:59 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkv9jEIACgkQi5O0Epaz9Tk36QCeLnGCCkpRgycPjfwh6m+6G5A/ +1PUAn2Go/NNGrFeuc4V4Oh5Co1S8L7vo +=4tuY +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.20.0.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.20.0.tar.gz.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.20.0.tar.gz.asc Thu May 27 15:38:59 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkv9jFQACgkQi5O0Epaz9TmpkgCeKdVTOdT7UFlNjHjlnn3QiQXT +ZSMAn3c4KkTgbOI20WR2FwNT4RR/SLwW +=fDff +-----END PGP SIGNATURE----- Added: public_html/releases/abcl-src-0.20.0.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/abcl-src-0.20.0.zip.asc ============================================================================== --- (empty file) +++ public_html/releases/abcl-src-0.20.0.zip.asc Thu May 27 15:38:59 2010 @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEABECAAYFAkv9jE0ACgkQi5O0Epaz9Tk6AQCdEcYrw3huzVs1Fxf7swI+8Ocg +FYIAn2YU1HYV3+aHkcBfn8NyQxj+x0qm +=fRF9 +-----END PGP SIGNATURE-----