From mevenson at common-lisp.net Sun Jan 1 21:25:04 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Jan 2012 13:25:04 -0800 Subject: [armedbear-cvs] r13711 - trunk/abcl/tools Message-ID: Author: mevenson Date: Sun Jan 1 13:25:03 2012 New Revision: 13711 Log: Use the hg bisect command to search for where an ANSI test breaks. A local copy of the ABCL source tree for the revision at which a given ANSI-TESTS test breaks. The code currently uses the failure of the test named by the symbol in *TEST* to decide if a given revision is a "good" or "bad" changeset. A Mercurial copy of the ABCL sources may be cloned from . Added: trunk/abcl/tools/check.sh Added: trunk/abcl/tools/check.sh ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/check.sh Sun Jan 1 13:25:03 2012 (r13711) @@ -0,0 +1,2 @@ +#!/bin/sh +A From mevenson at common-lisp.net Sun Jan 1 21:29:06 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 01 Jan 2012 13:29:06 -0800 Subject: [armedbear-cvs] r13712 - trunk/abcl/tools Message-ID: Author: mevenson Date: Sun Jan 1 13:29:05 2012 New Revision: 13712 Log: Correctly commit 'tools/check.lisp' not its generated wrapper. Use GENERATE-BISECT-WRAPPER to generate the check.sh wrapper. This should be generalized to the Windows 'check.bat' equivalent. Added: trunk/abcl/tools/check.lisp Deleted: trunk/abcl/tools/check.sh Added: trunk/abcl/tools/check.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/tools/check.lisp Sun Jan 1 13:29:05 2012 (r13712) @@ -0,0 +1,42 @@ +;;;; Run a bisection tool to determine where a test fails +;;; This file is in the public domain. +;;; Copyright (C) 2012 by Mark +(in-package :cl-user) + +(defun generate-bisect-wrapper () + "Create 'check.sh', a script suitable for use with hg bisect. + + To use, adjust the contents of the *TESTS* + + hg clone https://evenson.not.org at code.google.com/p/abcl-dynamic-install/ ./abcl +&& cd abcl +&& hg bisect --reset && hg bisect --good && hg --command sh ./check.sh +" + (let ((check.sh #p"check.sh")) + (unless (probe-file check.sh) + (with-open-file (output check.sh :direction :output) + (format output "#!/bin/sh~A~%" + "ant && ./abcl --noinit --batch --eval \"(load \\\"check.lisp\\\""))))) + +;;; XXX separate out runtime yucky top-level forms +(require :asdf) +(require :abcl-contrib) +(require :asdf-install) ;;; to push "~/.asdf-install-dir/systems/" into ASDF:*CENTRAL-REGISTRY* + + + +;;; The ASDF definition for ANSI-COMPILED contains the ANSI-TESTS package. +;;; The CL-TEST package is defined by the GCL ANSI tests. +(eval-when (:load-toplevel :execute) + (asdf:load-system :abcl) + (asdf:load-system :ansi-compiled) + (ansi-tests:load-tests)) ;; TODO figure out how to not load all the tests + +(defparameter *test* + 'CL-TEST::SYNTAX.SHARP-BACKSLASH.7) + +(unless (rt:do-test *test*) + (error "~A failed" *test*)) + + + From mevenson at common-lisp.net Wed Jan 4 13:44:29 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 05:44:29 -0800 Subject: [armedbear-cvs] r13713 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jan 4 05:44:27 2012 New Revision: 13713 Log: [PATCH 1/2] add class METAOBJECT, splice it into mop class >From 0d36155221ec6ac028cde6ba3741253e618773e9 Mon Sep 17 00:00:00 2001 hierarchy. ... see AMOP table 5.1 --- src/org/armedbear/lisp/GenericFunction.java | 2 +- src/org/armedbear/lisp/Metaobject.java | 52 +++++++++++++++++++++++++++ src/org/armedbear/lisp/StandardClass.java | 40 ++++++++++++--------- src/org/armedbear/lisp/Symbol.java | 2 + 4 files changed, 78 insertions(+), 18 deletions(-) create mode 100644 src/org/armedbear/lisp/Metaobject.java Added: trunk/abcl/src/org/armedbear/lisp/Metaobject.java Modified: trunk/abcl/src/org/armedbear/lisp/GenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/GenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/GenericFunction.java Sun Jan 1 13:29:05 2012 (r13712) +++ trunk/abcl/src/org/armedbear/lisp/GenericFunction.java Wed Jan 4 05:44:27 2012 (r13713) @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -public abstract class GenericFunction extends StandardObject +public abstract class GenericFunction extends Metaobject { protected GenericFunction(LispClass cls, int length) { Added: trunk/abcl/src/org/armedbear/lisp/Metaobject.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/Metaobject.java Wed Jan 4 05:44:27 2012 (r13713) @@ -0,0 +1,52 @@ +/* + * Metaobject.java + * + * Copyright (C) 2003-2005 Peter Graves, 2012 Rudolf Schlatte + * $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; + +import static org.armedbear.lisp.Lisp.*; + +public abstract class Metaobject extends StandardObject +{ + protected Metaobject(LispClass cls, int length) + { + super(cls, length); + } + + @Override + public LispObject typep(LispObject type) + { + if (type == Symbol.METAOBJECT) + return T; + return super.typep(type); + } +} Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sun Jan 1 13:29:05 2012 (r13712) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jan 4 05:44:27 2012 (r13713) @@ -385,9 +385,11 @@ addStandardClass(Symbol.STANDARD_CLASS, list(BuiltInClass.CLASS_T)); public static final StandardClass STANDARD_OBJECT = addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T)); + public static final StandardClass METAOBJECT = + addStandardClass(Symbol.METAOBJECT, list(STANDARD_OBJECT)); public static final StandardClass SLOT_DEFINITION = - addStandardClass(Symbol.SLOT_DEFINITION, list(STANDARD_OBJECT)); + addStandardClass(Symbol.SLOT_DEFINITION, list(METAOBJECT)); public static final StandardClass STANDARD_SLOT_DEFINITION = addClass(Symbol.STANDARD_SLOT_DEFINITION, new SlotDefinitionClass(Symbol.STANDARD_SLOT_DEFINITION, list(SLOT_DEFINITION))); @@ -416,8 +418,8 @@ // BuiltInClass.FUNCTION is also null here (see previous comment). public static final StandardClass GENERIC_FUNCTION = - addStandardClass(Symbol.GENERIC_FUNCTION, list(BuiltInClass.FUNCTION, - STANDARD_OBJECT)); + addStandardClass(Symbol.GENERIC_FUNCTION, list(METAOBJECT, + BuiltInClass.FUNCTION)); public static final StandardClass CLASS = addStandardClass(Symbol.CLASS, list(STANDARD_OBJECT)); @@ -536,7 +538,7 @@ addStandardClass(Symbol.JAVA_EXCEPTION, list(ERROR)); public static final StandardClass METHOD = - addStandardClass(Symbol.METHOD, list(STANDARD_OBJECT)); + addStandardClass(Symbol.METHOD, list(METAOBJECT)); public static final StandardClass STANDARD_METHOD = new StandardMethodClass(); @@ -566,8 +568,8 @@ // STANDARD_OBJECT). STANDARD_CLASS.setDirectSuperclass(CLASS); STANDARD_OBJECT.setDirectSuperclass(BuiltInClass.CLASS_T); - GENERIC_FUNCTION.setDirectSuperclasses(list(BuiltInClass.FUNCTION, - STANDARD_OBJECT)); + GENERIC_FUNCTION.setDirectSuperclasses(list(METAOBJECT, + BuiltInClass.FUNCTION)); ARITHMETIC_ERROR.setCPL(ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -631,14 +633,15 @@ STANDARD_OBJECT, BuiltInClass.CLASS_T); FORWARD_REFERENCED_CLASS.setCPL(FORWARD_REFERENCED_CLASS, CLASS, BuiltInClass.CLASS_T); - GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, STANDARD_OBJECT, + GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); JAVA_EXCEPTION.setCPL(JAVA_EXCEPTION, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); JAVA_EXCEPTION.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.CAUSE, list(Symbol.JAVA_EXCEPTION_CAUSE)))); - METHOD.setCPL(METHOD, STANDARD_OBJECT, BuiltInClass.CLASS_T); + METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); + METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setDirectSlotDefinitions( @@ -725,6 +728,7 @@ FLOATING_POINT_OVERFLOW.finalizeClass(); FLOATING_POINT_UNDERFLOW.finalizeClass(); JAVA_EXCEPTION.finalizeClass(); + METAOBJECT.finalizeClass(); PACKAGE_ERROR.finalizeClass(); PARSE_ERROR.finalizeClass(); PRINT_NOT_READABLE.finalizeClass(); @@ -747,33 +751,33 @@ // SYS:SLOT-DEFINITION is constructed and finalized in // SlotDefinitionClass.java, but we need to fill in a few things here. Debug.assertTrue(SLOT_DEFINITION.isFinalized()); - SLOT_DEFINITION.setCPL(SLOT_DEFINITION, STANDARD_OBJECT, + SLOT_DEFINITION.setCPL(SLOT_DEFINITION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); SLOT_DEFINITION.setDirectSlotDefinitions(SLOT_DEFINITION.getClassLayout().generateSlotDefinitions()); // There are no inherited slots. SLOT_DEFINITION.setSlotDefinitions(SLOT_DEFINITION.getDirectSlotDefinitions()); DIRECT_SLOT_DEFINITION.setCPL(DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, - STANDARD_OBJECT, BuiltInClass.CLASS_T); + METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); DIRECT_SLOT_DEFINITION.finalizeClass(); EFFECTIVE_SLOT_DEFINITION.setCPL(EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, - STANDARD_OBJECT, BuiltInClass.CLASS_T); + METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); EFFECTIVE_SLOT_DEFINITION.finalizeClass(); STANDARD_SLOT_DEFINITION.setCPL(STANDARD_SLOT_DEFINITION, SLOT_DEFINITION, - STANDARD_OBJECT, BuiltInClass.CLASS_T); + METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_SLOT_DEFINITION.finalizeClass(); STANDARD_DIRECT_SLOT_DEFINITION.setCPL(STANDARD_DIRECT_SLOT_DEFINITION, STANDARD_SLOT_DEFINITION, - DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, STANDARD_OBJECT, + DIRECT_SLOT_DEFINITION, SLOT_DEFINITION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_DIRECT_SLOT_DEFINITION.finalizeClass(); STANDARD_EFFECTIVE_SLOT_DEFINITION.setCPL(STANDARD_EFFECTIVE_SLOT_DEFINITION, STANDARD_SLOT_DEFINITION, - EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, STANDARD_OBJECT, + EFFECTIVE_SLOT_DEFINITION, SLOT_DEFINITION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass(); // STANDARD-METHOD Debug.assertTrue(STANDARD_METHOD.isFinalized()); - STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, STANDARD_OBJECT, + STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_METHOD.setDirectSlotDefinitions(STANDARD_METHOD.getClassLayout().generateSlotDefinitions()); // There are no inherited slots. @@ -782,7 +786,8 @@ // STANDARD-READER-METHOD Debug.assertTrue(STANDARD_READER_METHOD.isFinalized()); STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, STANDARD_METHOD, - METHOD, STANDARD_OBJECT, BuiltInClass.CLASS_T); + METHOD, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); STANDARD_READER_METHOD.setSlotDefinitions(STANDARD_READER_METHOD.getClassLayout().generateSlotDefinitions()); // All but the last slot are inherited. STANDARD_READER_METHOD.setDirectSlotDefinitions(list(STANDARD_READER_METHOD.getSlotDefinitions().reverse().car())); @@ -790,7 +795,8 @@ // STANDARD-GENERIC-FUNCTION Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized()); STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION, - GENERIC_FUNCTION, STANDARD_OBJECT, + GENERIC_FUNCTION, METAOBJECT, + STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); STANDARD_GENERIC_FUNCTION.setDirectSlotDefinitions(STANDARD_GENERIC_FUNCTION.getClassLayout().generateSlotDefinitions()); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Jan 1 13:29:05 2012 (r13712) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 4 05:44:27 2012 (r13713) @@ -2967,6 +2967,8 @@ PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT"); public static final Symbol CLASS_PRECEDENCE_LIST = PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); + public static final Symbol METAOBJECT = + PACKAGE_MOP.addExternalSymbol("METAOBJECT"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); public static final Symbol DIRECT_SLOT_DEFINITION = From mevenson at common-lisp.net Wed Jan 4 13:44:29 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 05:44:29 -0800 Subject: [armedbear-cvs] r13714 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jan 4 05:44:29 2012 New Revision: 13714 Log: [PATCH 2/2] add class SPECIALIZER, splice it into mop class >From 3d54c11cd984ce6df5a563c57dce85765c1ab602 Mon Sep 17 00:00:00 2001 hierarchy. --- src/org/armedbear/lisp/Specializer.java | 52 +++++++++++++++++++++++++++++ src/org/armedbear/lisp/StandardClass.java | 18 ++++++---- src/org/armedbear/lisp/Symbol.java | 2 + 3 files changed, 65 insertions(+), 7 deletions(-) create mode 100644 src/org/armedbear/lisp/Specializer.java Added: trunk/abcl/src/org/armedbear/lisp/Specializer.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Added: trunk/abcl/src/org/armedbear/lisp/Specializer.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/Specializer.java Wed Jan 4 05:44:29 2012 (r13714) @@ -0,0 +1,52 @@ +/* + * Specializer.java + * + * Copyright (C) 2003-2005 Peter Graves, 2012 Rudolf Schlatte + * $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; + +import static org.armedbear.lisp.Lisp.*; + +public abstract class Specializer extends Metaobject +{ + protected Specializer(LispClass cls, int length) + { + super(cls, length); + } + + @Override + public LispObject typep(LispObject type) + { + if (type == Symbol.SPECIALIZER) + return T; + return super.typep(type); + } +} Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jan 4 05:44:27 2012 (r13713) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jan 4 05:44:29 2012 (r13714) @@ -387,6 +387,8 @@ addStandardClass(Symbol.STANDARD_OBJECT, list(BuiltInClass.CLASS_T)); public static final StandardClass METAOBJECT = addStandardClass(Symbol.METAOBJECT, list(STANDARD_OBJECT)); + public static final StandardClass SPECIALIZER = + addStandardClass(Symbol.SPECIALIZER, list(METAOBJECT)); public static final StandardClass SLOT_DEFINITION = addStandardClass(Symbol.SLOT_DEFINITION, list(METAOBJECT)); @@ -422,7 +424,7 @@ BuiltInClass.FUNCTION)); public static final StandardClass CLASS = - addStandardClass(Symbol.CLASS, list(STANDARD_OBJECT)); + addStandardClass(Symbol.CLASS, list(SPECIALIZER)); public static final StandardClass BUILT_IN_CLASS = addStandardClass(Symbol.BUILT_IN_CLASS, list(CLASS)); @@ -578,14 +580,14 @@ list(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERATION"))), new SlotDefinition(Symbol.OPERANDS, list(PACKAGE_CL.intern("ARITHMETIC-ERROR-OPERANDS"))))); - BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, STANDARD_OBJECT, + BUILT_IN_CLASS.setCPL(BUILT_IN_CLASS, CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); CELL_ERROR.setCPL(CELL_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); CELL_ERROR.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.NAME, list(Symbol.CELL_ERROR_NAME)))); - CLASS.setCPL(CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T); + CLASS.setCPL(CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); COMPILER_ERROR.setCPL(COMPILER_ERROR, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); INTERNAL_COMPILER_ERROR.setCPL(INTERNAL_COMPILER_ERROR, CONDITION, STANDARD_OBJECT, @@ -632,7 +634,7 @@ ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); FORWARD_REFERENCED_CLASS.setCPL(FORWARD_REFERENCED_CLASS, CLASS, - BuiltInClass.CLASS_T); + SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); @@ -641,6 +643,7 @@ JAVA_EXCEPTION.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.CAUSE, list(Symbol.JAVA_EXCEPTION_CAUSE)))); METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); + SPECIALIZER.setCPL(SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -674,7 +677,7 @@ SIMPLE_WARNING.setDirectSuperclasses(list(SIMPLE_CONDITION, WARNING)); SIMPLE_WARNING.setCPL(SIMPLE_WARNING, SIMPLE_CONDITION, WARNING, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); - STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, + STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_OBJECT.setCPL(STANDARD_OBJECT, BuiltInClass.CLASS_T); STORAGE_CONDITION.setCPL(STORAGE_CONDITION, SERIOUS_CONDITION, CONDITION, @@ -684,8 +687,8 @@ STREAM_ERROR.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.STREAM, list(PACKAGE_CL.intern("STREAM-ERROR-STREAM"))))); - STRUCTURE_CLASS.setCPL(STRUCTURE_CLASS, CLASS, STANDARD_OBJECT, - BuiltInClass.CLASS_T); + STRUCTURE_CLASS.setCPL(STRUCTURE_CLASS, CLASS, SPECIALIZER, METAOBJECT, + STANDARD_OBJECT, BuiltInClass.CLASS_T); STYLE_WARNING.setCPL(STYLE_WARNING, WARNING, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); TYPE_ERROR.setCPL(TYPE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, @@ -729,6 +732,7 @@ FLOATING_POINT_UNDERFLOW.finalizeClass(); JAVA_EXCEPTION.finalizeClass(); METAOBJECT.finalizeClass(); + SPECIALIZER.finalizeClass(); PACKAGE_ERROR.finalizeClass(); PARSE_ERROR.finalizeClass(); PRINT_NOT_READABLE.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 4 05:44:27 2012 (r13713) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 4 05:44:29 2012 (r13714) @@ -2969,6 +2969,8 @@ PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); public static final Symbol METAOBJECT = PACKAGE_MOP.addExternalSymbol("METAOBJECT"); + public static final Symbol SPECIALIZER = + PACKAGE_MOP.addExternalSymbol("SPECIALIZER"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); public static final Symbol DIRECT_SLOT_DEFINITION = From mevenson at common-lisp.net Wed Jan 4 20:34:40 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 12:34:40 -0800 Subject: [armedbear-cvs] r13715 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jan 4 12:34:38 2012 New Revision: 13715 Log: Convert EQL-SPECIALIZER from a structure into a CLOS class. >From rudi at constantly. Backout creation of Specializer.java and Equalizer.java (do it all in Lisp). From: Rudi Schlatte Date: Wed, 4 Jan 2012 17:22:59 +0100 Subject: [PATCH] Convert EQL-SPECIALIZER from a structure into a CLOS class. ... open-code make-instance machinery in intern-eql-specializer to break circular dependency between it and generic functions working ... also remove unused Java classes for metaobject and specializer introduced in previous patches (Java-side, they are just instances of StandardClass). Added: trunk/abcl/src/org/armedbear/lisp/EqualSpecializerObject.java Deleted: trunk/abcl/src/org/armedbear/lisp/Metaobject.java trunk/abcl/src/org/armedbear/lisp/Specializer.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/GenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Jan 4 05:44:29 2012 (r13714) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Wed Jan 4 12:34:38 2012 (r13715) @@ -533,6 +533,7 @@ autoload(PACKAGE_JAVA, "make-classloader", "JavaClassLoader"); autoload(PACKAGE_JAVA, "%add-to-classpath", "JavaClassLoader"); autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader"); + autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true); autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false); autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); Added: trunk/abcl/src/org/armedbear/lisp/EqualSpecializerObject.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/EqualSpecializerObject.java Wed Jan 4 12:34:38 2012 (r13715) @@ -0,0 +1,65 @@ +/* + * Java-side object stub of the CLOS equals specializer. + * + * To be stubbed out into the Lisp-side once we get CLOS booted. + * + * Copyright (C) 2012 Rudolf Schlatte + * $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; + +import static org.armedbear.lisp.Lisp.*; + +/** TODO use @DocString annotations correctly in this situation... */ +// ### eql-specializer-object +public final class EqualSpecializerObject extends Primitive +{ + public EqualSpecializerObject() + { + super(Symbol.EQL_SPECIALIZER_OBJECT, "eql-specializer"); + } + + @Override + public LispObject execute(LispObject arg) + { + if (arg instanceof StandardObject + && arg.typep(StandardClass.EQL_SPECIALIZER) == T) + { + return ((StandardObject)arg).getInstanceSlotValue(Symbol.OBJECT); + } + return error(new TypeError(arg, Symbol.EQL_SPECIALIZER)); + } + + private static final EqualSpecializerObject EQL_SPECIALIZER_OBJECT + = new EqualSpecializerObject(); +} + + + Modified: trunk/abcl/src/org/armedbear/lisp/GenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/GenericFunction.java Wed Jan 4 05:44:29 2012 (r13714) +++ trunk/abcl/src/org/armedbear/lisp/GenericFunction.java Wed Jan 4 12:34:38 2012 (r13715) @@ -35,7 +35,7 @@ import static org.armedbear.lisp.Lisp.*; -public abstract class GenericFunction extends Metaobject +public abstract class GenericFunction extends StandardObject { protected GenericFunction(LispClass cls, int length) { Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jan 4 05:44:29 2012 (r13714) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Wed Jan 4 12:34:38 2012 (r13715) @@ -389,6 +389,8 @@ addStandardClass(Symbol.METAOBJECT, list(STANDARD_OBJECT)); public static final StandardClass SPECIALIZER = addStandardClass(Symbol.SPECIALIZER, list(METAOBJECT)); + public static final StandardClass EQL_SPECIALIZER = + addStandardClass(Symbol.EQL_SPECIALIZER, list(SPECIALIZER)); public static final StandardClass SLOT_DEFINITION = addStandardClass(Symbol.SLOT_DEFINITION, list(METAOBJECT)); @@ -644,6 +646,10 @@ list(new SlotDefinition(Symbol.CAUSE, list(Symbol.JAVA_EXCEPTION_CAUSE)))); METAOBJECT.setCPL(METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); SPECIALIZER.setCPL(SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); + EQL_SPECIALIZER.setCPL(EQL_SPECIALIZER, SPECIALIZER, METAOBJECT, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + EQL_SPECIALIZER.setDirectSlotDefinitions( + list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT"))))); METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -733,6 +739,7 @@ JAVA_EXCEPTION.finalizeClass(); METAOBJECT.finalizeClass(); SPECIALIZER.finalizeClass(); + EQL_SPECIALIZER.finalizeClass(); PACKAGE_ERROR.finalizeClass(); PARSE_ERROR.finalizeClass(); PRINT_NOT_READABLE.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 4 05:44:29 2012 (r13714) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Wed Jan 4 12:34:38 2012 (r13715) @@ -2967,6 +2967,10 @@ PACKAGE_MOP.addInternalSymbol("CLASS-LAYOUT"); public static final Symbol CLASS_PRECEDENCE_LIST = PACKAGE_MOP.addInternalSymbol("CLASS-PRECEDENCE-LIST"); + public static final Symbol EQL_SPECIALIZER = + PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER"); + public static final Symbol EQL_SPECIALIZER_OBJECT = + PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER-OBJECT"); public static final Symbol METAOBJECT = PACKAGE_MOP.addExternalSymbol("METAOBJECT"); public static final Symbol SPECIALIZER = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 4 05:44:29 2012 (r13714) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 4 12:34:38 2012 (r13715) @@ -1178,15 +1178,16 @@ :function ,(coerce-to-function lambda-expression))) name)) -(defstruct eql-specializer - object) - (defparameter *eql-specializer-table* (make-hash-table :test 'eql)) (defun intern-eql-specializer (object) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) - (make-eql-specializer :object object)))) + ;; we will be called during generic function invocation + ;; setup, so have to rely on plain functions here. + (let ((instance (std-allocate-instance (find-class 'eql-specializer)))) + (setf (std-slot-value instance 'sys::object) object) + instance)))) ;; MOP (p. 216) specifies the following reader generic functions: ;; generic-function-argument-precedence-order @@ -1443,7 +1444,7 @@ (defun canonicalize-specializer (specializer) (cond ((classp specializer) specializer) - ((eql-specializer-p specializer) + ((typep specializer 'eql-specializer) specializer) ((symbolp specializer) (find-class specializer)) @@ -1809,7 +1810,7 @@ (specializer (car (%method-specializers method))) (function (or (%method-fast-function method) (%method-function method)))) - (if (eql-specializer-p specializer) + (if (typep specializer 'eql-specializer) (let ((specializer-object (eql-specializer-object specializer))) #'(lambda (arg) (declare (optimize speed)) @@ -1965,9 +1966,9 @@ (let ((spec1 (nth index specializers-1)) (spec2 (nth index specializers-2))) (unless (eq spec1 spec2) - (cond ((eql-specializer-p spec1) + (cond ((typep spec1 'eql-specializer) (return t)) - ((eql-specializer-p spec2) + ((typep spec2 'eql-specializer) (return nil)) (t (return (sub-specializer-p spec1 spec2 @@ -1979,9 +1980,9 @@ (let ((spec1 (car specializers-1)) (spec2 (car specializers-2))) (unless (eq spec1 spec2) - (cond ((eql-specializer-p spec1) + (cond ((typep spec1 'eql-specializer) (return t)) - ((eql-specializer-p spec2) + ((typep spec2 'eql-specializer) (return nil)) (t (return (sub-specializer-p spec1 spec2 (car classes)))))))))) From mevenson at common-lisp.net Wed Jan 4 21:41:23 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 13:41:23 -0800 Subject: [armedbear-cvs] r13716 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jan 4 13:41:22 2012 New Revision: 13716 Log: Backport r13703: remove uncompilable file from system source. Deleted: branches/1.0.x/abcl/src/org/armedbear/lisp/threads-jss.lisp From mevenson at common-lisp.net Wed Jan 4 21:48:45 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 13:48:45 -0800 Subject: [armedbear-cvs] r13717 - in branches/1.0.x/abcl: doc/asdf src/org/armedbear/lisp Message-ID: Author: mevenson Date: Wed Jan 4 13:48:45 2012 New Revision: 13717 Log: Backport r13702: update to asdf-2.019 with ABCL patch. Modified: branches/1.0.x/abcl/doc/asdf/asdf.texinfo branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp Modified: branches/1.0.x/abcl/doc/asdf/asdf.texinfo ============================================================================== --- branches/1.0.x/abcl/doc/asdf/asdf.texinfo Wed Jan 4 13:41:22 2012 (r13716) +++ branches/1.0.x/abcl/doc/asdf/asdf.texinfo Wed Jan 4 13:48:45 2012 (r13717) @@ -895,7 +895,8 @@ @example system-definition := ( defsystem system-designator @var{system-option}* ) -system-option := :defsystem-depends-on system-list +system-option := :defsystem-depends-on system-list + | :class class-name (see discussion below) | module-option | option @@ -959,6 +960,25 @@ the current package @code{my-system-asd} can be specified as @code{:my-component-type}, or @code{my-component-type}. + at subsection System class names + +A system class name will be looked up in the same way as a Component +type (see above). Typically, one will not need to specify a system +class name, unless using a non-standard system class defined in some +ASDF extension, typically loaded through @code{DEFSYSTEM-DEPENDS-ON}, +see below. For such class names in the ASDF package, we recommend that +the @code{:class} option be specified using a keyword symbol, such as + + at example +:class :MY-NEW-SYSTEM-SUBCLASS + at end example + +This practice will ensure that package name conflicts are avoided. +Otherwise, the symbol @code{MY-NEW-SYSTEM-SUBCLASS} will be read into +the current package @emph{before} it has been exported from the ASDF +extension loaded by @code{:defsystem-depends-on}, causing a name +conflict in the current package. + @subsection Defsystem depends on The @code{:defsystem-depends-on} option to @code{defsystem} allows the @@ -2830,16 +2850,29 @@ @section Controlling file compilation When declaring a component (system, module, file), -you can specify a keyword argument @code{:around-compile some-symbol}. -If left unspecified, the value will be inherited from the parent component if any, -or with a default of @code{nil} if no value is specified in any transitive parent. - -The argument must be a either fbound symbol or @code{nil}. +you can specify a keyword argument @code{:around-compile function}. +If left unspecified, +the value will be inherited from the parent component if any, +or with a default of @code{nil} +if no value is specified in any transitive parent. + +The argument must be a either @code{nil}, a fbound symbol, +a lambda-expression (e.g. @code{(lambda (thunk) ...(funcall thunk) ...)}) +a function object (e.g. using @code{#.#'} but that's discouraged +because it prevents the introspection done by e.g. asdf-dependency-grovel), +or a string that when read yields a symbol or a lambda-expression. @code{nil} means the normal compile-file function will be called. -A symbol means the function fbound to it will be called with a single argument, -a thunk that calls the compile-file function; -the function you specify must then funcall that thunk -inside whatever wrapping you want. +A non-nil value designates a function of one argument +that will be called with a thunk for calling +the compile-file function with proper arguments. + +Note that by using a string, you may reference +a function, symbol and/or package +that will only be created later during the build, but +isn't yet present at the time the defsystem form is evaluated. +However, if your entire system is using such a hook, you may have to +explicitly override the hook with @code{nil} for all the modules and files +that are compiled before the hook is defined. Using this hook, you may achieve such effects as: locally renaming packages, @@ -3649,6 +3682,8 @@ "lis") @end lisp + at comment FIXME: Add a FAQ about how to use a new system class... + @node TODO list, Inspiration, FAQ, Top @comment node-name, next, previous, up Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp Wed Jan 4 13:41:22 2012 (r13716) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp Wed Jan 4 13:48:45 2012 (r13717) @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.017.22: Another System Definition Facility. +;;; This is ASDF 2.019: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -56,7 +56,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Implementation-dependent tweaks - ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* @@ -86,6 +86,8 @@ (find-symbol (string s) p)) ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) (defmacro compatfmt (format) #-(or gcl genera) format #+(or gcl genera) @@ -97,10 +99,8 @@ ("~@:>" . "") ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do - (setf format - (concatenate 'simple-string - (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) format) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version @@ -110,7 +110,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.017.22") + (asdf-version "2.019") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -188,7 +188,7 @@ (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'string-equal) + (unless (member sym bothly-exported-symbols :test 'equal) (push sym newly-exported-symbols))) (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do @@ -229,23 +229,19 @@ #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function :export - (#:defsystem #:oos #:operate #:find-system #:run-shell-command + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system #:clear-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems #:test-system #:clear-system + #:operation #:compile-op #:load-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type - - #:input-files #:output-files #:output-file #:perform ; operation methods + #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain #:component #:source-file @@ -337,11 +333,19 @@ #:process-source-registry #:system-registered-p #:asdf-message + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory ;; Utilities #:absolute-pathname-p ;; #:aif #:it - ;; #:appendf + ;; #:appendf #:orf #:coerce-name #:directory-pathname-p ;; #:ends-with @@ -349,8 +353,7 @@ #:getenv ;; #:length=n-p ;; #:find-symbol* - #:merge-pathnames* - #:coerce-pathname + #:merge-pathnames* #:coerce-pathname #:subpathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -413,6 +416,7 @@ condition-arguments condition-form condition-format condition-location coerce-name) + (ftype (function (&optional t) (values)) initialize-source-registry) #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) @@ -421,8 +425,8 @@ #+cormanlisp (progn (deftype logical-pathname () nil) - (defun* make-broadcast-stream () *error-output*) - (defun* file-namestring (p) + (defun make-broadcast-stream () *error-output*) + (defun file-namestring (p) (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) @@ -522,6 +526,9 @@ :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) +(defun* ununspecific (x) + (if (eq x :unspecific) nil x)) + (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname does not have an absolute directory, @@ -540,9 +547,7 @@ (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((ununspecific (x) - (if (eq x :unspecific) nil x)) - (unspecific-handler (p) + (labels ((unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) @@ -893,24 +898,21 @@ (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) - (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) - (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (if (or (ununspecific port) + (and (ununspecific host) (plusp (length host))) + (ununspecific scheme)) + (let ((prefix "")) + (when (ununspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (ununspecific host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (ununspecific scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname)) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -1173,45 +1175,6 @@ (properties :accessor component-properties :initarg :properties :initform nil))) -;;; I believe that the following could probably be more efficiently done -;;; by a primary method that invokes SHARED-INITIALIZE in a way that would -;;; appropriately pass the slots to have their initforms re-applied, but I -;;; do not know how to write such a method. [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj component) &rest initargs - &key (version nil version-suppliedp) - (description nil description-suppliedp) - (long-description nil - long-description-suppliedp) - (load-dependencies nil - ld-suppliedp) - in-order-to - do-first - inline-methods - parent - properties) - "We reuse component objects from previously-existing systems, so we need to -make sure we clear them thoroughly." - (declare (ignore initargs load-dependencies - long-description description version)) - ;; this is a cache and should be cleared - (slot-makunbound obj 'absolute-pathname) - ;; component operation times are no longer valid when the component changes - (clrhash (component-operation-times obj)) - (unless version-suppliedp (slot-makunbound obj 'version)) - (unless description-suppliedp - (slot-makunbound obj 'description)) - (unless long-description-suppliedp - (slot-makunbound obj 'long-description)) - ;; replicate the logic of the initforms... - (unless ld-suppliedp - (setf (component-load-dependencies obj) nil)) - (setf (component-in-order-to obj) in-order-to - (component-do-first obj) do-first - (component-inline-methods obj) inline-methods - (slot-value obj 'parent) parent - (slot-value obj 'properties) properties)) - - (defun* component-find-path (component) (reverse (loop :for c = component :then (component-parent c) @@ -1284,21 +1247,6 @@ :initarg :default-component-class :accessor module-default-component-class))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj module) &rest initargs &key) - "Clear MODULE's slots so it can be reused." - (slot-makunbound obj 'components-by-name) - ;; this may be a more elegant approach than in the - ;; COMPONENT method [2011/09/02:rpg] - (loop :for (initarg slot-name default) :in - `((:components components nil) - (:if-component-dep-fails if-component-dep-fails :fail) - (:default-component-class default-component-class - ,*default-component-class*)) - :unless (member initarg initargs) - :do (setf (slot-value obj slot-name) default))) - (defun* component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). ;; If you force component to have a NULL pathname, you better arrange @@ -1332,7 +1280,12 @@ (acons property new-value (slot-value c 'properties))))) new-value) -(defclass system (module) +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) (;; description and long-description are now available for all component's, ;; but now also inherited from component, but we add the legacy accessor (description :accessor system-description :initarg :description) @@ -1345,24 +1298,6 @@ :writer %set-system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj system) &rest initargs &key) - "Clear SYSTEM's slots so it can be reused." - ;; note that SYSTEM-SOURCE-FILE is very specially handled, - ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and - ;; not squash it. SYSTEM COMPONENTS are handled very specially, - ;; because they are always, effectively, reused, since the system component - ;; is made early in DO-DEFSYSTEM, instead of being made later, in - ;; PARSE-COMPONENT-FORM [2011/09/02:rpg] - (loop :for (initarg slot-name) :in - `((:author author) - (:maintainer maintainer) - (:licence licence) - (:defsystem-depends-on defsystem-depends-on)) - :unless (member initarg initargs) - :do (slot-makunbound obj slot-name))) - ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1450,11 +1385,10 @@ (file-position s (+ start network-volume-offset #x14)))) - (concatenate 'string - (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) (defun* parse-windows-shortcut (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) @@ -1541,15 +1475,25 @@ ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defparameter *system-definition-search-functions* - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)) +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-search *system-definition-search-functions*) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever does that + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search + sysdef-find-asdf)))) (defun* search-for-system-definition (system) - (let ((system-name (coerce-name system))) - (some #'(lambda (x) (funcall x system-name)) - (cons 'find-system-if-being-defined *system-definition-search-functions*)))) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1599,7 +1543,7 @@ (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") + :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) @@ -1673,6 +1617,7 @@ 0))) (defmethod find-system ((name null) &optional (error-p t)) + (declare (ignorable name)) (when error-p (sysdef-error (compatfmt "~@")))) @@ -1692,7 +1637,7 @@ (let ((*systems-being-defined* (make-hash-table :test 'equal))) (funcall thunk)))) -(defmacro with-system-definitions (() &body body) +(defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () , at body))) (defun* load-sysdef (name pathname) @@ -1708,22 +1653,37 @@ (let ((*package* package) (*default-pathname-defaults* (pathname-directory-pathname pathname))) + ;;; XXX Kludge for ABCL ticket #181 + #+abcl + (when (ext:pathname-jar-p pathname) + (setf *default-pathname-defaults* + (make-pathname :device nil :defaults *default-pathname-defaults*))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) (load pathname))) (delete-package package))))) -(defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () - (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))))) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp (setf pathname (resolve-symlinks* pathname)) (when (and pathname (not (absolute-pathname-p pathname))) (setf pathname (ensure-pathname-absolute pathname)) @@ -1733,23 +1693,37 @@ (system-source-file previous) pathname))) (%set-system-source-file pathname previous) (setf previous-time nil)) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (or (not previous-time) - ;; don't reload if it's already been loaded, - ;; or its filestamp is in the future which means some clock is skewed - ;; and trying to load might cause an infinite loop. - (< previous-time (safe-file-write-date pathname) (get-universal-time)))) - (load-sysdef name pathname)) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk - (cond - (in-memory - (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name))))))) + (values foundp found-system pathname previous previous-time)))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s "~@" name)) + (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) @@ -1871,6 +1845,17 @@ :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) +<<<<<<< .working +======= +(defun* subpathname (pathname subpath &key type) + (and pathname (merge-pathnames* (coerce-pathname subpath :type type) + (pathname-directory-pathname pathname)))) + +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + +>>>>>>> .merge-right.r13702 ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1973,10 +1958,9 @@ (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) - (let ((all-deps (component-depends-on o c))) - (remove-if-not #'(lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) @@ -2347,10 +2331,18 @@ ((component-parent c) (around-compile-hook (component-parent c))))) +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + (defmethod call-with-around-compile-hook ((c component) thunk) (let ((hook (around-compile-hook c))) (if hook - (funcall hook thunk) + (funcall (ensure-function hook) thunk) (funcall thunk)))) (defvar *compile-op-compile-file-function* 'compile-file* @@ -2536,31 +2528,38 @@ (defgeneric* operate (operation-class system &key &allow-other-keys)) (defgeneric* perform-plan (plan &key)) +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf:asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) + ;; Invalidate all systems but ASDF itself. + (setf *defined-systems* (make-defined-systems-table)) + (register-system asdf) + ;; If we're in the middle of something, restart it. + (when *systems-being-defined* + (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) + (clrhash *systems-being-defined*) + (dolist (s l) (find-system s nil)))) + t)))) + ;;;; Try to upgrade of ASDF. If a different version was used, return T. ;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () (let ((version (asdf:asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) - (let ((new-version (asdf:asdf-version))) - (block nil - (cond - ((equal version new-version) - (return nil)) - ((version-satisfies new-version version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - ((version-satisfies version new-version) - (warn (compatfmt "~&~@~%") - version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - version new-version))) - (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) - ;; invalidate all systems but ASDF itself - (setf *defined-systems* (make-defined-systems-table)) - (register-system asdf) - t))))) + (cleanup-upgraded-asdf version))) (defmethod perform-plan ((steps list) &key) (let ((*package* *package*) @@ -2624,7 +2623,7 @@ ")) (setf (documentation 'oos 'function) (format nil - "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" operate-docstring)) (setf (documentation 'operate 'function) operate-docstring)) @@ -2636,6 +2635,9 @@ (apply 'operate 'load-op system args) t) +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE @@ -2694,7 +2696,7 @@ (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) + (if (find c (cdr it) :test #'equal) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) @@ -2716,8 +2718,7 @@ (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - (compatfmt "~&~@")) + (sysdef-error (strcat msg (compatfmt "~&~@")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2794,29 +2795,22 @@ (warn (compatfmt "~@") version name parent))) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) (ret (find-component parent name))) (when weakly-depends-on (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (if ret - (apply 'reinitialize-instance ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) - (setf ret - (apply 'make-instance (class-for-type parent type) - :name (coerce-name name) - :pathname pathname - :parent parent - other-args))) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) (setf (module-default-component-class ret) @@ -2848,6 +2842,10 @@ (%refresh-component-inline-methods ret rest) ret))) +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + (defun* do-defsystem (name &rest options &key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) @@ -2860,14 +2858,14 @@ (with-system-definitions () (let* ((name (coerce-name name)) (registered (system-registered-p name)) - (system (cdr (or registered - (register-system (make-instance 'system :name name))))) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) (component-options (remove-keys '(:class) options))) - (%set-system-source-file (load-pathname) system) (setf (gethash name *systems-being-defined*) system) - (when registered - (setf (car registered) (get-universal-time))) - (map () 'load-system defsystem-depends-on) + (apply 'load-systems defsystem-depends-on) ;; We change-class (when necessary) AFTER we load the defsystem-dep's ;; since the class might not be defined as part of those. (let ((class (class-for-type nil class))) @@ -2952,7 +2950,7 @@ (ccl:run-program (cond ((os-unix-p) "/bin/sh") - ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! (t (error "Unsupported OS"))) (if (os-unix-p) (list "-c" command) '()) :input nil :output *verbose-out* :wait t))) @@ -2964,6 +2962,9 @@ (list "-c" command) :input nil :output *verbose-out*)) + #+cormanlisp + (win32:system command) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll (ext:system command) @@ -3159,41 +3160,46 @@ (and ts (values sp ts)))) (defun* user-configuration-directories () (let ((dirs - (flet ((try (x sub) (try-directory-subpath x sub))) - `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try dir "common-lisp/")) - ,@(when (os-windows-p) - `(,(try (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - "common-lisp/config/") - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp/config/"))) - ,(try (user-homedir) ".config/common-lisp/"))))) - (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/") + (loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (subpathname* dir "common-lisp/")))) + ,@(when (os-windows-p) + `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) (defun* system-configuration-directories () (cond ((os-unix-p) '(#p"/etc/common-lisp/")) ((os-windows-p) (aif - (flet ((try (x sub) (try-directory-subpath x sub))) - ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - (try (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (try (getenv "ALLUSERSPROFILE") "Application Data/")) - "common-lisp/config/")) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData + (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/") (list it))))) -(defun* in-first-directory (dirs x) - (loop :for dir :in dirs - :thereis (and dir (probe-file* (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) - (in-first-directory (system-configuration-directories) x)) +(defun* in-first-directory (dirs x &key (direction :input)) + (loop :with fun = (ecase direction + ((nil :input :probe) 'probe-file*) + ((:output :io) 'identity)) + :for dir :in dirs + :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) + +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) (defun* configuration-inheritance-directive-p (x) (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) @@ -3547,14 +3553,14 @@ (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) -(defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file*)) -(defun* system-output-translations-pathname () - (in-system-configuration-directory *output-translations-file*)) -(defun* user-output-translations-directory-pathname () - (in-user-configuration-directory *output-translations-directory*)) -(defun* system-output-translations-directory-pathname () - (in-system-configuration-directory *output-translations-directory*)) +(defun* user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) +(defun* system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) +(defun* user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) +(defun* system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) (defun* environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) @@ -3677,8 +3683,8 @@ (translate-pathname path absolute-source destination)))) (defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp (etypecase path - #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3719,7 +3725,7 @@ (defun* tmpize-pathname (x) (make-pathname - :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) @@ -3852,6 +3858,7 @@ (loop :for f :in entries :for p = (or (and (typep f 'logical-pathname) f) (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error (and u (equal (ignore-errors (truename u)) f) u))) :when p :collect p) entries)) @@ -3865,8 +3872,9 @@ (filter-logical-directory-results directory entries #'(lambda (f) - (make-pathname :defaults directory :version (pathname-version f) - :name (pathname-name f) :type (pathname-type f)))))) + (make-pathname :defaults directory + :name (pathname-name f) :type (ununspecific (pathname-type f)) + :version (ununspecific (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3875,9 +3883,9 @@ (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl xcl) + #-(or abcl allegro cmu lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl xcl) "*.*" + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3887,16 +3895,16 @@ #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks scl xcl) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu scl) (directory-pathname-p x) + #+(or cmu sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks scl) x))) + #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (normalize-pathname-directory-component @@ -4019,14 +4027,13 @@ :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () - (flet ((try (x sub) (try-directory-subpath x sub))) - `(:source-registry - #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) - (:directory ,(default-directory)) + `(:source-registry + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) + (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv "XDG_DATA_HOME") - (try (user-homedir) ".local/share/")) + (subpathname (user-homedir) ".local/share/")) ,@(split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share") :separator ":"))) @@ -4037,18 +4044,18 @@ (getenv "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) (getenv "ALLUSERSAPPDATA") - (try (getenv "ALLUSERSPROFILE") "Application Data/"))))) - :collect `(:directory ,(try dir "common-lisp/systems/")) - :collect `(:tree ,(try dir "common-lisp/source/"))) - :inherit-configuration))) -(defun* user-source-registry () - (in-user-configuration-directory *source-registry-file*)) -(defun* system-source-registry () - (in-system-configuration-directory *source-registry-file*)) -(defun* user-source-registry-directory () - (in-user-configuration-directory *source-registry-directory*)) -(defun* system-source-registry-directory () - (in-system-configuration-directory *source-registry-directory*)) + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) + :inherit-configuration)) +(defun* user-source-registry (&key (direction :input)) + (in-user-configuration-directory *source-registry-file* :direction direction)) +(defun* system-source-registry (&key (direction :input)) + (in-system-configuration-directory *source-registry-file* :direction direction)) +(defun* user-source-registry-directory (&key (direction :input)) + (in-user-configuration-directory *source-registry-directory* :direction direction)) +(defun* system-source-registry-directory (&key (direction :input)) + (in-system-configuration-directory *source-registry-directory* :direction direction)) (defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) @@ -4126,8 +4133,7 @@ (collect (list directory :recurse recurse :exclude exclude))))) :test 'equal :from-end t))) -;; Will read the configuration and initialize all internal variables, -;; and return the new configuration. +;; Will read the configuration and initialize all internal variables. (defun* compute-source-registry (&optional parameter (registry *source-registry*)) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry From mevenson at common-lisp.net Wed Jan 4 21:51:16 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 13:51:16 -0800 Subject: [armedbear-cvs] r13718 - in branches/1.0.x/abcl: src/org/armedbear/lisp test/lisp/abcl Message-ID: Author: mevenson Date: Wed Jan 4 13:51:15 2012 New Revision: 13718 Log: backport r13704: Fix problems loading ABCL-CONTRIB. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java Wed Jan 4 13:48:45 2012 (r13717) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Pathname.java Wed Jan 4 13:51:15 2012 (r13718) @@ -2169,9 +2169,18 @@ // Possibly canonicalize jar file directory Cons jars = (Cons) pathname.device; LispObject o = jars.car(); - if (o instanceof Pathname && ! (((Pathname)o).isURL())) { + if (o instanceof Pathname + && !(((Pathname)o).isURL()) + // XXX Silently fail to call truename() if the default + // pathname defaults exist within a jar, as that will + // (probably) not succeed. The better solution would + // probably be to parametize the value of + // *DEFAULT-PATHNAME-DEFAULTS* on invocations of + // truename(). + && !coerceToPathname(Symbol.DEFAULT_PATHNAME_DEFAULTS.symbolValue()).isJar()) + { LispObject truename = Pathname.truename((Pathname)o, errorIfDoesNotExist); - if (truename != null + if (truename != null && truename != NIL && truename instanceof Pathname) { Pathname truePathname = (Pathname)truename; // A jar that is a directory makes no sense, so exit Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp Wed Jan 4 13:48:45 2012 (r13717) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp Wed Jan 4 13:51:15 2012 (r13718) @@ -1653,11 +1653,6 @@ (let ((*package* package) (*default-pathname-defaults* (pathname-directory-pathname pathname))) - ;;; XXX Kludge for ABCL ticket #181 - #+abcl - (when (ext:pathname-jar-p pathname) - (setf *default-pathname-defaults* - (make-pathname :device nil :defaults *default-pathname-defaults*))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) (load pathname))) Modified: branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp ============================================================================== --- branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp Wed Jan 4 13:48:45 2012 (r13717) +++ branches/1.0.x/abcl/test/lisp/abcl/jar-pathname.lisp Wed Jan 4 13:51:15 2012 (r13718) @@ -481,8 +481,17 @@ "/foo/**/*.*") #p"/foo/d/e/f.lisp") - - - - - +;;; ticket #181 +;;; TODO Make reasons for failure more clear +(deftest jar-pathname.truename.1 + (let* ((abcl + (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname)) + (jar-entry + (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl)))) + (jar-entry-dir + (make-pathname :defaults jar-entry :name nil :type nil)) + (defaults + *default-pathname-defaults*)) + (let ((*default-pathname-defaults* jar-entry-dir)) + (not (probe-file (merge-pathnames jar-entry))))) + nil) From mevenson at common-lisp.net Thu Jan 5 05:42:07 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 04 Jan 2012 21:42:07 -0800 Subject: [armedbear-cvs] r13719 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Wed Jan 4 21:42:04 2012 New Revision: 13719 Log: abcl-1.0.0: update manual with light refresh. (Unfinished) use spell checker; start to fix broken references with an RDF vocabulary. Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Wed Jan 4 13:51:15 2012 (r13718) +++ trunk/abcl/doc/manual/abcl.tex Wed Jan 4 21:42:04 2012 (r13719) @@ -5,7 +5,7 @@ \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{November 24, 2011} +\date{January 5, 2012} \author{Mark~Evenson, Erik~H\"{u}lsmann, Alessio~Stalla, Ville~Voutilainen} \maketitle @@ -21,7 +21,7 @@ implementation for users of the system. \subsection{Version} -This manual corresponds to abcl-1.0.0, released on October 22, 2011. +This manual corresponds to abcl-1.0.1. \subsection{License} @@ -133,7 +133,7 @@ \end{itemize} Somewhat confusingly, this statement of non-conformance in the -accompanying user documentation fullfills the requirements that +accompanying user documentation fulfills the requirements that \textsc{ABCL} is a conforming ANSI Common Lisp implementation according to the CLHS \footnote{Common Lisp Hyperspec language reference document.}. Clarifications to this point are solicited. @@ -148,7 +148,7 @@ \subsection{Deficiencies} The following known problems detract from \textsc{ABCL} being a proper -contemporary Comon Lisp. +contemporary Common Lisp. \begin{itemize} \item An incomplete implementation of interactive debugging @@ -816,11 +816,18 @@ ABCL has created specializations of the ANSI Pathname object to enable to use of URIs to address dynamically loaded resources for the -JVM. A URL-PATHNAME has a corresponding URL whose cannoical +JVM. A URL-PATHNAME has a corresponding URL whose canonical representation is defined to be the NAMESTRING of the Pathname. +% \begin{verbatim} - JAR-PATHNAME isa URL-PATHNAME isa PATHNAME + +# RDF description of type hierarchy +% TODO Render via some LaTeX mode for graphviz? + + a . + a . + a . \end{verbatim} Both URL-PATHNAME and JAR-PATHNAME may be used anywhere a PATHNAME is @@ -848,7 +855,7 @@ will load and execute the Quicklisp setup code. -\ref{XACH2011} +See \ref{_:XACH2011} on page \pageref{_:XACH2011}. \subsubsection{Implementation} @@ -1051,7 +1058,7 @@ \label{section:jss} To one used to a syntax that can construct macros the Java syntax -may be said to suck, so we introduce the \#" macro. +may be said to suck, so we introduce the \code{SHARPSIGN-DOUBLE-QUOTE} \#" macro. \subsection{JSS usage} @@ -1101,10 +1108,12 @@ \begin{thebibliography}{9} +\label{_:1} \bibitem{Java2000} ``A New Era for Java Protocol Handlers.'' \url{http://java.sun.com/developer/onlineTraining/protocolhandlers/} +\label{_:XACH2011} \bibitem{Xach2011} Zach Beene ``Quicklisp: A system for quickly constructing Common Lisp'' From ehuelsmann at common-lisp.net Thu Jan 5 21:56:45 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 05 Jan 2012 13:56:45 -0800 Subject: [armedbear-cvs] r13720 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 5 13:56:44 2012 New Revision: 13720 Log: String hash randomization. Modified: trunk/abcl/src/org/armedbear/lisp/ComplexString.java trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/SimpleString.java Modified: trunk/abcl/src/org/armedbear/lisp/ComplexString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ComplexString.java Wed Jan 4 21:42:04 2012 (r13719) +++ trunk/abcl/src/org/armedbear/lisp/ComplexString.java Thu Jan 5 13:56:44 2012 (r13720) @@ -517,7 +517,7 @@ @Override public int sxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; final int limit = length(); for (int i = 0; i < limit; i++) { @@ -535,7 +535,7 @@ @Override public int psxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; final int limit = length(); for (int i = 0; i < limit; i++) { Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Wed Jan 4 21:42:04 2012 (r13719) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Thu Jan 5 13:56:44 2012 (r13720) @@ -141,6 +141,13 @@ // End-of-file marker. public static final LispObject EOF = new LispObject(); + // String hash randomization base + // Sets a base offset hashing value per JVM session, as an antidote to + // http://www.nruns.com/_downloads/advisory28122011.pdf + // (Denial of Service through hash table multi-collisions) + public static final int randomStringHashBase = + (int)(new java.util.Date().getTime()); + public static boolean profiling; public static boolean sampling; Modified: trunk/abcl/src/org/armedbear/lisp/SimpleString.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/SimpleString.java Wed Jan 4 21:42:04 2012 (r13719) +++ trunk/abcl/src/org/armedbear/lisp/SimpleString.java Thu Jan 5 13:56:44 2012 (r13720) @@ -416,7 +416,7 @@ @Override public int sxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; for (int i = 0; i < capacity; i++) { hashCode += chars[i]; hashCode += (hashCode << 10); @@ -426,13 +426,13 @@ hashCode ^= (hashCode >> 11); hashCode += (hashCode << 15); return (hashCode & 0x7fffffff); - } + } // For EQUALP hash tables. @Override public int psxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; for (int i = 0; i < capacity; i++) { hashCode += Character.toUpperCase(chars[i]); hashCode += (hashCode << 10); From mevenson at common-lisp.net Fri Jan 6 14:29:57 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Jan 2012 06:29:57 -0800 Subject: [armedbear-cvs] r13721 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jan 6 06:29:51 2012 New Revision: 13721 Log: backport r13720: randomize string hash computation to guard against exploits. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/ComplexString.java branches/1.0.x/abcl/src/org/armedbear/lisp/Lisp.java branches/1.0.x/abcl/src/org/armedbear/lisp/SimpleString.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/ComplexString.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/ComplexString.java Thu Jan 5 13:56:44 2012 (r13720) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/ComplexString.java Fri Jan 6 06:29:51 2012 (r13721) @@ -517,7 +517,7 @@ @Override public int sxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; final int limit = length(); for (int i = 0; i < limit; i++) { @@ -535,7 +535,7 @@ @Override public int psxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; final int limit = length(); for (int i = 0; i < limit; i++) { Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Lisp.java Thu Jan 5 13:56:44 2012 (r13720) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Lisp.java Fri Jan 6 06:29:51 2012 (r13721) @@ -141,6 +141,13 @@ // End-of-file marker. public static final LispObject EOF = new LispObject(); + // String hash randomization base + // Sets a base offset hashing value per JVM session, as an antidote to + // http://www.nruns.com/_downloads/advisory28122011.pdf + // (Denial of Service through hash table multi-collisions) + public static final int randomStringHashBase = + (int)(new java.util.Date().getTime()); + public static boolean profiling; public static boolean sampling; Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/SimpleString.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/SimpleString.java Thu Jan 5 13:56:44 2012 (r13720) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/SimpleString.java Fri Jan 6 06:29:51 2012 (r13721) @@ -416,7 +416,7 @@ @Override public int sxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; for (int i = 0; i < capacity; i++) { hashCode += chars[i]; hashCode += (hashCode << 10); @@ -426,13 +426,13 @@ hashCode ^= (hashCode >> 11); hashCode += (hashCode << 15); return (hashCode & 0x7fffffff); - } + } // For EQUALP hash tables. @Override public int psxhash() { - int hashCode = 0; + int hashCode = randomStringHashBase; for (int i = 0; i < capacity; i++) { hashCode += Character.toUpperCase(chars[i]); hashCode += (hashCode << 10); From mevenson at common-lisp.net Fri Jan 6 14:32:49 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Jan 2012 06:32:49 -0800 Subject: [armedbear-cvs] r13722 - branches/1.0.x/abcl Message-ID: Author: mevenson Date: Fri Jan 6 06:32:48 2012 New Revision: 13722 Log: backport r13709: spellcheck README. Modified: branches/1.0.x/abcl/README Modified: branches/1.0.x/abcl/README ============================================================================== --- branches/1.0.x/abcl/README Fri Jan 6 06:29:51 2012 (r13721) +++ branches/1.0.x/abcl/README Fri Jan 6 06:32:48 2012 (r13722) @@ -64,7 +64,7 @@ * Use the Ant build tool for Java environments. -* Use the Netbeans 6.x IDE to open ABCL as a project. +* Use the NetBeans 6.x IDE to open ABCL as a project. * Bootstrap ABCL using a Common Lisp implementation. Supported implementations for this process: SBCL, CMUCL, OpenMCL, Allegro @@ -105,7 +105,7 @@ Using NetBeans -------------- -Obtain and install the [Netbeans IDE][2]. One should be able to open +Obtain and install the [NetBeans IDE][2]. One should be able to open the ABCL directory as a project in the Netbeans 6.x application, whereupon the usual build, run, and debug targets as invoked in the GUI are available. @@ -127,7 +127,7 @@ situation, paying attention to the comments in the file. The critical step is to have Lisp special variable '*JDK*' point to the root of the Java Development Kit. Underneath the directory referenced by the -value of '*JDK*' there should be an exectuable Java compiler in +value of '*JDK*' there should be an executable Java compiler in 'bin/javac' ('bin/java.exe' under Windows). Then, one may either use the 'build-from-lisp.sh' shell script or load @@ -176,8 +176,8 @@ ABCL is a conforming ANSI Common Lisp implementation. Any other behavior should be reported as a bug. -ABCL now has a manual stating its confomance to the ANSI standard, -providing a compliant and practicalCommon Lisp implementation. +ABCL now has a manual stating its conformance to the ANSI standard, +providing a compliant and practical Common Lisp implementation. Because of this, @@ -188,7 +188,7 @@ Maxima's test suite runs without failures. -### Deficencies +### Deficiencies The MOP implementation is incomplete. From mevenson at common-lisp.net Fri Jan 6 14:34:39 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Jan 2012 06:34:39 -0800 Subject: [armedbear-cvs] r13723 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jan 6 06:34:39 2012 New Revision: 13723 Log: backport r13705: internal Java API for looking up internal vs. external symbols. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Package.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Package.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Package.java Fri Jan 6 06:32:48 2012 (r13722) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Package.java Fri Jan 6 06:34:39 2012 (r13723) @@ -209,11 +209,21 @@ return internalSymbols.get(name.toString()); } + public Symbol findInternalSymbol(String name) + { + return internalSymbols.get(name); + } + public Symbol findExternalSymbol(SimpleString name) { return externalSymbols.get(name.toString()); } + public Symbol findExternalSymbol(String name) + { + return externalSymbols.get(name); + } + public Symbol findExternalSymbol(SimpleString name, int hash) { return externalSymbols.get(name.toString()); From mevenson at common-lisp.net Fri Jan 6 14:35:40 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 06 Jan 2012 06:35:40 -0800 Subject: [armedbear-cvs] r13724 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Fri Jan 6 06:35:39 2012 New Revision: 13724 Log: backport r13706: use new API to fix Stream.readToken() bug reported by Blake McBride. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java Fri Jan 6 06:34:39 2012 (r13723) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java Fri Jan 6 06:35:39 2012 (r13724) @@ -1030,11 +1030,8 @@ if (Symbol.READ_SUPPRESS.symbolValue(thread) != NIL) return NIL; final LispObject readtableCase = rt.getReadtableCase(); - final String token; - if (readtableCase == Keyword.INVERT) - token = invert(sb.toString(), flags); - else - token = sb.toString(); + final String token = sb.toString(); + final boolean invert = readtableCase == Keyword.INVERT; final int length = token.length(); if (length > 0) { final char firstChar = token.charAt(0); @@ -1073,33 +1070,62 @@ return number; } } - if (firstChar == ':') - if (flags == null || !flags.get(0)) - return PACKAGE_KEYWORD.intern(token.substring(1)); - int index = findUnescapedDoubleColon(token, flags); - if (index > 0) { - String packageName = token.substring(0, index); - String symbolName = token.substring(index + 2); - Package pkg = Packages.findPackage(packageName); - if (pkg == null) - return error(new LispError("Package \"" + packageName + - "\" not found.")); - return pkg.intern(symbolName); + + String symbolName; + String packageName = null; + BitSet symbolFlags; + BitSet packageFlags = null; + Package pkg = null; + boolean internSymbol = true; + if (firstChar == ':' && (flags == null || !flags.get(0))) { + symbolName = token.substring(1); + pkg = PACKAGE_KEYWORD; + if (flags != null) + symbolFlags = flags.get(1, flags.size()); + else + symbolFlags = null; + } else { + int index = findUnescapedDoubleColon(token, flags); + if (index > 0) { + packageName = token.substring(0, index); + packageFlags = (flags != null) ? flags.get(0, index) : null; + symbolName = token.substring(index + 2); + symbolFlags = (flags != null) ? flags.get(index+2, flags.size()) : null; + } else { + index = findUnescapedSingleColon(token, flags); + if (index > 0) { + packageName = token.substring(0, index); + packageFlags = (flags != null) ? flags.get(0, index) : null; + symbolName = token.substring(index + 1); + symbolFlags = (flags != null) ? flags.get(index+2, flags.size()) : null; + internSymbol = false; + } else { + pkg = (Package)Symbol._PACKAGE_.symbolValue(thread); + symbolName = token; + symbolFlags = flags; + } + } } - index = findUnescapedSingleColon(token, flags); - if (index > 0) { - final String packageName = token.substring(0, index); - Package pkg = Packages.findPackage(packageName); + if (pkg == null) { + if (invert) + packageName = invert(packageName, packageFlags); + + pkg = Packages.findPackage(packageName); if (pkg == null) - return error(new PackageError("Package \"" + packageName + - "\" not found.")); - final String symbolName = token.substring(index + 1); - final SimpleString s = new SimpleString(symbolName); - Symbol symbol = pkg.findExternalSymbol(s); + return error(new ReaderError("The package \"" + packageName + "\" can't be found.", this)); + } + if (invert) + symbolName = invert(symbolName, symbolFlags); + + if (internSymbol) { + return pkg.intern(symbolName); + } else { + Symbol symbol = pkg.findExternalSymbol(symbolName); if (symbol != null) return symbol; + // Error! - if (pkg.findInternalSymbol(s) != null) + if (pkg.findInternalSymbol(symbolName) != null) return error(new ReaderError("The symbol \"" + symbolName + "\" is not external in package " + packageName + '.', @@ -1111,8 +1137,7 @@ this)); } } - // Intern token in current package. - return ((Package)Symbol._PACKAGE_.symbolValue(thread)).intern(new SimpleString(token)); + return error(new ReaderError("Can't intern zero-length symbol.", this)); } private final BitSet _readToken(StringBuilder sb, Readtable rt) From ehuelsmann at common-lisp.net Fri Jan 6 22:14:09 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 06 Jan 2012 14:14:09 -0800 Subject: [armedbear-cvs] r13725 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 6 14:14:08 2012 New Revision: 13725 Log: Patch by Rudi Schlatte: Move EqualSpecializerObject to clos.lisp. Deleted: trunk/abcl/src/org/armedbear/lisp/EqualSpecializerObject.java 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 Fri Jan 6 06:35:39 2012 (r13724) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 6 14:14:08 2012 (r13725) @@ -1189,6 +1189,10 @@ (setf (std-slot-value instance 'sys::object) object) instance)))) +(defun eql-specializer-object (eql-specializer) + (check-type eql-specializer eql-specializer) + (std-slot-value eql-specializer 'sys::object)) + ;; MOP (p. 216) specifies the following reader generic functions: ;; generic-function-argument-precedence-order ;; generic-function-declarations From ehuelsmann at common-lisp.net Fri Jan 6 22:45:49 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Fri, 06 Jan 2012 14:45:49 -0800 Subject: [armedbear-cvs] r13726 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Fri Jan 6 14:45:48 2012 New Revision: 13726 Log: Patch by Rudi Schlatte: Make method combinations real classes. Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 6 14:14:08 2012 (r13725) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 6 14:45:48 2012 (r13726) @@ -425,6 +425,15 @@ addStandardClass(Symbol.GENERIC_FUNCTION, list(METAOBJECT, BuiltInClass.FUNCTION)); + public static final StandardClass METHOD_COMBINATION = + addStandardClass(Symbol.METHOD_COMBINATION, list(METAOBJECT)); + + public static final StandardClass SHORT_METHOD_COMBINATION = + addStandardClass(Symbol.SHORT_METHOD_COMBINATION, list(METHOD_COMBINATION)); + + public static final StandardClass LONG_METHOD_COMBINATION = + addStandardClass(Symbol.LONG_METHOD_COMBINATION, list(METHOD_COMBINATION)); + public static final StandardClass CLASS = addStandardClass(Symbol.CLASS, list(SPECIALIZER)); @@ -651,6 +660,42 @@ EQL_SPECIALIZER.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT"))))); METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); + METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + METHOD_COMBINATION.setDirectSlotDefinitions( + list(new SlotDefinition(Symbol.NAME, + list(Symbol.METHOD_COMBINATION_NAME)), + new SlotDefinition(Symbol.DOCUMENTATION, + list(Symbol.METHOD_COMBINATION_DOCUMENTATION)))); + SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION, + METHOD_COMBINATION, METAOBJECT, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + SHORT_METHOD_COMBINATION.setDirectSlotDefinitions( + list(new SlotDefinition(Symbol.OPERATOR, + list(Symbol.SHORT_METHOD_COMBINATION_OPERATOR)), + new SlotDefinition(Symbol.IDENTITY_WITH_ONE_ARGUMENT, + list(Symbol.SHORT_METHOD_COMBINATION_IDENTITY_WITH_ONE_ARGUMENT)))); + LONG_METHOD_COMBINATION.setCPL(LONG_METHOD_COMBINATION, + METHOD_COMBINATION, METAOBJECT, + STANDARD_OBJECT, BuiltInClass.CLASS_T); + LONG_METHOD_COMBINATION.setDirectSlotDefinitions( + list(new SlotDefinition(Symbol.LAMBDA_LIST, + list(Symbol.LONG_METHOD_COMBINATION_LAMBDA_LIST)), + new SlotDefinition(Symbol.METHOD_GROUP_SPECS, + list(Symbol.LONG_METHOD_COMBINATION_METHOD_GROUP_SPECS)), + new SlotDefinition(Symbol.ARGS_LAMBDA_LIST, + list(Symbol.LONG_METHOD_COMBINATION_ARGS_LAMBDA_LIST)), + new SlotDefinition(Symbol.GENERIC_FUNCTION_SYMBOL, + list(Symbol.LONG_METHOD_COMBINATION_GENERIC_FUNCTION_SYMBOL)), + new SlotDefinition(Symbol.FUNCTION, + list(Symbol.LONG_METHOD_COMBINATION_FUNCTION)), + new SlotDefinition(Symbol.ARGUMENTS, + list(Symbol.LONG_METHOD_COMBINATION_ARGUMENTS)), + new SlotDefinition(Symbol.DECLARATIONS, + list(Symbol.LONG_METHOD_COMBINATION_DECLARATIONS)), + new SlotDefinition(Symbol.FORMS, + list(Symbol.LONG_METHOD_COMBINATION_FORMS)))); + PACKAGE_ERROR.setCPL(PACKAGE_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); PACKAGE_ERROR.setDirectSlotDefinitions( @@ -740,6 +785,9 @@ METAOBJECT.finalizeClass(); SPECIALIZER.finalizeClass(); EQL_SPECIALIZER.finalizeClass(); + METHOD_COMBINATION.finalizeClass(); + SHORT_METHOD_COMBINATION.finalizeClass(); + LONG_METHOD_COMBINATION.finalizeClass(); PACKAGE_ERROR.finalizeClass(); PARSE_ERROR.finalizeClass(); PRINT_NOT_READABLE.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 6 14:14:08 2012 (r13725) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 6 14:45:48 2012 (r13726) @@ -2971,6 +2971,10 @@ PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER"); public static final Symbol EQL_SPECIALIZER_OBJECT = PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER-OBJECT"); + public static final Symbol SHORT_METHOD_COMBINATION = + PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); + public static final Symbol LONG_METHOD_COMBINATION = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION"); public static final Symbol METAOBJECT = PACKAGE_MOP.addExternalSymbol("METAOBJECT"); public static final Symbol SPECIALIZER = @@ -2987,6 +2991,48 @@ PACKAGE_MOP.addExternalSymbol("STANDARD-DIRECT-SLOT-DEFINITION"); public static final Symbol STANDARD_EFFECTIVE_SLOT_DEFINITION = PACKAGE_MOP.addExternalSymbol("STANDARD-EFFECTIVE-SLOT-DEFINITION"); + // MOP method combination readers. + public static final Symbol METHOD_COMBINATION_NAME = + PACKAGE_MOP.addInternalSymbol("METHOD-COMBINATION-NAME"); + public static final Symbol METHOD_COMBINATION_DOCUMENTATION = + PACKAGE_MOP.addInternalSymbol("METHOD-COMBINATION-DOCUMENTATION"); + public static final Symbol SHORT_METHOD_COMBINATION_OPERATOR = + PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION-OPERATOR"); + public static final Symbol SHORT_METHOD_COMBINATION_IDENTITY_WITH_ONE_ARGUMENT = + PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT"); + public static final Symbol LONG_METHOD_COMBINATION_LAMBDA_LIST = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-LAMBDA-LIST"); + public static final Symbol LONG_METHOD_COMBINATION_METHOD_GROUP_SPECS = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-METHOD-GROUP-SPECS"); + public static final Symbol LONG_METHOD_COMBINATION_ARGS_LAMBDA_LIST = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-ARGS-LAMBDA-LIST"); + public static final Symbol LONG_METHOD_COMBINATION_GENERIC_FUNCTION_SYMBOL = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-GENERIC-FUNCTION-SYMBOL"); + public static final Symbol LONG_METHOD_COMBINATION_FUNCTION = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FUNCTION"); + public static final Symbol LONG_METHOD_COMBINATION_ARGUMENTS = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-ARGUMENTS"); + public static final Symbol LONG_METHOD_COMBINATION_DECLARATIONS = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-DECLARATIONS"); + public static final Symbol LONG_METHOD_COMBINATION_FORMS = + PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FORMS"); + public static final Symbol OPERATOR = + PACKAGE_MOP.addInternalSymbol("OPERATOR"); + public static final Symbol IDENTITY_WITH_ONE_ARGUMENT = + PACKAGE_MOP.addInternalSymbol("IDENTITY-WITH-ONE-ARGUMENT"); + public static final Symbol METHOD_GROUP_SPECS = + PACKAGE_MOP.addInternalSymbol("METHOD-GROUP-SPECS"); + public static final Symbol ARGS_LAMBDA_LIST = + PACKAGE_MOP.addInternalSymbol("ARGS-LAMBDA-LIST"); + public static final Symbol GENERIC_FUNCTION_SYMBOL = + PACKAGE_MOP.addInternalSymbol("GENERIC-FUNCTION-SYMBOL"); + public static final Symbol ARGUMENTS = + PACKAGE_MOP.addInternalSymbol("ARGUMENTS"); + public static final Symbol DECLARATIONS = + PACKAGE_MOP.addInternalSymbol("DECLARATIONS"); + public static final Symbol FORMS = + PACKAGE_MOP.addInternalSymbol("FORMS"); + // Java interface. public static final Symbol JAVA_EXCEPTION = @@ -3138,6 +3184,8 @@ PACKAGE_SYS.addInternalSymbol("LISP-STACK-FRAME"); public static final Symbol JAVA_STACK_FRAME = PACKAGE_SYS.addInternalSymbol("JAVA-STACK-FRAME"); + public static final Symbol LAMBDA_LIST = + PACKAGE_SYS.addInternalSymbol("LAMBDA-LIST"); // CDR6 public static final Symbol _INSPECTOR_HOOK_ = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 6 14:14:08 2012 (r13725) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 6 14:45:48 2012 (r13726) @@ -826,26 +826,6 @@ ,(canonicalize-direct-slots direct-slots) ,@(canonicalize-defclass-options options))) -(defstruct method-combination - name - documentation) - -(defstruct (short-method-combination - (:include method-combination)) - operator - identity-with-one-argument) - -(defstruct (long-method-combination - (:include method-combination)) - lambda-list - method-group-specs - args-lambda-list - generic-function-symbol - function - arguments - declarations - forms) - (defun expand-long-defcombin (name args) (destructuring-bind (lambda-list method-groups &rest body) args `(apply #'define-long-form-method-combination @@ -854,6 +834,96 @@ (list ,@(mapcar #'canonicalize-method-group-spec method-groups)) ',body))) +;;; The class method-combination and its subclasses are defined in +;;; StandardClass.java, but we cannot use make-instance and slot-value +;;; yet. +(defun make-short-method-combination (&key name documentation operator identity-with-one-argument) + (let ((instance (std-allocate-instance (find-class 'short-method-combination)))) + (when name (setf (std-slot-value instance 'sys::name) name)) + (when documentation + (setf (std-slot-value instance 'documentation) documentation)) + (when operator (setf (std-slot-value instance 'operator) operator)) + (when identity-with-one-argument + (setf (std-slot-value instance 'identity-with-one-argument) + identity-with-one-argument)) + instance)) + +(defun make-long-method-combination (&key name documentation lambda-list + method-group-specs args-lambda-list + generic-function-symbol function + arguments declarations forms) + (let ((instance (std-allocate-instance (find-class 'long-method-combination)))) + (when name (setf (std-slot-value instance 'sys::name) name)) + (when documentation + (setf (std-slot-value instance 'documentation) documentation)) + (when lambda-list + (setf (std-slot-value instance 'sys::lambda-list) lambda-list)) + (when method-group-specs + (setf (std-slot-value instance 'method-group-specs) method-group-specs)) + (when args-lambda-list + (setf (std-slot-value instance 'args-lambda-list) args-lambda-list)) + (when generic-function-symbol + (setf (std-slot-value instance 'generic-function-symbol) + generic-function-symbol)) + (when function + (setf (std-slot-value instance 'function) function)) + (when arguments + (setf (std-slot-value instance 'arguments) arguments)) + (when declarations + (setf (std-slot-value instance 'declarations) declarations)) + (when forms + (setf (std-slot-value instance 'forms) forms)) + instance)) + +(defun method-combination-name (method-combination) + (check-type method-combination method-combination) + (std-slot-value method-combination 'sys::name)) + +(defun method-combination-documentation (method-combination) + (check-type method-combination method-combination) + (std-slot-value method-combination 'documentation)) + +(defun short-method-combination-operator (method-combination) + (check-type method-combination short-method-combination) + (std-slot-value method-combination 'operator)) + +(defun short-method-combination-identity-with-one-argument (method-combination) + (check-type method-combination short-method-combination) + (std-slot-value method-combination 'identity-with-one-argument)) + +(defun long-method-combination-lambda-list (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'sys::lambda-list)) + +(defun long-method-combination-method-group-specs (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'method-group-specs)) + +(defun long-method-combination-args-lambda-list (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'args-lambda-list)) + +(defun long-method-combination-generic-function-symbol (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'generic-function-symbol)) + +(defun long-method-combination-function (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'function)) + +(defun long-method-combination-arguments (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'arguments)) + +(defun long-method-combination-declarations (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'declarations)) + +(defun long-method-combination-forms (method-combination) + (check-type method-combination long-method-combination) + (std-slot-value method-combination 'forms)) + + (defun expand-short-defcombin (whole) (let* ((name (cadr whole)) (documentation From astalla at common-lisp.net Sat Jan 7 23:09:32 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Sat, 07 Jan 2012 15:09:32 -0800 Subject: [armedbear-cvs] r13727 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Sat Jan 7 15:09:30 2012 New Revision: 13727 Log: Class writer: basic support for annotations (only without parameters) Runtime-class: annotations on methods only, with no syntax sugar yet Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Fri Jan 6 14:45:48 2012 (r13726) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Sat Jan 7 15:09:30 2012 (r13727) @@ -1321,6 +1321,92 @@ (write-u2 (local-descriptor local-variable) stream) (write-u2 (local-index local-variable) stream))) +;;Annotations + +(defstruct (annotations-attribute + (:conc-name annotations-) + (:include attribute + ;;Name is to be provided by subtypes + (finalizer #'finalize-annotations) + (writer #'write-annotations))) + "An attribute of a class, method or field, containing a list of annotations. +This structure serves as the abstract supertype of concrete annotations types." + list ;; a list of annotation structures, in reverse order + ) + +(defstruct annotation + "Each value of the annotations table represents a single runtime-visible annotation on a program element. + The annotation structure has the following format: + annotation { + u2 type_index; + u2 num_element_value_pairs; + { + u2 element_name_index; + element_value value; + } element_value_pairs[num_element_value_pairs] + }" + type + elements) + +(defstruct annotation-element name value) + +(defstruct annotation-element-value tag finalizer writer) + +(defstruct (primitive-or-string-annotation-element-value + (:conc-name primitive-or-string-annotation-element-) + (:include annotation-element-value + (finalizer (lambda (self class) + (let ((value (primitive-or-string-annotation-element-value self))) + (etypecase value + (boolean + (setf (annotation-element-value-tag self) + (char-code #\B) + (primitive-or-string-annotation-element-value self) + (pool-add-int (class-file-constants class) (if value 1 0)))))))) + (writer (lambda (self stream) + (write-u1 (annotation-element-value-tag self) stream) + (write-u2 (primitive-or-string-annotation-element-value self) stream))))) + value) + +(defstruct (runtime-visible-annotations-attribute + (:include annotations-attribute + (name "RuntimeVisibleAnnotations") + (finalizer #'finalize-annotations) + (writer #'write-annotations))) + "4.8.15 The RuntimeVisibleAnnotations attribute +The RuntimeVisibleAnnotations attribute is a variable length attribute in the +attributes table of the ClassFile, field_info, and method_info structures. The +RuntimeVisibleAnnotations attribute records runtime-visible Java program- +ming language annotations on the corresponding class, method, or field. Each +ClassFile, field_info, and method_info structure may contain at most one +RuntimeVisibleAnnotations attribute, which records all the runtime-visible +Java programming language annotations on the corresponding program element. +The JVM must make these annotations available so they can be returned by the +appropriate reflective APIs.") + +(defun finalize-annotations (annotations code class) + (declare (ignore code)) + (dolist (ann (annotations-list annotations)) + (setf (annotation-type ann) + (pool-add-class (class-file-constants class) + (if (jvm-class-name-p (annotation-type ann)) + (annotation-type ann) + (make-jvm-class-name (annotation-type ann))))) + (dolist (elem (annotation-elements ann)) + (setf (annotation-element-name elem) + (pool-add-utf8 (class-file-constants class) + (annotation-element-name elem))) + (funcall (annotation-element-value-finalizer (annotation-element-value elem)) + (annotation-element-value elem) class)))) + +(defun write-annotations (annotations stream) + (write-u2 (length (annotations-list annotations)) stream) + (dolist (annotation (reverse (annotations-list annotations))) + (write-u2 (annotation-type annotation) stream) + (write-u2 (length (annotation-elements annotation)) stream) + (dolist (elem (reverse (annotation-elements annotation))) + (funcall (annotation-element-value-writer elem) elem stream)))) + #| ;; this is the minimal sequence we need to support: Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Fri Jan 6 14:45:48 2012 (r13726) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Sat Jan 7 15:09:30 2012 (r13727) @@ -1,4 +1,5 @@ (require "COMPILER-PASS2") +(require "JVM-CLASS-FILE") (in-package :jvm) @@ -25,10 +26,10 @@ be called with the second and first arguments. Method definitions are lists of the form - (method-name return-type argument-types function modifier*) + (method-name return-type argument-types function &key modifiers annotations) where method-name is a string, return-type and argument-types are strings or keywords for primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity - (1+ (length argument-types)); the instance (`this') is passed in as the last argument. + (1+ (length argument-types)); the instance (`this') is passed in as the first argument. Field definitions are lists of the form (field-name type modifier*) @@ -44,66 +45,69 @@ (setf (class-file-interfaces class-file) (mapcar #'make-jvm-class-name interfaces)) (dolist (m methods) - (destructuring-bind (name return-type argument-types function &rest flags) m - (let* ((argument-types (mapcar #'make-jvm-class-name argument-types)) - (argc (length argument-types)) - (return-type (if (keywordp return-type) - return-type - (make-jvm-class-name return-type))) - (jmethod (make-jvm-method name return-type argument-types :flags (or flags '(:public)))) - (field-name (string (gensym name)))) - (class-add-method class-file jmethod) - (let ((field (make-field field-name +lisp-object+ :flags '(:public :static)))) - (class-add-field class-file field) - (push (cons field-name function) method-implementation-fields)) - (with-code-to-method (class-file jmethod) - ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this") - (dotimes (i (* 2 (1+ argc))) - (allocate-register nil)) - ;;Box "this" (to be passed as the first argument to the Lisp function) - (aload 0) - (emit 'iconst_1) ;;true - (emit-invokestatic +abcl-java-object+ "getInstance" - (list +java-object+ :boolean) +lisp-object+) - (astore (1+ argc)) - ;;Box each argument - (loop - :for arg-type :in argument-types - :for i :from 1 - :do (progn - (cond - ((keywordp arg-type) - (error "Unsupported arg-type: ~A" arg-type)) - ((eq arg-type :int) :todo) - (t (aload i) - (emit 'iconst_1) ;;true - (emit-invokestatic +abcl-java-object+ "getInstance" - (list +java-object+ :boolean) +lisp-object+))) - (astore (+ i (1+ argc))))) - ;;Load the Lisp function from its static field - (emit-getstatic jvm-class-name field-name +lisp-object+) - (if (<= (1+ argc) call-registers-limit) - (progn - ;;Load the boxed this - (aload (1+ argc)) - ;;Load each boxed argument - (dotimes (i argc) - (aload (+ argc 2 i)))) - (error "execute(LispObject[]) is currently not supported")) - (emit-call-execute (1+ (length argument-types))) - (cond - ((eq return-type :void) - (emit 'pop) - (emit 'return)) - ((eq return-type :int) - (emit-invokevirtual +lisp-object+ "intValue" nil :int) - (emit 'ireturn)) - ((keywordp return-type) - (error "Unsupported return type: ~A" return-type)) - (t - (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) - (emit-checkcast return-type) - (emit 'areturn))))))) + (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m + (let* ((argument-types (mapcar #'make-jvm-class-name argument-types)) + (argc (length argument-types)) + (return-type (if (keywordp return-type) + return-type + (make-jvm-class-name return-type))) + (jmethod (make-jvm-method name return-type argument-types :flags modifiers)) + (field-name (string (gensym name)))) + (class-add-method class-file jmethod) + (let ((field (make-field field-name +lisp-object+ :flags '(:public :static)))) + (class-add-field class-file field) + (push (cons field-name function) method-implementation-fields)) + (when annotations + (method-add-attribute jmethod (make-runtime-visible-annotations-attribute + :list (mapcar #'parse-annotation annotations)))) + (with-code-to-method (class-file jmethod) + ;;Allocate registers (2 * argc to load and store arguments + 2 to box "this") + (dotimes (i (* 2 (1+ argc))) + (allocate-register nil)) + ;;Box "this" (to be passed as the first argument to the Lisp function) + (aload 0) + (emit 'iconst_1) ;;true + (emit-invokestatic +abcl-java-object+ "getInstance" + (list +java-object+ :boolean) +lisp-object+) + (astore (1+ argc)) + ;;Box each argument + (loop + :for arg-type :in argument-types + :for i :from 1 + :do (progn + (cond + ((keywordp arg-type) + (error "Unsupported arg-type: ~A" arg-type)) + ((eq arg-type :int) :todo) + (t (aload i) + (emit 'iconst_1) ;;true + (emit-invokestatic +abcl-java-object+ "getInstance" + (list +java-object+ :boolean) +lisp-object+))) + (astore (+ i (1+ argc))))) + ;;Load the Lisp function from its static field + (emit-getstatic jvm-class-name field-name +lisp-object+) + (if (<= (1+ argc) call-registers-limit) + (progn + ;;Load the boxed this + (aload (1+ argc)) + ;;Load each boxed argument + (dotimes (i argc) + (aload (+ argc 2 i)))) + (error "execute(LispObject[]) is currently not supported")) + (emit-call-execute (1+ (length argument-types))) + (cond + ((eq return-type :void) + (emit 'pop) + (emit 'return)) + ((eq return-type :int) + (emit-invokevirtual +lisp-object+ "intValue" nil :int) + (emit 'ireturn)) + ((jvm-class-name-p return-type) + (emit-invokevirtual +lisp-object+ "javaInstance" nil +java-object+) + (emit-checkcast return-type) + (emit 'areturn)) + (t + (error "Unsupported return type: ~A" return-type))))))) (when (null constructors) (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) (class-add-method class-file ctor) @@ -124,13 +128,17 @@ (setf (java:jfield jclass (car method)) (cdr method))) jclass))) +(defun parse-annotation (annotation) + annotation) ;;TODO + #+example (java:jnew-runtime-class "Foo" :interfaces (list "java.lang.Comparable") :methods (list (list "foo" :void '("java.lang.Object") - (lambda (this that) (print (list this that)))) + (lambda (this that) (print (list this that))) + :annotations (list (make-annotation :type "java.lang.Deprecated"))) (list "bar" :int '("java.lang.Object") (lambda (this that) (print (list this that)) 23)))) From mevenson at common-lisp.net Mon Jan 9 08:38:54 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 00:38:54 -0800 Subject: [armedbear-cvs] r13728 - branches/1.0.x/abcl/doc/manual Message-ID: Author: mevenson Date: Mon Jan 9 00:38:52 2012 New Revision: 13728 Log: Backport changes to manual en masse. Added: branches/1.0.x/abcl/doc/manual/README.markdown - copied unchanged from r13727, trunk/abcl/doc/manual/README.markdown branches/1.0.x/abcl/doc/manual/grovel.lisp - copied unchanged from r13727, trunk/abcl/doc/manual/grovel.lisp Modified: branches/1.0.x/abcl/doc/manual/abcl.sty branches/1.0.x/abcl/doc/manual/abcl.tex branches/1.0.x/abcl/doc/manual/extensions.tex branches/1.0.x/abcl/doc/manual/java.tex branches/1.0.x/abcl/doc/manual/threads.tex Copied: branches/1.0.x/abcl/doc/manual/README.markdown (from r13727, trunk/abcl/doc/manual/README.markdown) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ branches/1.0.x/abcl/doc/manual/README.markdown Mon Jan 9 00:38:52 2012 (r13728, copy of r13727, trunk/abcl/doc/manual/README.markdown) @@ -0,0 +1,6 @@ +ABCL User Manual +================ + +With a suitable TexLive installed, to build simply issue: + + cmd$ pdflatex abcl.tex && makeindex abcl && pdflatex abcl.tex Modified: branches/1.0.x/abcl/doc/manual/abcl.sty ============================================================================== --- branches/1.0.x/abcl/doc/manual/abcl.sty Sat Jan 7 15:09:30 2012 (r13727) +++ branches/1.0.x/abcl/doc/manual/abcl.sty Mon Jan 9 00:38:52 2012 (r13728) @@ -34,4 +34,12 @@ \usepackage{verbatim} +%% For setting margins in docstrings +\usepackage{changepage} + +\usepackage{makeidx} + +\makeindex + \ProvidesPackage{abcl} + Modified: branches/1.0.x/abcl/doc/manual/abcl.tex ============================================================================== --- branches/1.0.x/abcl/doc/manual/abcl.tex Sat Jan 7 15:09:30 2012 (r13727) +++ branches/1.0.x/abcl/doc/manual/abcl.tex Mon Jan 9 00:38:52 2012 (r13728) @@ -5,8 +5,8 @@ \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{October 21, 2011} -\author{Mark~Evenson, Erik~Huelsmann, Alessio~Stalla, Ville~Voutilainen} +\date{January 5, 2012} +\author{Mark~Evenson, Erik~H\"{u}lsmann, Alessio~Stalla, Ville~Voutilainen} \maketitle @@ -14,12 +14,14 @@ \chapter{Introduction} -Armed Bear is a (mostly) conforming implementation of the ANSI Common -Lisp standard. This manual documents the Armed Bear Common Lisp +Armed Bear is a conforming implementation of the ANSI Common Lisp +standard (see \ref{chapter:conformance} on page +\pageref{chapter:conformance} which states the details of the +conformance level. This manual documents the Armed Bear Common Lisp implementation for users of the system. \subsection{Version} -This manual corresponds to abcl-1.0.0, released on October 22, 2011. +This manual corresponds to abcl-1.0.1. \subsection{License} @@ -52,21 +54,22 @@ \textsc{ABCL} is packaged as a single jar file usually named either ``abcl.jar'' or possibly``abcl-1.0.0.jar'' if one is using a versioned package from your system vendor. This byte archive can be executed -under the control of a suitable JVM by using the ``-jar'' option to -parse the manifest, and select the named class -(\code{org.armedbear.lisp.Main}) for execution, viz: +under the control of a suitable JVM \footnote {Java Virtual Machine} +by using the ``-jar'' option to parse the manifest, and select the +class named therein ``\code{org.armedbear.lisp.Main}'' for execution, +viz: \begin{listing-shell} cmd$ java -jar abcl.jar \end{listing-shell} -N.b. for the proceeding command to work, the ``java'' executable needs +\emph{N.b.} for the proceeding command to work, the ``java'' executable needs to be in your path. To make it easier to facilitate the use of ABCL in tool chains (such as SLIME \footnote{SLIME is the Superior Lisp Mode for Interaction under Emacs}) the invocation is wrapped in a Bourne shell script -under UNIX or a DOS command script under Windows so that ABCL may be +under \textsc{UNIX} or a \textsc{DOS} command script under Windows so that ABCL may be executed simply as: \begin{listing-shell} @@ -106,7 +109,7 @@ \section{Initialization} -If the ABCL process is started without the ``--noinit'' flag, it +If the \textsc{ABCL} process is started without the ``--noinit'' flag, it attempts to load a file named ``.abclrc'' located in the user's home directory and then interpret its contents. @@ -116,6 +119,7 @@ JVM implementation that \textsc{ABCL} finds itself hosted upon. \chapter{Conformance} +\label{chapter:conformance} \section{ANSI Common Lisp} \textsc{ABCL} is currently a (non)-conforming ANSI Common Lisp @@ -129,7 +133,7 @@ \end{itemize} Somewhat confusingly, this statement of non-conformance in the -accompanying user documentation fullfills the requirements that +accompanying user documentation fulfills the requirements that \textsc{ABCL} is a conforming ANSI Common Lisp implementation according to the CLHS \footnote{Common Lisp Hyperspec language reference document.}. Clarifications to this point are solicited. @@ -144,10 +148,18 @@ \subsection{Deficiencies} The following known problems detract from \textsc{ABCL} being a proper -contemporary Comon Lisp. +contemporary Common Lisp. \begin{itemize} + + \item An incomplete implementation of interactive debugging + mechanisms namely a no-op version of + \code{STEP} \footnote{Somewhat surprisingly allowed by + \textsc{ANSI}}, the inability to inspect local variables in a + given call frame, and the inability to resume a halted computation + at an arbitrarily selected call frame. + \item An incomplete implementation of a properly named metaobject - protocol (viz. (A)MOP \footnote{Another Metaobject Protocol} ) + protocol (viz. (A)MOP \footnote{The Art of the Metaobject Protocol} ) % N.b. % TODO go through AMOP with symbols, starting by looking for @@ -161,7 +173,7 @@ byte-level manipulations. \item Incomplete documentation (missing docstrings from exported - symbols. + symbols and the draft status of the User Manual). \end{itemize} @@ -200,11 +212,12 @@ \subsection{Low-level Java API} -We define a higher level Java API in the \ref{topic:Higher level Java - API: JSS}(JSS package) which is available in the \code{contrib/} \ref{topic:contrib} -directory. This package is described later in this document. This -section covers the lower level API directly available after evaluating -\code{(require 'JAVA)}. +We define a higher level Java API in the topic:Higher level Java JSS +package developed by Alan Ruttenberg which is available in the +\code{contrib/} directory, see the . This package is +described later in this document, see \ref{section:jss} on page +\pageref{section:jss}. This section covers the lower level API +directly available after evaluating \code{(require 'JAVA)}. \subsubsection{Calling Java Object Methods} @@ -747,12 +760,10 @@ CL-USER> (add-to-classpath "/path/to/some.jar") \end{listing-lisp} -N.b \code{add-to-classpath} only affects the classloader used by ABCL +N.b \code{ADD-TO-CLASSPATH} only affects the classloader used by ABCL (the value of the special variable \code{JAVA:*CLASSLOADER*}. It has no effect on Java code outside ABCL. -\subsection{API} - % include autogen docs for the JAVA package. \include{java} @@ -763,8 +774,6 @@ excellent \code{java.util.concurrent} packages may be manipulated directly via the JSS contrib to great effect. -\subsection{API} - % include autogen docs for the THREADS package. \include{threads} @@ -776,10 +785,8 @@ running external programs, registering object finalizers, constructing reference weakly held by the garbage collector and others. -See \ref{Extensible Sequences} for a generic function interface to -the native JVM contract for \code{java.util.List}. - -\subsection{API} +See \ref{Rhodes2007} for a generic function interface to the native +JVM contract for \code{java.util.List}. % include autogen docs for the EXTENSIONS package. \include{extensions} @@ -804,15 +811,23 @@ JVM ``understands''. Support is built-in to the ``http'' and ``https'' implementations but additional protocol handlers may be installed at runtime by having JVM symbols present in the -sun.net.protocol.dynmamic pacakge. See [JAVA2006] for more details. +sun.net.protocol.dynmamic pacakge. See Java2007 \cite{Java2007} for more +details. ABCL has created specializations of the ANSI Pathname object to enable to use of URIs to address dynamically loaded resources for the -JVM. A URL-PATHNAME has a corresponding URL whose cannoical +JVM. A URL-PATHNAME has a corresponding URL whose canonical representation is defined to be the NAMESTRING of the Pathname. +% \begin{verbatim} - JAR-PATHNAME isa URL-PATHNAME isa PATHNAME + +# RDF description of type hierarchy +% TODO Render via some LaTeX mode for graphviz? + + a . + a . + a . \end{verbatim} Both URL-PATHNAME and JAR-PATHNAME may be used anywhere a PATHNAME is @@ -832,7 +847,7 @@ \end{itemize} The implementation of URL-PATHNAME allows the ABCL user to laod dynamically -code from the network. For example, for Quicklisp. +code from the network. For example, for Quicklisp (\cite{Xach2011}): \begin{listing-lisp} CL-USER> (load "http://beta.quicklisp.org/quicklisp.lisp") @@ -840,16 +855,16 @@ will load and execute the Quicklisp setup code. -\ref{XACH2011} +See \ref{_:XACH2011} on page \pageref{_:XACH2011}. \subsubsection{Implementation} -\textsc{DEVICE} either a string denoting a drive letter under DOS or a cons -specifying a \textsc{URL-PATHNAME}. +\code{DEVICE} either a string denoting a drive letter under DOS or a cons +specifying a \code{URL-PATHNAME}. \section{Extensible Sequences} -See \ref{RHODES2007} RHODES2007 for the design. +See Rhodes2007 \cite{RHODES2007} for the design. The SEQUENCE package fully implements Christopher Rhodes' proposal for extensible sequences. These user extensible sequences are used @@ -931,14 +946,18 @@ \subsection{JSS optionally extends the Reader} The JSS contrib consitutes an additional, optional extension to the -reader in the definition of the \#\" reader macro. +reader in the definition of the \#\" reader macro. See +\ref{section:jss} on page \pageref{section:jss} for more information. \section{ASDF} asdf-2.017.22 is packaged as core component of ABCL, but not -intialized by default, as it relies on the CLOS subsystem which can -take a bit of time to initialize. It may be initialized by the ANSI -\textsc{REQUIRE} mechanism as follows: +initialized by default, as it relies on the CLOS subsystem which can +take a bit of time to start \footnote{While this time is ``merely'' on + the order of seconds for contemporary 2011 machines, for + applications that need to initialize quickly, for example a web + server, this time might be unnecessarily long}. ASDF may be loaded +by the \textsc{ANSI} \code{REQUIRE} mechanism as follows: \begin{listing-lisp} CL-USER> (require 'asdf) @@ -946,23 +965,39 @@ \chapter{Contrib} +The ABCL contrib is packaged as a separate jar archive usually named +\code{abcl-contrib.jar} or possibly something like +\code{abcl-contrib-1.0.0.jar}. The contrib jar is not loaded by the +implementation by default, and must be first intialized by the +\code{REQUIRE} mechanism before using any specific contrib: + +\begin{listing-lisp} +CL-USER> (require 'abcl-contrib) +\end{listing-lisp} + \section{abcl-asdf} -This contrib to ABCL enables an additional syntax for ASDF system -definition which dynamically loads JVM artifacts such as jar archives -via a Maven encapsulation. The Maven Aether can also be directly -manipulated by the function associated with the RESOLVE-DEPENDENCIES symbol. +This contrib enables an additional syntax for \textsc{ASDF} system +definition which dynamically loads \textsc{JVM} artifacts such as jar +archives via encapsulation of the Maven build tool. The Maven Aether +component can also be directly manipulated by the function associated +with the \code{ABCL-ASDF:RESOLVE-DEPENDENCIES} symbol. -%ABCL specific contributions to ASDF system definition mainly concerned -%with finding JVM artifacts such as jar archives to be dynamically loaded. +%ABCL specific contributions to ASDF system definition mainly +%concerned with finding JVM artifacts such as jar archives to be +%dynamically loaded. -The following ASDF components are added: \textsc{JAR-FILE}, \textsc{JAR-DIRECTORY}, -\textsc{CLASS-FILE-DIRECTORY} and \textsc{MVN}. +The following \textsc{ASDF} components are added: \code{JAR-FILE}, +\code{JAR-DIRECTORY}, \code{CLASS-FILE-DIRECTORY} and \code{MVN}. +\subsection{Referencing Maven Artifacts via ASDF} -\subsection{ABCL-ASDF Examples} +Maven artifacts may be referenced within \textsc{ASDF} system +definitions, as the following example references the +\code{log4j-1.4.9.jar} JVM artifact which provides a widely-used +abstraction for handling logging systems: \begin{listing-lisp} ;;;; -*- Mode: LISP -*- @@ -973,75 +1008,85 @@ :version "1.4.9"))) \end{listing-lisp} -\subsection{abcl-asdf API} +\subsection{API} -We define an API as consisting of the following ASDF classes: +We define an API for \textsc{ABCL-ASDF} as consisting of the following +ASDF classes: -\textsc{JAR-DIRECTORY}, \textsc{JAR-FILE}, and -\textsc{CLASS-FILE-DIRECTORY} for JVM artifacts that have a currently -valid pathname representation +\code{JAR-DIRECTORY}, \code{JAR-FILE}, and +\code{CLASS-FILE-DIRECTORY} for JVM artifacts that have a currently +valid pathname representation. -And the MVN and IRI classes descend from ASDF-COMPONENT, but do not +Both the MVN and IRI classes descend from ASDF-COMPONENT, but do not directly have a filesystem location. -For use outside of ASDF, we currently define one method, -\textsc{RESOLVE-DEPENDENCIES} which locates, downloads, caches, and then loads -into the currently executing JVM process all recursive dependencies -annotated in the Maven pom.xml graph. +For use outside of ASDF system definitions, we currently define one +method, \code{ABCL-ASDF:RESOLVE-DEPENDENCIES} which locates, +downloads, caches, and then loads into the currently executing JVM +process all recursive dependencies annotated in the Maven pom.xml +graph. -\subsection{ABCL-ASDF Example 2} +\subsection{Directly Instructing Maven to Download JVM Artifacts} -Bypassing ASDF, one can directly issue requests for the Maven +Bypassing \textsc{ASDF}, one can directly issue requests for the Maven artifacts to be downloaded \begin{listing-lisp} - CL-USER> (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user") - WARNING: Using LATEST for unspecified version. - "/Users/evenson/.m2/repository/com/google/gwt/gwt-user/2.4.0-rc1/gwt-user-2.4.0-rc1.jar:/Users/evenson/.m2/repository/javax/validation/validation-api/1.0.0.GA/validation-api-1.0.0.GA.jar:/Users/evenson/.m2/repository/javax/validation/validation-api/1.0.0.GA/validation-api-1.0.0.GA-sources.jar" +CL-USER> (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user") +WARNING: Using LATEST for unspecified version. +"/Users/evenson/.m2/repository/com/google/gwt/gwt-user/2.4.0-rc1/gwt-user-2.4.0-rc1.jar:/Users/evenson/.m2/repository/javax/validation/validation-api/1.0.0.GA/validation-api-1.0.0.GA.jar:/Users/evenson/.m2/repository/javax/validation/validation-api/1.0.0.GA/validation-api-1.0.0.GA-sources.jar" \end{listing-lisp} -To actually load the dependency, use the JAVA:ADD-TO-CLASSPATH generic +To actually load the dependency, use the \code{JAVA:ADD-TO-CLASSPATH} generic function: \begin{listing-lisp} - CL-USER> (java:add-to-classpath (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user")) +CL-USER> (java:add-to-classpath (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user")) \end{listing-lisp} Notice that all recursive dependencies have been located and installed locally from the network as well. - \section{asdf-jar} -ASDF-JAR provides a system for packaging ASDF systems into jar -archives for ABCL. Given a running ABCL image with loadable ASDF +The asdf-jar contrib provides a system for packaging ASDF systems into +jar archives for ABCL. Given a running ABCL image with loadable ASDF systems the code in this package will recursively package all the required source and fasls in a jar archive. \section{jss} +\label{section:jss} -To one used to a syntax that can construct macros, the Java syntax -sucks, so we introduce the \#" macro. +To one used to a syntax that can construct macros the Java syntax +may be said to suck, so we introduce the \code{SHARPSIGN-DOUBLE-QUOTE} \#" macro. \subsection{JSS usage} Example: \begin{listing-lisp} - CL-USER> (require 'jss) +CL-USER> (require 'jss) - CL-USER) (#"getProperties" 'java.lang.System) +CL-USER) (#"getProperties" 'java.lang.System) - CL-USER) (#"propertyNames" (#"getProperties" 'java.lang.System)) +CL-USER) (#"propertyNames" (#"getProperties" 'java.lang.System)) \end{listing-lisp} \section{asdf-install} -An implementation of ASDF-INSTALL. Superseded by Quicklisp (qv.) +The asdf-install contrib provides an implementation of ASDF-INSTALL. +Superseded by Quicklisp (see Xach2011 \cite{Xach2011}). + +The \code{require} of the \code{asdf-install} symbol has the side +effect of pushing the directory ``~/.asdf-install-dir/systems/'' into +the value of the \textsc{ASDF} central registry in +\code{asdf:*central-registry*}, providing a convenient mechanism for +stashing \textsc{ABCL} specific system definitions for convenient +access. \chapter{History} -ABCL was originally the extension language for the J editor, which was +\textsc{ABCL} was originally the extension language for the J editor, which was started in 1998 by Peter Graves. Sometime in 2003, a whole lot of code that had previously not been released publically was suddenly committed that enabled ABCL to be plausibly termed an emergent ANSI @@ -1049,29 +1094,41 @@ From 2006 to 2008, Peter manned the development lists, incorporating patches as made sense. After a suitable search, Peter nominated Erik -Huelsmann to take over the project. +H\"{u}lsmann to take over the project. In 2008, the implementation was transferred to the current maintainers, who have strived to improve its usability as a contemporary Common Lisp implementation. On October 22, 2011, with the publication of this Manual explicitly -stating the conformance of Armed Bear Common Lisp to ANSI, we released +stating the conformance of Armed Bear Common Lisp to \textsc{ANSI}, we released abcl-1.0.0. +\begin{thebibliography}{9} -\section{References} - -[Java2000]: A New Era for Java Protocol Handlers. -\url{http://java.sun.com/developer/onlineTraining/protocolhandlers/} - -[Xach2011]: Quicklisp: A system for quickly constructing Common Lisp -libraries. \url{http://www.quicklisp.org/} +\label{_:1} +\bibitem{Java2000} + ``A New Era for Java Protocol Handlers.'' + \url{http://java.sun.com/developer/onlineTraining/protocolhandlers/} + +\label{_:XACH2011} +\bibitem{Xach2011} + Zach Beene + ``Quicklisp: A system for quickly constructing Common Lisp'' + \url{http://www.quicklisp.org/} + +\bibitem{Rhodes2007} +Christopher Rhodes +``User-extensible Sequences in Common Lisp'' +ILC '07 Proceedings of the 2007 International Lisp Conference +% An early draft. XXX where is the real one? +\url{http://jcsu.jesus.cam.ac.uk/~csr21/spec.pdf} -[RHODES2007]: Christopher Rhodes +\end{thebibliography} +\printindex \end{document} Modified: branches/1.0.x/abcl/doc/manual/extensions.tex ============================================================================== --- branches/1.0.x/abcl/doc/manual/extensions.tex Sat Jan 7 15:09:30 2012 (r13727) +++ branches/1.0.x/abcl/doc/manual/extensions.tex Mon Jan 9 00:38:52 2012 (r13728) @@ -1,250 +1,1118 @@ -\begin{verbatim} -%CADDR - Macro: (not documented) -%CADR - Macro: (not documented) -%CAR - Macro: (not documented) -%CDR - Macro: (not documented) -*AUTOLOAD-VERBOSE* - Variable: (not documented) -*BATCH-MODE* - Variable: (not documented) -*COMMAND-LINE-ARGUMENT-LIST* - Variable: (not documented) -*DEBUG-CONDITION* - Variable: (not documented) -*DEBUG-LEVEL* - Variable: (not documented) -*DISASSEMBLER* - Variable: (not documented) -*ED-FUNCTIONS* - Variable: (not documented) -*ENABLE-INLINE-EXPANSION* - Variable: (not documented) -*INSPECTOR-HOOK* - Variable: (not documented) -*LISP-HOME* - Variable: (not documented) -*LOAD-TRUENAME-FASL* - Variable: (not documented) -*PRINT-STRUCTURE* - Variable: (not documented) -*REQUIRE-STACK-FRAME* - Variable: (not documented) -*SAVED-BACKTRACE* - Variable: (not documented) -*SUPPRESS-COMPILER-WARNINGS* - Variable: (not documented) -*WARN-ON-REDEFINITION* - Variable: (not documented) -ADJOIN-EQL - Function: (not documented) -ARGLIST - Function: (not documented) -ASSQ - Function: (not documented) -ASSQL - Function: (not documented) -AUTOLOAD - Function: (not documented) -AUTOLOAD-MACRO - Function: (not documented) -AUTOLOADP - Function: (not documented) -AVER - Macro: (not documented) -CANCEL-FINALIZATION - Function: (not documented) -CHAR-TO-UTF8 - Function: (not documented) -CHARPOS - Function: (not documented) -CLASSP - Function: (not documented) -COLLECT - Macro: (not documented) -COMPILE-FILE-IF-NEEDED - Function: (not documented) -COMPILE-SYSTEM - Function: (not documented) -COMPILER-ERROR - Function: (not documented) - Class: (not documented) -COMPILER-UNSUPPORTED-FEATURE-ERROR - Class: (not documented) -DESCRIBE-COMPILER-POLICY - Function: (not documented) -DOUBLE-FLOAT-NEGATIVE-INFINITY - Variable: (not documented) -DOUBLE-FLOAT-POSITIVE-INFINITY - Variable: (not documented) -DUMP-JAVA-STACK - Function: (not documented) -EXIT - Function: (not documented) -FEATUREP - Function: (not documented) -FILE-DIRECTORY-P - Function: (not documented) -FINALIZE - Function: (not documented) -FIXNUMP - Function: (not documented) -GC - Function: (not documented) -GET-FLOATING-POINT-MODES - Function: (not documented) -GET-SOCKET-STREAM - Function: :ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. -GETENV - Function: Return the value of the environment VARIABLE if it exists, otherwise return NIL. -GROVEL-JAVA-DEFINITIONS - Function: (not documented) -INIT-GUI - Function: (not documented) -INTERNAL-COMPILER-ERROR - Function: (not documented) - Class: (not documented) -INTERRUPT-LISP - Function: (not documented) -JAR-PATHNAME - Class: (not documented) -MACROEXPAND-ALL - Function: (not documented) -MAILBOX - Class: (not documented) -MAKE-DIALOG-PROMPT-STREAM - Function: (not documented) -MAKE-SERVER-SOCKET - Function: (not documented) -MAKE-SLIME-INPUT-STREAM - Function: (not documented) -MAKE-SLIME-OUTPUT-STREAM - Function: (not documented) -MAKE-SOCKET - Function: (not documented) -MAKE-TEMP-FILE - Function: (not documented) -MAKE-WEAK-REFERENCE - Function: (not documented) -MEMQ - Function: (not documented) -MEMQL - Function: (not documented) -MOST-NEGATIVE-JAVA-LONG - Variable: (not documented) -MOST-POSITIVE-JAVA-LONG - Variable: (not documented) -MUTEX - Class: (not documented) -NEQ - Function: (not documented) -NIL-VECTOR - Class: (not documented) -PATHNAME-JAR-P - Function: (not documented) -PATHNAME-URL-P - Function: Predicate for whether PATHNAME references a URL. -PRECOMPILE - Function: (not documented) -PROBE-DIRECTORY - Function: (not documented) -PROCESS - Function: (not documented) -PROCESS-ALIVE-P - Function: (not documented) -PROCESS-ERROR - Function: (not documented) -PROCESS-EXIT-CODE - Function: (not documented) -PROCESS-INPUT - Function: (not documented) -PROCESS-KILL - Function: (not documented) -PROCESS-OUTPUT - Function: (not documented) -PROCESS-P - Function: (not documented) -PROCESS-WAIT - Function: (not documented) -QUIT - Function: (not documented) -RESOLVE - Function: (not documented) -RUN-PROGRAM - Function: (not documented) -RUN-SHELL-COMMAND - Function: (not documented) -SERVER-SOCKET-CLOSE - Function: (not documented) -SET-FLOATING-POINT-MODES - Function: (not documented) -SHOW-RESTARTS - Function: (not documented) -SIMPLE-SEARCH - Function: (not documented) -SIMPLE-STRING-FILL - Function: (not documented) -SIMPLE-STRING-SEARCH - Function: (not documented) -SINGLE-FLOAT-NEGATIVE-INFINITY - Variable: (not documented) -SINGLE-FLOAT-POSITIVE-INFINITY - Variable: (not documented) -SLIME-INPUT-STREAM - Class: (not documented) -SLIME-OUTPUT-STREAM - Class: (not documented) -SOCKET-ACCEPT - Function: (not documented) -SOCKET-CLOSE - Function: (not documented) -SOCKET-LOCAL-ADDRESS - Function: Returns the local address of the given socket as a dotted quad string. -SOCKET-LOCAL-PORT - Function: Returns the local port number of the given socket. -SOCKET-PEER-ADDRESS - Function: Returns the peer address of the given socket as a dotted quad string. -SOCKET-PEER-PORT - Function: Returns the peer port number of the given socket. -SOURCE - Function: (not documented) -SOURCE-FILE-POSITION - Function: (not documented) -SOURCE-PATHNAME - Function: (not documented) -SPECIAL-VARIABLE-P - Function: (not documented) -STRING-FIND - Function: (not documented) -STRING-INPUT-STREAM-CURRENT - Function: (not documented) -STRING-POSITION - Function: (not documented) -STYLE-WARN - Function: (not documented) -TRULY-THE - Special Operator: (not documented) -UPTIME - Function: (not documented) -URI-DECODE - Function: (not documented) -URI-ENCODE - Function: (not documented) -URL-PATHNAME - Class: (not documented) -URL-PATHNAME-AUTHORITY - Function: (not documented) -URL-PATHNAME-FRAGMENT - Function: (not documented) -URL-PATHNAME-QUERY - Function: (not documented) -URL-PATHNAME-SCHEME - Function: (not documented) -WEAK-REFERENCE - Class: (not documented) -WEAK-REFERENCE-VALUE - Function: (not documented) -\end{verbatim} +\subsection{Exported Symbols from the EXTENSIONS package} + +\paragraph{} +\label{EXTENSIONS:COMPILE-FILE-IF-NEEDED} +\index{COMPILE-FILE-IF-NEEDED} +--- Function: \textbf{compile-file-if-needed} [\textbf{extensions}] \textit{input-file \&rest allargs \&key force-compile \&allow-other-keys} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MOST-POSITIVE-JAVA-LONG} +\index{MOST-POSITIVE-JAVA-LONG} +--- Variable: \textbf{most-positive-java-long} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:DUMP-JAVA-STACK} +\index{DUMP-JAVA-STACK} +--- Function: \textbf{dump-java-stack} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MEMQL} +\index{MEMQL} +--- Function: \textbf{memql} [\textbf{extensions}] \textit{item list} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:DOUBLE-FLOAT-NEGATIVE-INFINITY} +\index{DOUBLE-FLOAT-NEGATIVE-INFINITY} +--- Variable: \textbf{double-float-negative-infinity} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:GROVEL-JAVA-DEFINITIONS} +\index{GROVEL-JAVA-DEFINITIONS} +--- Function: \textbf{grovel-java-definitions} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*AUTOLOAD-VERBOSE*} +\index{*AUTOLOAD-VERBOSE*} +--- Variable: \textbf{*autoload-verbose*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-SLIME-INPUT-STREAM} +\index{MAKE-SLIME-INPUT-STREAM} +--- Function: \textbf{make-slime-input-stream} [\textbf{extensions}] \textit{function output-stream} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URL-PATHNAME-FRAGMENT} +\index{URL-PATHNAME-FRAGMENT} +--- Function: \textbf{url-pathname-fragment} [\textbf{extensions}] \textit{p} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-KILL} +\index{PROCESS-KILL} +--- Function: \textbf{process-kill} [\textbf{extensions}] \textit{process} + +\begin{adjustwidth}{5em}{5em} +Kills the process. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:NIL-VECTOR} +\index{NIL-VECTOR} +--- Class: \textbf{nil-vector} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOURCE-PATHNAME} +\index{SOURCE-PATHNAME} +--- Function: \textbf{source-pathname} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URI-DECODE} +\index{URI-DECODE} +--- Function: \textbf{uri-decode} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SIMPLE-STRING-FILL} +\index{SIMPLE-STRING-FILL} +--- Function: \textbf{simple-string-fill} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MEMQ} +\index{MEMQ} +--- Function: \textbf{memq} [\textbf{extensions}] \textit{item list} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URL-PATHNAME-SCHEME} +\index{URL-PATHNAME-SCHEME} +--- Function: \textbf{url-pathname-scheme} [\textbf{extensions}] \textit{p} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:TRULY-THE} +\index{TRULY-THE} +--- Special Operator: \textbf{truly-the} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SLIME-INPUT-STREAM} +\index{SLIME-INPUT-STREAM} +--- Class: \textbf{slime-input-stream} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-SOCKET} +\index{MAKE-SOCKET} +--- Function: \textbf{make-socket} [\textbf{extensions}] \textit{host port} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*ENABLE-INLINE-EXPANSION*} +\index{*ENABLE-INLINE-EXPANSION*} +--- Variable: \textbf{*enable-inline-expansion*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-INPUT} +\index{PROCESS-INPUT} +--- Function: \textbf{process-input} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAILBOX} +\index{MAILBOX} +--- Class: \textbf{mailbox} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:STRING-POSITION} +\index{STRING-POSITION} +--- Function: \textbf{string-position} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PRECOMPILE} +\index{PRECOMPILE} +--- Function: \textbf{precompile} [\textbf{extensions}] \textit{name \&optional definition} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*SUPPRESS-COMPILER-WARNINGS*} +\index{*SUPPRESS-COMPILER-WARNINGS*} +--- Variable: \textbf{*suppress-compiler-warnings*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS} +\index{PROCESS} +--- Class: \textbf{process} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SIMPLE-SEARCH} +\index{SIMPLE-SEARCH} +--- Function: \textbf{simple-search} [\textbf{extensions}] \textit{sequence1 sequence2} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*LISP-HOME*} +\index{*LISP-HOME*} +--- Variable: \textbf{*lisp-home*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*COMMAND-LINE-ARGUMENT-LIST*} +\index{*COMMAND-LINE-ARGUMENT-LIST*} +--- Variable: \textbf{*command-line-argument-list*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:FILE-DIRECTORY-P} +\index{FILE-DIRECTORY-P} +--- Function: \textbf{file-directory-p} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-DIALOG-PROMPT-STREAM} +\index{MAKE-DIALOG-PROMPT-STREAM} +--- Function: \textbf{make-dialog-prompt-stream} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:CLASSP} +\index{CLASSP} +--- Function: \textbf{classp} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*DISASSEMBLER*} +\index{*DISASSEMBLER*} +--- Variable: \textbf{*disassembler*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SET-FLOATING-POINT-MODES} +\index{SET-FLOATING-POINT-MODES} +--- Function: \textbf{set-floating-point-modes} [\textbf{extensions}] \textit{\&key traps} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*DEBUG-CONDITION*} +\index{*DEBUG-CONDITION*} +--- Variable: \textbf{*debug-condition*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:EXIT} +\index{EXIT} +--- Function: \textbf{exit} [\textbf{extensions}] \textit{\&key status} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-ERROR} +\index{PROCESS-ERROR} +--- Function: \textbf{process-error} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOCKET-LOCAL-PORT} +\index{SOCKET-LOCAL-PORT} +--- Function: \textbf{socket-local-port} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +Returns the local port number of the given socket. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-ALIVE-P} +\index{PROCESS-ALIVE-P} +--- Function: \textbf{process-alive-p} [\textbf{extensions}] \textit{process} + +\begin{adjustwidth}{5em}{5em} +Return t if process is still alive, nil otherwise. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*INSPECTOR-HOOK*} +\index{*INSPECTOR-HOOK*} +--- Variable: \textbf{*inspector-hook*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*REQUIRE-STACK-FRAME*} +\index{*REQUIRE-STACK-FRAME*} +--- Variable: \textbf{*require-stack-frame*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROBE-DIRECTORY} +\index{PROBE-DIRECTORY} +--- Function: \textbf{probe-directory} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:CHAR-TO-UTF8} +\index{CHAR-TO-UTF8} +--- Function: \textbf{char-to-utf8} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:AUTOLOAD} +\index{AUTOLOAD} +--- Function: \textbf{autoload} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MUTEX} +\index{MUTEX} +--- Class: \textbf{mutex} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URI-ENCODE} +\index{URI-ENCODE} +--- Function: \textbf{uri-encode} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:AUTOLOAD-MACRO} +\index{AUTOLOAD-MACRO} +--- Function: \textbf{autoload-macro} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOCKET-CLOSE} +\index{SOCKET-CLOSE} +--- Function: \textbf{socket-close} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:UPTIME} +\index{UPTIME} +--- Function: \textbf{uptime} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*ED-FUNCTIONS*} +\index{*ED-FUNCTIONS*} +--- Variable: \textbf{*ed-functions*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:COMPILE-SYSTEM} +\index{COMPILE-SYSTEM} +--- Function: \textbf{compile-system} [\textbf{extensions}] \textit{\&key quit (zip t) output-path} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*LOAD-TRUENAME-FASL*} +\index{*LOAD-TRUENAME-FASL*} +--- Variable: \textbf{*load-truename-fasl*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SPECIAL-VARIABLE-P} +\index{SPECIAL-VARIABLE-P} +--- Function: \textbf{special-variable-p} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOCKET-ACCEPT} +\index{SOCKET-ACCEPT} +--- Function: \textbf{socket-accept} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*WARN-ON-REDEFINITION*} +\index{*WARN-ON-REDEFINITION*} +--- Variable: \textbf{*warn-on-redefinition*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URL-PATHNAME-AUTHORITY} +\index{URL-PATHNAME-AUTHORITY} +--- Function: \textbf{url-pathname-authority} [\textbf{extensions}] \textit{p} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:AUTOLOADP} +\index{AUTOLOADP} +--- Function: \textbf{autoloadp} [\textbf{extensions}] \textit{symbol} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-WEAK-REFERENCE} +\index{MAKE-WEAK-REFERENCE} +--- Function: \textbf{make-weak-reference} [\textbf{extensions}] \textit{obj} + +\begin{adjustwidth}{5em}{5em} +Creates a weak reference to 'obj'. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:RESOLVE} +\index{RESOLVE} +--- Function: \textbf{resolve} [\textbf{extensions}] \textit{symbol} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:CANCEL-FINALIZATION} +\index{CANCEL-FINALIZATION} +--- Function: \textbf{cancel-finalization} [\textbf{extensions}] \textit{object} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-SLIME-OUTPUT-STREAM} +\index{MAKE-SLIME-OUTPUT-STREAM} +--- Function: \textbf{make-slime-output-stream} [\textbf{extensions}] \textit{function} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:RUN-PROGRAM} +\index{RUN-PROGRAM} +--- Function: \textbf{run-program} [\textbf{extensions}] \textit{program args \&key environment (wait t)} + +\begin{adjustwidth}{5em}{5em} +Creates a new process running the the PROGRAM. +ARGS are a list of strings to be passed to the program as arguments. + +For no arguments, use nil which means that just the name of the +program is passed as arg 0. + +Returns a process structure containing the JAVA-OBJECT wrapped Process +object, and the PROCESS-INPUT, PROCESS-OUTPUT, and PROCESS-ERROR streams. + +c.f. http://download.oracle.com/javase/6/docs/api/java/lang/Process.html + +Notes about Unix environments (as in the :environment): + + * The ABCL implementation of run-program, like SBCL, Perl and many + other programs, copies the Unix environment by default. + + * Running Unix programs from a setuid process, or in any other + situation where the Unix environment is under the control of + someone else, is a mother lode of security problems. If you are + contemplating doing this, read about it first. (The Perl + community has a lot of good documentation about this and other + security issues in script-like programs.) + +The \&key arguments have the following meanings: + +:environment + An alist of STRINGs (name . value) describing the new + environment. The default is to copy the environment of the current + process. + +:wait + If non-NIL, which is the default, wait until the created process + finishes. If NIL, continue running Lisp until the program + finishes. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:FIXNUMP} +\index{FIXNUMP} +--- Function: \textbf{fixnump} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SINGLE-FLOAT-NEGATIVE-INFINITY} +\index{SINGLE-FLOAT-NEGATIVE-INFINITY} +--- Variable: \textbf{single-float-negative-infinity} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:QUIT} +\index{QUIT} +--- Function: \textbf{quit} [\textbf{extensions}] \textit{\&key status} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:INTERNAL-COMPILER-ERROR} +\index{INTERNAL-COMPILER-ERROR} +--- Function: \textbf{internal-compiler-error} [\textbf{extensions}] \textit{format-control \&rest format-arguments} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:JAR-PATHNAME} +\index{JAR-PATHNAME} +--- Class: \textbf{jar-pathname} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +NIL + +\paragraph{} +\label{EXTENSIONS:SIMPLE-STRING-SEARCH} +\index{SIMPLE-STRING-SEARCH} +--- Function: \textbf{simple-string-search} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:ASSQL} +\index{ASSQL} +--- Function: \textbf{assql} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:FINALIZE} +\index{FINALIZE} +--- Function: \textbf{finalize} [\textbf{extensions}] \textit{object function} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:RUN-SHELL-COMMAND} +\index{RUN-SHELL-COMMAND} +--- Function: \textbf{run-shell-command} [\textbf{extensions}] \textit{command \&key directory (output *standard-output*)} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*SAVED-BACKTRACE*} +\index{*SAVED-BACKTRACE*} +--- Variable: \textbf{*saved-backtrace*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:COLLECT} +\index{COLLECT} +--- Macro: \textbf{collect} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:ARGLIST} +\index{ARGLIST} +--- Function: \textbf{arglist} [\textbf{extensions}] \textit{extended-function-designator} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:ADJOIN-EQL} +\index{ADJOIN-EQL} +--- Function: \textbf{adjoin-eql} [\textbf{extensions}] \textit{item list} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:CHARPOS} +\index{CHARPOS} +--- Function: \textbf{charpos} [\textbf{extensions}] \textit{stream} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-TEMP-FILE} +\index{MAKE-TEMP-FILE} +--- Function: \textbf{make-temp-file} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:DESCRIBE-COMPILER-POLICY} +\index{DESCRIBE-COMPILER-POLICY} +--- Function: \textbf{describe-compiler-policy} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*PRINT-STRUCTURE*} +\index{*PRINT-STRUCTURE*} +--- Variable: \textbf{*print-structure*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOCKET-PEER-ADDRESS} +\index{SOCKET-PEER-ADDRESS} +--- Function: \textbf{socket-peer-address} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +Returns the peer address of the given socket as a dotted quad string. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:GC} +\index{GC} +--- Function: \textbf{gc} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:GETENV} +\index{GETENV} +--- Function: \textbf{getenv} [\textbf{extensions}] \textit{variable} + +\begin{adjustwidth}{5em}{5em} +Return the value of the environment VARIABLE if it exists, otherwise return NIL. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SERVER-SOCKET-CLOSE} +\index{SERVER-SOCKET-CLOSE} +--- Function: \textbf{server-socket-close} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:WEAK-REFERENCE} +\index{WEAK-REFERENCE} +--- Class: \textbf{weak-reference} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:GET-FLOATING-POINT-MODES} +\index{GET-FLOATING-POINT-MODES} +--- Function: \textbf{get-floating-point-modes} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:WEAK-REFERENCE-VALUE} +\index{WEAK-REFERENCE-VALUE} +--- Function: \textbf{weak-reference-value} [\textbf{extensions}] \textit{obj} + +\begin{adjustwidth}{5em}{5em} +Returns two values, the first being the value of the weak ref,the second T if the reference is valid, or NIL if it hasbeen cleared. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SINGLE-FLOAT-POSITIVE-INFINITY} +\index{SINGLE-FLOAT-POSITIVE-INFINITY} +--- Variable: \textbf{single-float-positive-infinity} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:FEATUREP} +\index{FEATUREP} +--- Function: \textbf{featurep} [\textbf{extensions}] \textit{form} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PATHNAME-URL-P} +\index{PATHNAME-URL-P} +--- Function: \textbf{pathname-url-p} [\textbf{extensions}] \textit{pathname} + +\begin{adjustwidth}{5em}{5em} +Predicate for whether PATHNAME references a URL. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:STRING-INPUT-STREAM-CURRENT} +\index{STRING-INPUT-STREAM-CURRENT} +--- Function: \textbf{string-input-stream-current} [\textbf{extensions}] \textit{stream} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MAKE-SERVER-SOCKET} +\index{MAKE-SERVER-SOCKET} +--- Function: \textbf{make-server-socket} [\textbf{extensions}] \textit{port} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:INTERRUPT-LISP} +\index{INTERRUPT-LISP} +--- Function: \textbf{interrupt-lisp} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:AVER} +\index{AVER} +--- Macro: \textbf{aver} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:INIT-GUI} +\index{INIT-GUI} +--- Function: \textbf{init-gui} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +Dummy function used to autoload this file +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URL-PATHNAME-QUERY} +\index{URL-PATHNAME-QUERY} +--- Function: \textbf{url-pathname-query} [\textbf{extensions}] \textit{p} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-EXIT-CODE} +\index{PROCESS-EXIT-CODE} +--- Function: \textbf{process-exit-code} [\textbf{extensions}] \textit{instance} + +\begin{adjustwidth}{5em}{5em} +The exit code of a process. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOURCE-FILE-POSITION} +\index{SOURCE-FILE-POSITION} +--- Function: \textbf{source-file-position} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOCKET-PEER-PORT} +\index{SOCKET-PEER-PORT} +--- Function: \textbf{socket-peer-port} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +Returns the peer port number of the given socket. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:ASSQ} +\index{ASSQ} +--- Function: \textbf{assq} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOURCE} +\index{SOURCE} +--- Function: \textbf{source} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SOCKET-LOCAL-ADDRESS} +\index{SOCKET-LOCAL-ADDRESS} +--- Function: \textbf{socket-local-address} [\textbf{extensions}] \textit{socket} + +\begin{adjustwidth}{5em}{5em} +Returns the local address of the given socket as a dotted quad string. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:NEQ} +\index{NEQ} +--- Function: \textbf{neq} [\textbf{extensions}] \textit{obj1 obj2} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:STRING-FIND} +\index{STRING-FIND} +--- Function: \textbf{string-find} [\textbf{extensions}] \textit{char string} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PATHNAME-JAR-P} +\index{PATHNAME-JAR-P} +--- Function: \textbf{pathname-jar-p} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-WAIT} +\index{PROCESS-WAIT} +--- Function: \textbf{process-wait} [\textbf{extensions}] \textit{process} + +\begin{adjustwidth}{5em}{5em} +Wait for process to quit running for some reason. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SHOW-RESTARTS} +\index{SHOW-RESTARTS} +--- Function: \textbf{show-restarts} [\textbf{extensions}] \textit{restarts stream} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*BATCH-MODE*} +\index{*BATCH-MODE*} +--- Variable: \textbf{*batch-mode*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-P} +\index{PROCESS-P} +--- Function: \textbf{process-p} [\textbf{extensions}] \textit{object} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*GUI-BACKEND*} +\index{*GUI-BACKEND*} +--- Variable: \textbf{*gui-backend*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:DOUBLE-FLOAT-POSITIVE-INFINITY} +\index{DOUBLE-FLOAT-POSITIVE-INFINITY} +--- Variable: \textbf{double-float-positive-infinity} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:STYLE-WARN} +\index{STYLE-WARN} +--- Function: \textbf{style-warn} [\textbf{extensions}] \textit{format-control \&rest format-arguments} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MOST-NEGATIVE-JAVA-LONG} +\index{MOST-NEGATIVE-JAVA-LONG} +--- Variable: \textbf{most-negative-java-long} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:SLIME-OUTPUT-STREAM} +\index{SLIME-OUTPUT-STREAM} +--- Class: \textbf{slime-output-stream} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:GET-SOCKET-STREAM} +\index{GET-SOCKET-STREAM} +--- Function: \textbf{get-socket-stream} [\textbf{extensions}] \textit{socket \&key (element-type (quote character)) (external-format default)} + +\begin{adjustwidth}{5em}{5em} +:ELEMENT-TYPE must be CHARACTER or (UNSIGNED-BYTE 8); the default is CHARACTER. +EXTERNAL-FORMAT must be of the same format as specified for OPEN. +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:PROCESS-OUTPUT} +\index{PROCESS-OUTPUT} +--- Function: \textbf{process-output} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:URL-PATHNAME} +\index{URL-PATHNAME} +--- Class: \textbf{url-pathname} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:COMPILER-UNSUPPORTED-FEATURE-ERROR} +\index{COMPILER-UNSUPPORTED-FEATURE-ERROR} +--- Class: \textbf{compiler-unsupported-feature-error} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:*DEBUG-LEVEL*} +\index{*DEBUG-LEVEL*} +--- Variable: \textbf{*debug-level*} [\textbf{extensions}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:COMPILER-ERROR} +\index{COMPILER-ERROR} +--- Function: \textbf{compiler-error} [\textbf{extensions}] \textit{format-control \&rest format-arguments} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{EXTENSIONS:MACROEXPAND-ALL} +\index{MACROEXPAND-ALL} +--- Function: \textbf{macroexpand-all} [\textbf{extensions}] \textit{form \&optional env} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + Copied: branches/1.0.x/abcl/doc/manual/grovel.lisp (from r13727, trunk/abcl/doc/manual/grovel.lisp) ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ branches/1.0.x/abcl/doc/manual/grovel.lisp Mon Jan 9 00:38:52 2012 (r13728, copy of r13727, trunk/abcl/doc/manual/grovel.lisp) @@ -0,0 +1,92 @@ +#-abcl We're only grovelling ABCL docstrings here. +(defun grovel-docstrings-as-tex (&optional (package (find-package :java))) + (let ((output-file (format nil "~A.tex" (string-downcase (package-name package))))) + (with-open-file (stream output-file :direction :output) + (format t "Writing output to ~A.~%" output-file) + (loop :for symbol :being :each :external-symbol :of package + :doing (format stream "~&~A~%~%" (symbol-as-tex symbol)))))) + +(asdf:load-system 'swank) ;; XXX Does this load the SWANK-BACKEND package as well + +(defun arglist-as-tex (symbol) + (handler-case + (loop :for arg :in (arglist symbol) + :collecting + (format nil + ;;; XXX should really check the entire input for TeX escapes + (if (and (symbolp arg) + (or (string= (subseq (symbol-name arg) 0 1) #\&) + (string= (subseq (symbol-name arg) 0 1) #\%))) + "\\~A" + "~A") + (if (symbolp arg) + (string-downcase (symbol-name arg)) + (format nil "~(~A~)" arg)))) + (t (e) + (progn (warn "Failed to form arglist for ~A: ~A" symbol e) + (list ""))))) + + +(defvar *type-alist* + '((:function + . "Function") + (:macro + . "Macro") + (:variable + . "Variable") + (:class + . "Class") + (:special-operator + . "Special Operator") + (:generic-function + . "Generic Function"))) + +(defun symbol-as-tex (symbol) + "Return the TeX representation of a SYMBOL as Tex." + (let (type documentation arglist doc symbol-name package-name) + (when (setf doc (swank-backend:describe-symbol-for-emacs symbol)) + (cond + ((find :function doc) + (setf type :function + documentation (second doc) + arglist (format nil "~{~A~^ ~}" (arglist-as-tex symbol)))) + ((find :variable doc) + (setf type :variable + documentation (second doc))) + ((find :macro doc) + (setf type :macro + documentation (second doc))) + ((find :generic-function doc) + (setf type :generic-function + documentation (second doc))) + ((find :class doc) + (setf type :class + documentation (second doc))) + ((find :special-operator doc) + (setf type :special-operator + documentation (second doc))) + (t + (warn "Unknown type of documentation for symbol ~A: ~A" + symbol doc))) + (setf symbol-name (string-downcase + symbol) + package-name (string-downcase + (package-name (find-package (symbol-package symbol))))) + (format nil "~&\\paragraph{}~&\\label{~A:~A}~&\\index{~A}~&--- ~A: \\textbf{~A} [\\textbf{~A}] \\textit{~A}~%~%\\begin{adjustwidth}{5em}{5em}~&~A~&\\end{adjustwidth}" + (package-name (find-package (symbol-package symbol))) + (symbol-name symbol) + (symbol-name symbol) + (cdr (assoc type *type-alist*)) + symbol-name + package-name + (if arglist arglist "") + (if documentation documentation ""))))) + + + + + + + + + \ No newline at end of file Modified: branches/1.0.x/abcl/doc/manual/java.tex ============================================================================== --- branches/1.0.x/abcl/doc/manual/java.tex Sat Jan 7 15:09:30 2012 (r13727) +++ branches/1.0.x/abcl/doc/manual/java.tex Mon Jan 9 00:38:52 2012 (r13728) @@ -1,182 +1,768 @@ -\begin{verbatim} -%JGET-PROPERTY-VALUE - Function: Gets a JavaBeans property on JAVA-OBJECT. -%JSET-PROPERTY-VALUE - Function: Sets a JavaBean property on JAVA-OBJECT. -*JAVA-OBJECT-TO-STRING-LENGTH* - Variable: Length to truncate toString() PRINT-OBJECT output for an - otherwise unspecialized JAVA-OBJECT. Can be set to NIL to indicate - no limit. -+FALSE+ - Variable: The JVM primitive value for boolean false. -+NULL+ - Variable: The JVM null object reference. -+TRUE+ - Variable: The JVM primitive value for boolean true. -ADD-TO-CLASSPATH - Generic Function: (not documented) -CHAIN - Macro: (not documented) -DESCRIBE-JAVA-OBJECT - Function: (not documented) -DUMP-CLASSPATH - Function: (not documented) -ENSURE-JAVA-CLASS - Function: (not documented) -ENSURE-JAVA-OBJECT - Function: Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary. -GET-CURRENT-CLASSLOADER - Function: (not documented) -GET-DEFAULT-CLASSLOADER - Function: (not documented) -JARRAY-COMPONENT-TYPE - Function: Returns the component type of the array type ATYPE -JARRAY-LENGTH - Function: (not documented) -JARRAY-REF - Function: Dereferences the Java array JAVA-ARRAY using the given - INDICIES, coercing the result into a Lisp object, if possible. -JARRAY-REF-RAW - Function: Dereference the Java array JAVA-ARRAY using the given - INDICIES. Does not attempt to coerce the result into a Lisp object. -JARRAY-SET - Function: Stores NEW-VALUE at the given index in JAVA-ARRAY. -JAVA-CLASS - Class: (not documented) -JAVA-EXCEPTION - Class: (not documented) -JAVA-EXCEPTION-CAUSE - Function: (not documented) -JAVA-OBJECT - Class: (not documented) -JAVA-OBJECT-P - Function: Returns T if OBJECT is a JAVA-OBJECT. -JCALL - Function: Invokes the Java method METHOD-REF on INSTANCE with - arguments ARGS, coercing the result into a Lisp object, if possible. -JCALL-RAW - Function: Invokes the Java method METHOD-REF on INSTANCE with - arguments ARGS. Does not attempt to coerce the result into a Lisp - object. -JCLASS - Function: 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. -JCLASS-ARRAY-P - Function: Returns T if CLASS is an array class -JCLASS-CONSTRUCTORS - Function: Returns a vector of constructors for CLASS -JCLASS-FIELD - Function: Returns the field named FIELD-NAME of CLASS -JCLASS-FIELDS - Function: Returns a vector of all (or just the declared/public, if - DECLARED/PUBLIC is true) fields of CLASS -JCLASS-INTERFACE-P - Function: Returns T if CLASS is an interface -JCLASS-INTERFACES - Function: Returns the vector of interfaces of CLASS -JCLASS-METHODS - Function: Return a vector of all (or just the declared/public, if - DECLARED/PUBLIC is true) methods of CLASS -JCLASS-NAME - Function: (not documented) -JCLASS-OF - Function: (not documented) -JCLASS-SUPERCLASS - Function: Returns the superclass of CLASS, or NIL if it hasn't got one -JCLASS-SUPERCLASS-P - Function: Returns T if CLASS-1 is a superclass or interface of CLASS-2 -JCOERCE - Function: Attempts to coerce OBJECT into a JavaObject of class - INTENDED-CLASS. Raises a TYPE-ERROR if no conversion is possible. -JCONSTRUCTOR - Function: Returns a reference to the Java constructor of CLASS-REF - with the given PARAMETER-CLASS-REFS. -JCONSTRUCTOR-PARAMS - Function: Returns a vector of parameter types (Java classes) for CONSTRUCTOR -JEQUAL - Function: Compares obj1 with obj2 using java.lang.Object.equals() -JFIELD - Function: Retrieves or modifies a field in a Java class or instance. -JFIELD-NAME - Function: Returns the name of FIELD as a Lisp string -JFIELD-RAW - Function: Retrieves or modifies a field in a Java class or instance. Does not -JFIELD-TYPE - Function: Returns the type (Java class) of FIELD -JINSTANCE-OF-P - Function: OBJ is an instance of CLASS (or one of its subclasses) -JINTERFACE-IMPLEMENTATION - Function: Creates and returns an implementation of a Java interface with -JMAKE-INVOCATION-HANDLER - Function: (not documented) -JMAKE-PROXY - Generic Function: (not documented) -JMEMBER-PROTECTED-P - Function: MEMBER is a protected member of its declaring class -JMEMBER-PUBLIC-P - Function: MEMBER is a public member of its declaring class -JMEMBER-STATIC-P - Function: MEMBER is a static member of its declaring class -JMETHOD - Function: Returns a reference to the Java method METHOD-NAME of - CLASS-REF with the given PARAMETER-CLASS-REFS. -JMETHOD-LET - Macro: (not documented) -JMETHOD-NAME - Function: Returns the name of METHOD as a Lisp string -JMETHOD-PARAMS - Function: Returns a vector of parameter types (Java classes) for METHOD -JMETHOD-RETURN-TYPE - Function: Returns the result type (Java class) of the METHOD -JNEW - Function: Invokes the Java constructor CONSTRUCTOR with the arguments ARGS. -JNEW-ARRAY - Function: Creates a new Java array of type ELEMENT-TYPE, with the given DIMENSIONS. -JNEW-ARRAY-FROM-ARRAY - Function: Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) -JNEW-ARRAY-FROM-LIST - Function: (not documented) -JNEW-RUNTIME-CLASS - Function: (not documented) -JNULL-REF-P - Function: Returns a non-NIL value when the JAVA-OBJECT `object` is `null`, -JOBJECT-CLASS - Function: Returns the Java class that OBJ belongs to -JOBJECT-LISP-VALUE - Function: Attempts to coerce JAVA-OBJECT into a Lisp object. -JPROPERTY-VALUE - Function: (not documented) -JREDEFINE-METHOD - Function: (not documented) -JREGISTER-HANDLER - Function: (not documented) -JRESOLVE-METHOD - Function: Finds the most specific Java method METHOD-NAME on - INSTANCE applicable to arguments ARGS. Returns NIL if no suitable - method is found. The algorithm used for resolution is the same used - by JCALL when it is called with a string as the first parameter - (METHOD-REF). -JRUN-EXCEPTION-PROTECTED - Function: Invokes the function CLOSURE and returns the result. - Signals an error if stack or heap exhaustion occurs. -JRUNTIME-CLASS-EXISTS-P - Function: (not documented) -JSTATIC - Function: Invokes the static method METHOD on class CLASS with ARGS. -JSTATIC-RAW - Function: Invokes the static method METHOD on class CLASS with - ARGS. Does not attempt to coerce the arguments or result into a Lisp - object. -MAKE-CLASSLOADER - Function: (not documented) -MAKE-IMMEDIATE-OBJECT - Function: Attempts to coerce a given Lisp object into a java-object of the -REGISTER-JAVA-EXCEPTION - Function: Registers the Java Throwable named by the symbol - EXCEPTION-NAME as the condition designated by CONDITION-SYMBOL. - Returns T if successful, NIL if not. -UNREGISTER-JAVA-EXCEPTION - Function: Unregisters the Java Throwable EXCEPTION-NAME previously - registered by REGISTER-JAVA-EXCEPTION. -\end{verbatim} +\subsection{Exported Symbols from the JAVA package} +\paragraph{} +\label{JAVA:JAVA-EXCEPTION-CAUSE} +\index{JAVA-EXCEPTION-CAUSE} +--- Function: \textbf{java-exception-cause} [\textbf{java}] \textit{java-exception} + +\begin{adjustwidth}{5em}{5em} +Returns the cause of JAVA-EXCEPTION. (The cause is the Java Throwable + object that caused JAVA-EXCEPTION to be signalled.) +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-SUPERCLASS-P} +\index{JCLASS-SUPERCLASS-P} +--- Function: \textbf{jclass-superclass-p} [\textbf{java}] \textit{class-1 class-2} + +\begin{adjustwidth}{5em}{5em} +Returns T if CLASS-1 is a superclass or interface of CLASS-2 +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JINTERFACE-IMPLEMENTATION} +\index{JINTERFACE-IMPLEMENTATION} +--- Function: \textbf{jinterface-implementation} [\textbf{java}] \textit{interface \&rest method-names-and-defs} + +\begin{adjustwidth}{5em}{5em} +Creates and returns an implementation of a Java interface with + methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS. + + INTERFACE is either a Java interface or a string naming one. + + METHOD-NAMES-AND-DEFS is an alternating list of method names + (strings) and method definitions (closures). + + For missing methods, a dummy implementation is provided that + returns nothing or null depending on whether the return type is + void or not. This is for convenience only, and a warning is issued + for each undefined method. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:DUMP-CLASSPATH} +\index{DUMP-CLASSPATH} +--- Function: \textbf{dump-classpath} [\textbf{java}] \textit{\&optional classloader} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:ENSURE-JAVA-OBJECT} +\index{ENSURE-JAVA-OBJECT} +--- Function: \textbf{ensure-java-object} [\textbf{java}] \textit{obj} + +\begin{adjustwidth}{5em}{5em} +Ensures OBJ is wrapped in a JAVA-OBJECT, wrapping it if necessary. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMETHOD-RETURN-TYPE} +\index{JMETHOD-RETURN-TYPE} +--- Function: \textbf{jmethod-return-type} [\textbf{java}] \textit{method} + +\begin{adjustwidth}{5em}{5em} +Returns the result type (Java class) of the METHOD +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JFIELD-NAME} +\index{JFIELD-NAME} +--- Function: \textbf{jfield-name} [\textbf{java}] \textit{field} + +\begin{adjustwidth}{5em}{5em} +Returns the name of FIELD as a Lisp string +\end{adjustwidth} + +\paragraph{} +\label{JAVA:*JAVA-OBJECT-TO-STRING-LENGTH*} +\index{*JAVA-OBJECT-TO-STRING-LENGTH*} +--- Variable: \textbf{*java-object-to-string-length*} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +Length to truncate toString() PRINT-OBJECT output for an otherwise unspecialized JAVA-OBJECT. Can be set to NIL to indicate no limit. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JRUN-EXCEPTION-PROTECTED} +\index{JRUN-EXCEPTION-PROTECTED} +--- Function: \textbf{jrun-exception-protected} [\textbf{java}] \textit{closure} + +\begin{adjustwidth}{5em}{5em} +Invokes the function CLOSURE and returns the result. Signals an error if stack or heap exhaustion occurs. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JINSTANCE-OF-P} +\index{JINSTANCE-OF-P} +--- Function: \textbf{jinstance-of-p} [\textbf{java}] \textit{obj class} + +\begin{adjustwidth}{5em}{5em} +OBJ is an instance of CLASS (or one of its subclasses) +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMETHOD-NAME} +\index{JMETHOD-NAME} +--- Function: \textbf{jmethod-name} [\textbf{java}] \textit{method} + +\begin{adjustwidth}{5em}{5em} +Returns the name of METHOD as a Lisp string +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JSTATIC-RAW} +\index{JSTATIC-RAW} +--- Function: \textbf{jstatic-raw} [\textbf{java}] \textit{method class \&rest args} + +\begin{adjustwidth}{5em}{5em} +Invokes the static method METHOD on class CLASS with ARGS. Does not attempt to coerce the arguments or result into a Lisp object. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-OF} +\index{JCLASS-OF} +--- Function: \textbf{jclass-of} [\textbf{java}] \textit{object \&optional name} + +\begin{adjustwidth}{5em}{5em} +Returns the name of the Java class of OBJECT. If the NAME argument is + supplied, verifies that OBJECT is an instance of the named class. The name + of the class or nil is always returned as a second value. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:GET-CURRENT-CLASSLOADER} +\index{GET-CURRENT-CLASSLOADER} +--- Function: \textbf{get-current-classloader} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + + +\paragraph{} +\label{JAVA:JNEW-ARRAY-FROM-LIST} +\index{JNEW-ARRAY-FROM-LIST} +--- Function: \textbf{jnew-array-from-list} [\textbf{java}] \textit{element-type list} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMETHOD} +\index{JMETHOD} +--- Function: \textbf{jmethod} [\textbf{java}] \textit{class-ref method-name \&rest parameter-class-refs} + +\begin{adjustwidth}{5em}{5em} +Returns a reference to the Java method METHOD-NAME of CLASS-REF with the given PARAMETER-CLASS-REFS. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:GET-DEFAULT-CLASSLOADER} +\index{GET-DEFAULT-CLASSLOADER} +--- Function: \textbf{get-default-classloader} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-METHODS} +\index{JCLASS-METHODS} +--- Function: \textbf{jclass-methods} [\textbf{java}] \textit{class \&key declared public} + +\begin{adjustwidth}{5em}{5em} +Return a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) methods of CLASS +\end{adjustwidth} + +\paragraph{} +\label{JAVA:REGISTER-JAVA-EXCEPTION} +\index{REGISTER-JAVA-EXCEPTION} +--- Function: \textbf{register-java-exception} [\textbf{java}] \textit{exception-name condition-symbol} + +\begin{adjustwidth}{5em}{5em} +Registers the Java Throwable named by the symbol EXCEPTION-NAME as the condition designated by CONDITION-SYMBOL. Returns T if successful, NIL if not. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS} +\index{JCLASS} +--- Function: \textbf{jclass} [\textbf{java}] \textit{name-or-class-ref \&optional class-loader} + +\begin{adjustwidth}{5em}{5em} +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. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JPROPERTY-VALUE} +\index{JPROPERTY-VALUE} +--- Function: \textbf{jproperty-value} [\textbf{java}] \textit{obj prop} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JFIELD-TYPE} +\index{JFIELD-TYPE} +--- Function: \textbf{jfield-type} [\textbf{java}] \textit{field} + +\begin{adjustwidth}{5em}{5em} +Returns the type (Java class) of FIELD +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JNEW-RUNTIME-CLASS} +\index{JNEW-RUNTIME-CLASS} +--- Function: \textbf{jnew-runtime-class} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-CONSTRUCTORS} +\index{JCLASS-CONSTRUCTORS} +--- Function: \textbf{jclass-constructors} [\textbf{java}] \textit{class} + +\begin{adjustwidth}{5em}{5em} +Returns a vector of constructors for CLASS +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JSTATIC} +\index{JSTATIC} +--- Function: \textbf{jstatic} [\textbf{java}] \textit{method class \&rest args} + +\begin{adjustwidth}{5em}{5em} +Invokes the static method METHOD on class CLASS with ARGS. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMETHOD-PARAMS} +\index{JMETHOD-PARAMS} +--- Function: \textbf{jmethod-params} [\textbf{java}] \textit{method} + +\begin{adjustwidth}{5em}{5em} +Returns a vector of parameter types (Java classes) for METHOD +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JREGISTER-HANDLER} +\index{JREGISTER-HANDLER} +--- Function: \textbf{jregister-handler} [\textbf{java}] \textit{object event handler \&key data count} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-SUPERCLASS} +\index{JCLASS-SUPERCLASS} +--- Function: \textbf{jclass-superclass} [\textbf{java}] \textit{class} + +\begin{adjustwidth}{5em}{5em} +Returns the superclass of CLASS, or NIL if it hasn't got one +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JAVA-OBJECT-P} +\index{JAVA-OBJECT-P} +--- Function: \textbf{java-object-p} [\textbf{java}] \textit{object} + +\begin{adjustwidth}{5em}{5em} +Returns T if OBJECT is a JAVA-OBJECT. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:UNREGISTER-JAVA-EXCEPTION} +\index{UNREGISTER-JAVA-EXCEPTION} +--- Function: \textbf{unregister-java-exception} [\textbf{java}] \textit{exception-name} + +\begin{adjustwidth}{5em}{5em} +Unregisters the Java Throwable EXCEPTION-NAME previously registered by REGISTER-JAVA-EXCEPTION. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JNEW} +\index{JNEW} +--- Function: \textbf{jnew} [\textbf{java}] \textit{constructor \&rest args} + +\begin{adjustwidth}{5em}{5em} +Invokes the Java constructor CONSTRUCTOR with the arguments ARGS. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JRUNTIME-CLASS-EXISTS-P} +\index{JRUNTIME-CLASS-EXISTS-P} +--- Function: \textbf{jruntime-class-exists-p} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JARRAY-COMPONENT-TYPE} +\index{JARRAY-COMPONENT-TYPE} +--- Function: \textbf{jarray-component-type} [\textbf{java}] \textit{atype} + +\begin{adjustwidth}{5em}{5em} +Returns the component type of the array type ATYPE +\end{adjustwidth} + +\paragraph{} +\label{JAVA:ADD-TO-CLASSPATH} +\index{ADD-TO-CLASSPATH} +--- Generic Function: \textbf{add-to-classpath} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JOBJECT-LISP-VALUE} +\index{JOBJECT-LISP-VALUE} +--- Function: \textbf{jobject-lisp-value} [\textbf{java}] \textit{java-object} + +\begin{adjustwidth}{5em}{5em} +Attempts to coerce JAVA-OBJECT into a Lisp object. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-NAME} +\index{JCLASS-NAME} +--- Function: \textbf{jclass-name} [\textbf{java}] \textit{class-ref \&optional name} + +\begin{adjustwidth}{5em}{5em} +When called with one argument, returns the name of the Java class + designated by CLASS-REF. When called with two arguments, tests + whether CLASS-REF matches NAME. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMEMBER-PUBLIC-P} +\index{JMEMBER-PUBLIC-P} +--- Function: \textbf{jmember-public-p} [\textbf{java}] \textit{member} + +\begin{adjustwidth}{5em}{5em} +MEMBER is a public member of its declaring class +\end{adjustwidth} + +\paragraph{} +\label{JAVA:+NULL+} +\index{+NULL+} +--- Variable: \textbf{+null+} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +The JVM null object reference. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:ENSURE-JAVA-CLASS} +\index{ENSURE-JAVA-CLASS} +--- Function: \textbf{ensure-java-class} [\textbf{java}] \textit{jclass} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JAVA-CLASS} +\index{JAVA-CLASS} +--- Class: \textbf{java-class} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMETHOD-LET} +\index{JMETHOD-LET} +--- Macro: \textbf{jmethod-let} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-ARRAY-P} +\index{JCLASS-ARRAY-P} +--- Function: \textbf{jclass-array-p} [\textbf{java}] \textit{class} + +\begin{adjustwidth}{5em}{5em} +Returns T if CLASS is an array class +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCALL} +\index{JCALL} +--- Function: \textbf{jcall} [\textbf{java}] \textit{method-ref instance \&rest args} + +\begin{adjustwidth}{5em}{5em} +Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS, coercing the result into a Lisp object, if possible. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JARRAY-REF-RAW} +\index{JARRAY-REF-RAW} +--- Function: \textbf{jarray-ref-raw} [\textbf{java}] \textit{java-array \&rest indices} + +\begin{adjustwidth}{5em}{5em} +Dereference the Java array JAVA-ARRAY using the given INDICIES. Does not attempt to coerce the result into a Lisp object. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JEQUAL} +\index{JEQUAL} +--- Function: \textbf{jequal} [\textbf{java}] \textit{obj1 obj2} + +\begin{adjustwidth}{5em}{5em} +Compares obj1 with obj2 using java.lang.Object.equals() +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JNULL-REF-P} +\index{JNULL-REF-P} +--- Function: \textbf{jnull-ref-p} [\textbf{java}] \textit{object} + +\begin{adjustwidth}{5em}{5em} +Returns a non-NIL value when the JAVA-OBJECT `object` is `null`, +or signals a TYPE-ERROR condition if the object isn't of +the right type. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JNEW-ARRAY} +\index{JNEW-ARRAY} +--- Function: \textbf{jnew-array} [\textbf{java}] \textit{element-type \&rest dimensions} + +\begin{adjustwidth}{5em}{5em} +Creates a new Java array of type ELEMENT-TYPE, with the given DIMENSIONS. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:CHAIN} +\index{CHAIN} +--- Macro: \textbf{chain} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JFIELD} +\index{JFIELD} +--- Function: \textbf{jfield} [\textbf{java}] \textit{class-ref-or-field field-or-instance \&optional instance value} + +\begin{adjustwidth}{5em}{5em} +Retrieves or modifies a field in a Java class or instance. + +Supported argument patterns: + + Case 1: class-ref field-name: + Retrieves the value of a static field. + + Case 2: class-ref field-name instance-ref: + Retrieves the value of a class field of the instance. + + Case 3: class-ref field-name primitive-value: + Stores a primitive-value in a static field. + + Case 4: class-ref field-name instance-ref value: + Stores value in a class field of the instance. + + Case 5: class-ref field-name nil value: + Stores value in a static field (when value may be + confused with an instance-ref). + + Case 6: field-name instance: + Retrieves the value of a field of the instance. The + class is derived from the instance. + + Case 7: field-name instance value: + Stores value in a field of the instance. The class is + derived from the instance. + +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JAVA-OBJECT} +\index{JAVA-OBJECT} +--- Class: \textbf{java-object} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-INTERFACES} +\index{JCLASS-INTERFACES} +--- Function: \textbf{jclass-interfaces} [\textbf{java}] \textit{class} + +\begin{adjustwidth}{5em}{5em} +Returns the vector of interfaces of CLASS +\end{adjustwidth} + +\paragraph{} +\label{JAVA:+TRUE+} +\index{+TRUE+} +--- Variable: \textbf{+true+} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +The JVM primitive value for boolean true. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMAKE-INVOCATION-HANDLER} +\index{JMAKE-INVOCATION-HANDLER} +--- Function: \textbf{jmake-invocation-handler} [\textbf{java}] \textit{function} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JRESOLVE-METHOD} +\index{JRESOLVE-METHOD} +--- Function: \textbf{jresolve-method} [\textbf{java}] \textit{method-name instance \&rest args} + +\begin{adjustwidth}{5em}{5em} +Finds the most specific Java method METHOD-NAME on INSTANCE applicable to arguments ARGS. Returns NIL if no suitable method is found. The algorithm used for resolution is the same used by JCALL when it is called with a string as the first parameter (METHOD-REF). +\end{adjustwidth} + +\paragraph{} +\label{JAVA:MAKE-CLASSLOADER} +\index{MAKE-CLASSLOADER} +--- Function: \textbf{make-classloader} [\textbf{java}] \textit{\&optional parent} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMEMBER-PROTECTED-P} +\index{JMEMBER-PROTECTED-P} +--- Function: \textbf{jmember-protected-p} [\textbf{java}] \textit{member} + +\begin{adjustwidth}{5em}{5em} +MEMBER is a protected member of its declaring class +\end{adjustwidth} + +\paragraph{} +\label{JAVA:MAKE-IMMEDIATE-OBJECT} +\index{MAKE-IMMEDIATE-OBJECT} +--- Function: \textbf{make-immediate-object} [\textbf{java}] \textit{object \&optional type} + +\begin{adjustwidth}{5em}{5em} +Attempts to coerce a given Lisp object into a java-object of the +given type. If type is not provided, works as jobject-lisp-value. +Currently, type may be :BOOLEAN, treating the object as a truth value, +or :REF, which returns Java null if NIL is provided. + +Deprecated. Please use JAVA:+NULL+, JAVA:+TRUE+, and JAVA:+FALSE+ for +constructing wrapped primitive types, JAVA:JOBJECT-LISP-VALUE for converting a +JAVA:JAVA-OBJECT to a Lisp value, or JAVA:JNULL-REF-P to distinguish a wrapped +null JAVA-OBJECT from NIL. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JNEW-ARRAY-FROM-ARRAY} +\index{JNEW-ARRAY-FROM-ARRAY} +--- Function: \textbf{jnew-array-from-array} [\textbf{java}] \textit{element-type array} + +\begin{adjustwidth}{5em}{5em} +Returns a new Java array with base type ELEMENT-TYPE (a string or a class-ref) + initialized from ARRAY +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JOBJECT-CLASS} +\index{JOBJECT-CLASS} +--- Function: \textbf{jobject-class} [\textbf{java}] \textit{obj} + +\begin{adjustwidth}{5em}{5em} +Returns the Java class that OBJ belongs to +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JREDEFINE-METHOD} +\index{JREDEFINE-METHOD} +--- Function: \textbf{jredefine-method} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-FIELDS} +\index{JCLASS-FIELDS} +--- Function: \textbf{jclass-fields} [\textbf{java}] \textit{class \&key declared public} + +\begin{adjustwidth}{5em}{5em} +Returns a vector of all (or just the declared/public, if DECLARED/PUBLIC is true) fields of CLASS +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JAVA-EXCEPTION} +\index{JAVA-EXCEPTION} +--- Class: \textbf{java-exception} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:DESCRIBE-JAVA-OBJECT} +\index{DESCRIBE-JAVA-OBJECT} +--- Function: \textbf{describe-java-object} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JFIELD-RAW} +\index{JFIELD-RAW} +--- Function: \textbf{jfield-raw} [\textbf{java}] \textit{class-ref-or-field field-or-instance \&optional instance value} + +\begin{adjustwidth}{5em}{5em} +Retrieves or modifies a field in a Java class or instance. Does not +attempt to coerce its value or the result into a Lisp object. + +Supported argument patterns: + + Case 1: class-ref field-name: + Retrieves the value of a static field. + + Case 2: class-ref field-name instance-ref: + Retrieves the value of a class field of the instance. + + Case 3: class-ref field-name primitive-value: + Stores a primitive-value in a static field. + + Case 4: class-ref field-name instance-ref value: + Stores value in a class field of the instance. + + Case 5: class-ref field-name nil value: + Stores value in a static field (when value may be + confused with an instance-ref). + + Case 6: field-name instance: + Retrieves the value of a field of the instance. The + class is derived from the instance. + + Case 7: field-name instance value: + Stores value in a field of the instance. The class is + derived from the instance. + +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCONSTRUCTOR-PARAMS} +\index{JCONSTRUCTOR-PARAMS} +--- Function: \textbf{jconstructor-params} [\textbf{java}] \textit{constructor} + +\begin{adjustwidth}{5em}{5em} +Returns a vector of parameter types (Java classes) for CONSTRUCTOR +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMEMBER-STATIC-P} +\index{JMEMBER-STATIC-P} +--- Function: \textbf{jmember-static-p} [\textbf{java}] \textit{member} + +\begin{adjustwidth}{5em}{5em} +MEMBER is a static member of its declaring class +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCOERCE} +\index{JCOERCE} +--- Function: \textbf{jcoerce} [\textbf{java}] \textit{object intended-class} + +\begin{adjustwidth}{5em}{5em} +Attempts to coerce OBJECT into a JavaObject of class INTENDED-CLASS. Raises a TYPE-ERROR if no conversion is possible. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCONSTRUCTOR} +\index{JCONSTRUCTOR} +--- Function: \textbf{jconstructor} [\textbf{java}] \textit{class-ref \&rest parameter-class-refs} + +\begin{adjustwidth}{5em}{5em} +Returns a reference to the Java constructor of CLASS-REF with the given PARAMETER-CLASS-REFS. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JARRAY-SET} +\index{JARRAY-SET} +--- Function: \textbf{jarray-set} [\textbf{java}] \textit{java-array new-value \&rest indices} + +\begin{adjustwidth}{5em}{5em} +Stores NEW-VALUE at the given index in JAVA-ARRAY. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JARRAY-LENGTH} +\index{JARRAY-LENGTH} +--- Function: \textbf{jarray-length} [\textbf{java}] \textit{java-array} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JARRAY-REF} +\index{JARRAY-REF} +--- Function: \textbf{jarray-ref} [\textbf{java}] \textit{java-array \&rest indices} + +\begin{adjustwidth}{5em}{5em} +Dereferences the Java array JAVA-ARRAY using the given INDICIES, coercing the result into a Lisp object, if possible. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-FIELD} +\index{JCLASS-FIELD} +--- Function: \textbf{jclass-field} [\textbf{java}] \textit{class field-name} + +\begin{adjustwidth}{5em}{5em} +Returns the field named FIELD-NAME of CLASS +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JMAKE-PROXY} +\index{JMAKE-PROXY} +--- Generic Function: \textbf{jmake-proxy} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCALL-RAW} +\index{JCALL-RAW} +--- Function: \textbf{jcall-raw} [\textbf{java}] \textit{method-ref instance \&rest args} + +\begin{adjustwidth}{5em}{5em} +Invokes the Java method METHOD-REF on INSTANCE with arguments ARGS. Does not attempt to coerce the result into a Lisp object. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:+FALSE+} +\index{+FALSE+} +--- Variable: \textbf{+false+} [\textbf{java}] \textit{} + +\begin{adjustwidth}{5em}{5em} +The JVM primitive value for boolean false. +\end{adjustwidth} + +\paragraph{} +\label{JAVA:JCLASS-INTERFACE-P} +\index{JCLASS-INTERFACE-P} +--- Function: \textbf{jclass-interface-p} [\textbf{java}] \textit{class} + +\begin{adjustwidth}{5em}{5em} +Returns T if CLASS is an interface +\end{adjustwidth} + Modified: branches/1.0.x/abcl/doc/manual/threads.tex ============================================================================== --- branches/1.0.x/abcl/doc/manual/threads.tex Sat Jan 7 15:09:30 2012 (r13727) +++ branches/1.0.x/abcl/doc/manual/threads.tex Mon Jan 9 00:38:52 2012 (r13728) @@ -1,52 +1,235 @@ -\begin{verbatim} -THREADS:CURRENT-THREAD - Function: (not documented) -THREADS:DESTROY-THREAD - Function: (not documented) -THREADS:GET-MUTEX - Function: Acquires a lock on the `mutex'. -THREADS:INTERRUPT-THREAD - Function: Interrupts THREAD and forces it to apply FUNCTION to ARGS. -THREADS:MAILBOX-EMPTY-P - Function: Returns non-NIL if the mailbox can be read from, NIL otherwise. -THREADS:MAILBOX-PEEK - Function: Returns two values. The second returns non-NIL when the mailbox -THREADS:MAILBOX-READ - Function: Blocks on the mailbox until an item is available for reading. -THREADS:MAILBOX-SEND - Function: Sends an item into the mailbox, notifying 1 waiter -THREADS:MAKE-MAILBOX - Function: (not documented) -THREADS:MAKE-MUTEX - Function: (not documented) -THREADS:MAKE-THREAD - Function: (not documented) -THREADS:MAKE-THREAD-LOCK - Function: Returns an object to be used with the `with-thread-lock' macro. -THREADS:MAPCAR-THREADS - Function: (not documented) -THREADS:OBJECT-NOTIFY - Function: (not documented) -THREADS:OBJECT-NOTIFY-ALL - Function: (not documented) -THREADS:OBJECT-WAIT - Function: (not documented) -THREADS:RELEASE-MUTEX - Function: Releases a lock on the `mutex'. -THREADS:SYNCHRONIZED-ON - Function: (not documented) -THREADS:THREAD - Class: (not documented) -THREADS:THREAD-ALIVE-P - Function: Boolean predicate whether THREAD is alive. -THREADS:THREAD-JOIN - Function: Waits for thread to finish. -THREADS:THREAD-NAME - Function: (not documented) -THREADS:THREADP - Function: (not documented) -THREADS:WITH-MUTEX - Function: (not documented) -THREADS:WITH-THREAD-LOCK - Function: (not documented) -\end{verbatim} +\subsection{Exported Symbols from the THREADS package} + +\paragraph{} +\label{THREADS:MAILBOX-EMPTY-P} +\index{MAILBOX-EMPTY-P} +--- Function: \textbf{mailbox-empty-p} [\textbf{threads}] \textit{mailbox} + +\begin{adjustwidth}{5em}{5em} +Returns non-NIL if the mailbox can be read from, NIL otherwise. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:THREADP} +\index{THREADP} +--- Function: \textbf{threadp} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:DESTROY-THREAD} +\index{DESTROY-THREAD} +--- Function: \textbf{destroy-thread} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:WITH-MUTEX} +\index{WITH-MUTEX} +--- Macro: \textbf{with-mutex} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:THREAD-JOIN} +\index{THREAD-JOIN} +--- Function: \textbf{thread-join} [\textbf{threads}] \textit{thread} + +\begin{adjustwidth}{5em}{5em} +Waits for thread to finish. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:RELEASE-MUTEX} +\index{RELEASE-MUTEX} +--- Function: \textbf{release-mutex} [\textbf{threads}] \textit{mutex} + +\begin{adjustwidth}{5em}{5em} +Releases a lock on the `mutex'. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:OBJECT-WAIT} +\index{OBJECT-WAIT} +--- Function: \textbf{object-wait} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAKE-THREAD} +\index{MAKE-THREAD} +--- Function: \textbf{make-thread} [\textbf{threads}] \textit{function \&key name} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAKE-THREAD-LOCK} +\index{MAKE-THREAD-LOCK} +--- Function: \textbf{make-thread-lock} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +Returns an object to be used with the `with-thread-lock' macro. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:OBJECT-NOTIFY-ALL} +\index{OBJECT-NOTIFY-ALL} +--- Function: \textbf{object-notify-all} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAKE-MAILBOX} +\index{MAKE-MAILBOX} +--- Function: \textbf{make-mailbox} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:OBJECT-NOTIFY} +\index{OBJECT-NOTIFY} +--- Function: \textbf{object-notify} [\textbf{threads}] \textit{object} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:GET-MUTEX} +\index{GET-MUTEX} +--- Function: \textbf{get-mutex} [\textbf{threads}] \textit{mutex} + +\begin{adjustwidth}{5em}{5em} +Acquires a lock on the `mutex'. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAILBOX-PEEK} +\index{MAILBOX-PEEK} +--- Function: \textbf{mailbox-peek} [\textbf{threads}] \textit{mailbox} + +\begin{adjustwidth}{5em}{5em} +Returns two values. The second returns non-NIL when the mailbox +is empty. The first is the next item to be read from the mailbox +if the first is NIL. + +Note that due to multi-threading, the first value returned upon +peek, may be different from the one returned upon next read in the +calling thread. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:THREAD-ALIVE-P} +\index{THREAD-ALIVE-P} +--- Function: \textbf{thread-alive-p} [\textbf{threads}] \textit{thread} + +\begin{adjustwidth}{5em}{5em} +Boolean predicate whether THREAD is alive. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAILBOX-READ} +\index{MAILBOX-READ} +--- Function: \textbf{mailbox-read} [\textbf{threads}] \textit{mailbox} + +\begin{adjustwidth}{5em}{5em} +Blocks on the mailbox until an item is available for reading. +When an item is available, it is returned. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:SYNCHRONIZED-ON} +\index{SYNCHRONIZED-ON} +--- NIL: \textbf{synchronized-on} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +\end{adjustwidth} + +\paragraph{} +\label{THREADS:INTERRUPT-THREAD} +\index{INTERRUPT-THREAD} +--- Function: \textbf{interrupt-thread} [\textbf{threads}] \textit{thread function \&rest args} + +\begin{adjustwidth}{5em}{5em} +Interrupts THREAD and forces it to apply FUNCTION to ARGS. +When the function returns, the thread's original computation continues. If multiple interrupts are queued for a thread, they are all run, but the order is not guaranteed. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAKE-MUTEX} +\index{MAKE-MUTEX} +--- Function: \textbf{make-mutex} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:THREAD} +\index{THREAD} +--- Class: \textbf{thread} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:WITH-THREAD-LOCK} +\index{WITH-THREAD-LOCK} +--- Macro: \textbf{with-thread-lock} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAILBOX-SEND} +\index{MAILBOX-SEND} +--- Function: \textbf{mailbox-send} [\textbf{threads}] \textit{mailbox item} + +\begin{adjustwidth}{5em}{5em} +Sends an item into the mailbox, notifying 1 waiter +to wake up for retrieval of that object. +\end{adjustwidth} + +\paragraph{} +\label{THREADS:THREAD-NAME} +\index{THREAD-NAME} +--- Function: \textbf{thread-name} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:CURRENT-THREAD} +\index{CURRENT-THREAD} +--- Function: \textbf{current-thread} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + +\paragraph{} +\label{THREADS:MAPCAR-THREADS} +\index{MAPCAR-THREADS} +--- Function: \textbf{mapcar-threads} [\textbf{threads}] \textit{} + +\begin{adjustwidth}{5em}{5em} +NOT-DOCUMENTED +\end{adjustwidth} + From mevenson at common-lisp.net Mon Jan 9 09:55:59 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 01:55:59 -0800 Subject: [armedbear-cvs] r13729 - branches/1.0.x/abcl Message-ID: Author: mevenson Date: Mon Jan 9 01:55:58 2012 New Revision: 13729 Log: backport most recent copy of build properties Modified: branches/1.0.x/abcl/abcl.properties.in Modified: branches/1.0.x/abcl/abcl.properties.in ============================================================================== --- branches/1.0.x/abcl/abcl.properties.in Mon Jan 9 00:38:52 2012 (r13728) +++ branches/1.0.x/abcl/abcl.properties.in Mon Jan 9 01:55:58 2012 (r13729) @@ -1,7 +1,10 @@ # $Id$ +# XXX should be called 'build.properties' but this collides with its usage by the Eclipe IDE + # Template for settings the Ant based build process. + # Attempt to perform incremental compilation? #abcl.build.incremental=true @@ -13,13 +16,28 @@ # Examples: +# Java7 on 64bit optimizations +#java.options=-d64 -Xmx16g -XX:+CMSClassUnloadingEnabled -XX:MaxPermSize=2g + # Set the JVM to use a maximum of 1GB of RAM (only works for 64bit JVMs) #java.options=-d64 -Xmx1g +# Use a default garbage collector on another +#java.options=-d64 -Xmx4g -XX:+PrintGCDetails -XX:+UnlockExperimentalVMOptions -XX:+UseG1GC -XX:MaxGCPauseMillis=100 + +# Use a separate concurrent GC thread (java-1.6_14 or later) +#java.options=-d64 -Xmx8g -XX:+UseConcMarkSweepGC + +# Java 5 era (???) flag to GC class definitions +#java.options=-XX:+CMSPermGenSweepingEnabled + # The unloading of class definitions is a per jvm policy. For those # implementations which run out of permgen space, the following should # help things out. #java.options=-d64 -XX:+CMSClassUnloadingEnabled -XX:MaxPermSize=1g +# Enable assertions specified via the JVM contract +#java.options=-ea + # Additional site specific startup code to be merged in 'system.lisp' at build time #abcl.startup.file=${basedir}/startup.lisp From mevenson at common-lisp.net Mon Jan 9 10:53:47 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 02:53:47 -0800 Subject: [armedbear-cvs] r13731 - trunk/abcl Message-ID: Author: mevenson Date: Mon Jan 9 02:53:47 2012 New Revision: 13731 Log: Update CHANGES for abcl-1.0.1. Modified: trunk/abcl/CHANGES Modified: trunk/abcl/CHANGES ============================================================================== --- trunk/abcl/CHANGES Mon Jan 9 02:53:45 2012 (r13730) +++ trunk/abcl/CHANGES Mon Jan 9 02:53:47 2012 (r13731) @@ -3,6 +3,58 @@ svn.uri=:"http//common-lisp.net/project/armedbear/svn/trunk/abcl/" (unreleased) +Changes +------- + + * [r13695] Reimplementation of global symbol macros to avoid using + the symbol's value slot. + + * [r13696] DEFMACRO now supports documentation strings as per the + ANSI specification. + + * [r13700] ABCL loads under the Weblogic 10.3 application server. + + +Version 1.0.1 +============== +svn.uri=:"http//common-lisp.net/project/armedbear/svn/tags/1.0.1/abcl/" +(09 January 2012) + +Changes +------- + + * Updated ASDF to 2.019 + + * User Manual now contains more polished formating from docstring + groveling, an index of symbols, and additional enhancements. + + * 'abcl.properties.in' now contains examples of optimizing the ABCL + wrapper script for 64bit instances for Java7 and for Java6. + + * [r13720] Randomize string hash computation to guard against + exploits. + + * [r13723] New internal API in Package.java for looking up internal + vs. external symbols. + +Fixes +----- + + * [#181][r13718] The implementation now correctly loads ASDF definitions + from jar archives. This had prevented the ABCL-CONTRIB loading + mechanism from working. + + * [#177] Made the mechanism for locating the abcl-contrib archive + more robust + + * [#177] LIST-DIRECTORY no longer ignores :RESOLVE-SYMLINKS + + * [r13706] Fix Streadm.readToken() bug reported by Blake McBride. + + * [#183][r13703] Move threads-jss.lisp out of system source to + restore conditional recompilation logic. + + Version 1.0.0 ============== svn.uri=:"http//common-lisp.net/project/armedbear/svn/tags/1.0.0/abcl/" From mevenson at common-lisp.net Mon Jan 9 10:53:51 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 02:53:51 -0800 Subject: [armedbear-cvs] r13730 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jan 9 02:53:45 2012 New Revision: 13730 Log: Fix #177: make logic for finding abcl-contrib more robust. Issuing a (REQUIRE 'ABCL-CONTRIB) will now use the full name of the jar archive ABCL was loaded from if it is of the form `abcl.jar' or `abcl-x.y.z.jar` or `abcl-x.y.z-some-arbitrary-string.jar' to determine the location of the jar containing the ABCL-CONTRIB packages. The namestrings of the ASDF systems located by this mechanism are now printed to *STANDARD-OUTPUT*. Installations of the implementations loading from non-standard locations may use the SYS::*ABCL-JAR* and SYS:*ABCL-CONTRIB* specials to override this behavior. Modified: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Modified: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Mon Jan 9 01:55:58 2012 (r13729) +++ trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Mon Jan 9 02:53:45 2012 (r13730) @@ -2,21 +2,21 @@ (require :asdf) -;;; XXX make less sensitive to ABCL jar being called "abcl.jar" -;;; allow being called "abcl-x.y.z.jar for semantic versioning -;;; allow customization in system.lisp +;;; TODO possibly allow customization in system.lisp? (defun find-system-jar () - (dolist (loader (java:dump-classpath)) - (let ((abcl-jar - (find-if (lambda (p) (and - (or (equal (pathname-name p) "abcl") - (equal (pathname-name p) - (format nil "abcl-~A" - (lisp-implementation-version)))) - (equal (pathname-type p) "jar"))) - (rest loader)))) - (when abcl-jar - (return abcl-jar))))) + (flet ((match-system-jar (p) + "Match `abcl.jar` or `abcl-1.0.1.jar` or `abcl-1.0.1-something.jar`" + (and (pathnamep p) + (equal (pathname-type p) "jar") + (java:jstatic "matches" + "java.util.regex.Pattern" + "abcl(-[0-9]\\.[0-9]\\.[0-9](-.+)?)?" + (pathname-name p)) + p))) + (dolist (loader (java:dump-classpath)) + (let ((abcl-jar (some #'match-system-jar loader))) + (when abcl-jar + (return abcl-jar)))))) (defvar *abcl-jar* nil "Pathname of the jar that ABCL was loaded from. @@ -26,32 +26,41 @@ "Pathname of the ABCL contrib. Initialized via SYSTEM:FIND-CONTRIB") -(defun find-contrib (&optional (verbose nil)) +(defun find-contrib (&key (verbose nil)) "Attempt to find the ABCL contrib jar and add its contents to ASDF." (unless *abcl-contrib* (unless *abcl-jar* (setf *abcl-jar* (find-system-jar))) (when *abcl-jar* - (let ((abcl-contrib (make-pathname :defaults *abcl-jar* - :name "abcl-contrib"))) - (when (probe-file abcl-contrib) - (setf *abcl-contrib* abcl-contrib) - (dolist (asdf-file - (directory (make-pathname :device (list *abcl-contrib*) - :directory '(:absolute :wild) - :name :wild - :type "asd"))) - (let ((asdf-directory - (make-pathname :defaults asdf-file :name nil :type nil))) - (when verbose - (format t "Adding ~A to ASDF.~%" asdf-directory)) - (push asdf-directory asdf:*central-registry*))) - *abcl-contrib*))))) + (let* ((abcl-contrib-name + (concatenate 'string "abcl-contrib" + (subseq (pathname-name *abcl-jar*) 4))) + (abcl-contrib (make-pathname :defaults *abcl-jar* + :name abcl-contrib-name))) + (if (probe-file abcl-contrib) + (progn + (setf *abcl-contrib* abcl-contrib) + (dolist (asdf-file + (directory (make-pathname :device (list *abcl-contrib*) + :directory '(:absolute :wild) + :name :wild + :type "asd"))) + (let ((asdf-directory + (make-pathname :defaults asdf-file :name nil :type nil))) + (format verbose "Adding ~A to ASDF.~%" asdf-directory) + (push asdf-directory asdf:*central-registry*))) + *abcl-contrib*) + (format verbose "Failed to find abcl-contrib at '~A'." abcl-contrib)))))) -(when (find-contrib) + +(when (find-contrib :verbose t) (provide :abcl-contrib)) + + + + From mevenson at common-lisp.net Mon Jan 9 10:58:12 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 02:58:12 -0800 Subject: [armedbear-cvs] r13732 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Mon Jan 9 02:58:11 2012 New Revision: 13732 Log: backport r13730: make logic for finding abcl-contrib more robust. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/abcl-contrib.lisp ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Mon Jan 9 02:53:47 2012 (r13731) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/abcl-contrib.lisp Mon Jan 9 02:58:11 2012 (r13732) @@ -2,17 +2,21 @@ (require :asdf) -;;; XXX make less sensitive to ABCL jar being called "abcl.jar" -;;; allow being called "abcl-x.y.z.jar for semantic versioning -;;; allow customization in system.lisp +;;; TODO possibly allow customization in system.lisp? (defun find-system-jar () - (dolist (loader (java:dump-classpath)) - (let ((abcl-jar - (find-if (lambda (p) (and (equal (pathname-name p) "abcl") - (equal (pathname-type p) "jar"))) - (rest loader)))) - (when abcl-jar - (return abcl-jar))))) + (flet ((match-system-jar (p) + "Match `abcl.jar` or `abcl-1.0.1.jar` or `abcl-1.0.1-something.jar`" + (and (pathnamep p) + (equal (pathname-type p) "jar") + (java:jstatic "matches" + "java.util.regex.Pattern" + "abcl(-[0-9]\\.[0-9]\\.[0-9](-.+)?)?" + (pathname-name p)) + p))) + (dolist (loader (java:dump-classpath)) + (let ((abcl-jar (some #'match-system-jar loader))) + (when abcl-jar + (return abcl-jar)))))) (defvar *abcl-jar* nil "Pathname of the jar that ABCL was loaded from. @@ -22,32 +26,41 @@ "Pathname of the ABCL contrib. Initialized via SYSTEM:FIND-CONTRIB") -(defun find-contrib (&optional (verbose nil)) +(defun find-contrib (&key (verbose nil)) "Attempt to find the ABCL contrib jar and add its contents to ASDF." (unless *abcl-contrib* (unless *abcl-jar* (setf *abcl-jar* (find-system-jar))) (when *abcl-jar* - (let ((abcl-contrib (make-pathname :defaults *abcl-jar* - :name "abcl-contrib"))) - (when (probe-file abcl-contrib) - (setf *abcl-contrib* abcl-contrib) - (dolist (asdf-file - (directory (make-pathname :device (list *abcl-contrib*) - :directory '(:absolute :wild) - :name :wild - :type "asd"))) - (let ((asdf-directory - (make-pathname :defaults asdf-file :name nil :type nil))) - (when verbose - (format t "Adding ~A to ASDF.~%" asdf-directory)) - (push asdf-directory asdf:*central-registry*))) - *abcl-contrib*))))) + (let* ((abcl-contrib-name + (concatenate 'string "abcl-contrib" + (subseq (pathname-name *abcl-jar*) 4))) + (abcl-contrib (make-pathname :defaults *abcl-jar* + :name abcl-contrib-name))) + (if (probe-file abcl-contrib) + (progn + (setf *abcl-contrib* abcl-contrib) + (dolist (asdf-file + (directory (make-pathname :device (list *abcl-contrib*) + :directory '(:absolute :wild) + :name :wild + :type "asd"))) + (let ((asdf-directory + (make-pathname :defaults asdf-file :name nil :type nil))) + (format verbose "Adding ~A to ASDF.~%" asdf-directory) + (push asdf-directory asdf:*central-registry*))) + *abcl-contrib*) + (format verbose "Failed to find abcl-contrib at '~A'." abcl-contrib)))))) -(when (find-contrib) + +(when (find-contrib :verbose t) (provide :abcl-contrib)) + + + + From mevenson at common-lisp.net Mon Jan 9 10:59:00 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 02:59:00 -0800 Subject: [armedbear-cvs] r13733 - branches/1.0.x/abcl Message-ID: Author: mevenson Date: Mon Jan 9 02:59:00 2012 New Revision: 13733 Log: backport r13731: CHANGES for abcl-1.0.1. Modified: branches/1.0.x/abcl/CHANGES Modified: branches/1.0.x/abcl/CHANGES ============================================================================== --- branches/1.0.x/abcl/CHANGES Mon Jan 9 02:58:11 2012 (r13732) +++ branches/1.0.x/abcl/CHANGES Mon Jan 9 02:59:00 2012 (r13733) @@ -1,3 +1,55 @@ +Changes +------- + + * [r13695] Reimplementation of global symbol macros to avoid using + the symbol's value slot. + + * [r13696] DEFMACRO now supports documentation strings as per the + ANSI specification. + + * [r13700] ABCL loads under the Weblogic 10.3 application server. + + +Version 1.0.1 +============== +svn.uri=:"http//common-lisp.net/project/armedbear/svn/tags/1.0.1/abcl/" +(09 January 2012) + +Changes +------- + + * Updated ASDF to 2.019 + + * User Manual now contains more polished formating from docstring + groveling, an index of symbols, and additional enhancements. + + * 'abcl.properties.in' now contains examples of optimizing the ABCL + wrapper script for 64bit instances for Java7 and for Java6. + + * [r13720] Randomize string hash computation to guard against + exploits. + + * [r13723] New internal API in Package.java for looking up internal + vs. external symbols. + +Fixes +----- + + * [#181][r13718] The implementation now correctly loads ASDF definitions + from jar archives. This had prevented the ABCL-CONTRIB loading + mechanism from working. + + * [#177] Made the mechanism for locating the abcl-contrib archive + more robust + + * [#177] LIST-DIRECTORY no longer ignores :RESOLVE-SYMLINKS + + * [r13706] Fix Streadm.readToken() bug reported by Blake McBride. + + * [#183][r13703] Move threads-jss.lisp out of system source to + restore conditional recompilation logic. + + Version 1.0.0 ============== svn://common-lisp.net/project/armedbear/svn/tags/1.0.0/abcl From mevenson at common-lisp.net Mon Jan 9 11:01:00 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 03:01:00 -0800 Subject: [armedbear-cvs] r13734 - branches/1.0.x/abcl Message-ID: Author: mevenson Date: Mon Jan 9 03:00:59 2012 New Revision: 13734 Log: Update README version for 1.0.1 Modified: branches/1.0.x/abcl/README Modified: branches/1.0.x/abcl/README ============================================================================== --- branches/1.0.x/abcl/README Mon Jan 9 02:59:00 2012 (r13733) +++ branches/1.0.x/abcl/README Mon Jan 9 03:00:59 2012 (r13734) @@ -47,7 +47,7 @@ which should result in output like the following - Armed Bear Common Lisp 1.0.0 + Armed Bear Common Lisp 1.0.1 Java 1.6.0_21 Sun Microsystems Inc. Java HotSpot(TM) Client VM Low-level initialization completed in 0.3 seconds. @@ -183,7 +183,7 @@ ### Tests -ABCL 1.0.0 now fails only 18 out of 21708 total tests in the ANSI CL +ABCL 1.0.1 now fails only 18 out of 21708 total tests in the ANSI CL test suite (derived from the tests orginally written for GCL). Maxima's test suite runs without failures. @@ -207,5 +207,5 @@ Alessio Stalla Ville Voutilaninen -October 22, 2011 +Janurary 2012 From mevenson at common-lisp.net Mon Jan 9 11:19:31 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 03:19:31 -0800 Subject: [armedbear-cvs] r13735 - branches/1.0.x/abcl Message-ID: Author: mevenson Date: Mon Jan 9 03:19:30 2012 New Revision: 13735 Log: Don't include future features in CHANGES for point release. Modified: branches/1.0.x/abcl/CHANGES Modified: branches/1.0.x/abcl/CHANGES ============================================================================== --- branches/1.0.x/abcl/CHANGES Mon Jan 9 03:00:59 2012 (r13734) +++ branches/1.0.x/abcl/CHANGES Mon Jan 9 03:19:30 2012 (r13735) @@ -1,15 +1,3 @@ -Changes -------- - - * [r13695] Reimplementation of global symbol macros to avoid using - the symbol's value slot. - - * [r13696] DEFMACRO now supports documentation strings as per the - ANSI specification. - - * [r13700] ABCL loads under the Weblogic 10.3 application server. - - Version 1.0.1 ============== svn.uri=:"http//common-lisp.net/project/armedbear/svn/tags/1.0.1/abcl/" From mevenson at common-lisp.net Mon Jan 9 11:28:56 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 03:28:56 -0800 Subject: [armedbear-cvs] r13736 - branches/1.0.x/abcl Message-ID: Author: mevenson Date: Mon Jan 9 03:28:56 2012 New Revision: 13736 Log: Correct spelling of January Modified: branches/1.0.x/abcl/README Modified: branches/1.0.x/abcl/README ============================================================================== --- branches/1.0.x/abcl/README Mon Jan 9 03:19:30 2012 (r13735) +++ branches/1.0.x/abcl/README Mon Jan 9 03:28:56 2012 (r13736) @@ -207,5 +207,5 @@ Alessio Stalla Ville Voutilaninen -Janurary 2012 +January 2012 From mevenson at common-lisp.net Mon Jan 9 11:30:35 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 03:30:35 -0800 Subject: [armedbear-cvs] r13737 - in public_html/releases/1.0.1: . RC1 Message-ID: Author: mevenson Date: Mon Jan 9 03:30:34 2012 New Revision: 13737 Log: Upload abcl-1.0.1-rc1 distribution files. Added: public_html/releases/1.0.1/ public_html/releases/1.0.1/RC1/ From mevenson at common-lisp.net Mon Jan 9 11:31:39 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 09 Jan 2012 03:31:39 -0800 Subject: [armedbear-cvs] r13738 - public_html/releases/1.0.1/RC1 Message-ID: Author: mevenson Date: Mon Jan 9 03:31:38 2012 New Revision: 13738 Log: Upload abcl-1.0.1-rc1 distribution files. Added: public_html/releases/1.0.1/RC1/abcl-bin-1.0.1-rc1.tar.gz (contents, props changed) public_html/releases/1.0.1/RC1/abcl-bin-1.0.1-rc1.zip (contents, props changed) public_html/releases/1.0.1/RC1/abcl-src-1.0.1-rc1.tar.gz (contents, props changed) public_html/releases/1.0.1/RC1/abcl-src-1.0.1-rc1.zip (contents, props changed) Added: public_html/releases/1.0.1/RC1/abcl-bin-1.0.1-rc1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/1.0.1/RC1/abcl-bin-1.0.1-rc1.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/1.0.1/RC1/abcl-src-1.0.1-rc1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/1.0.1/RC1/abcl-src-1.0.1-rc1.zip ============================================================================== Binary file. No diff available. From astalla at common-lisp.net Mon Jan 9 22:55:38 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Mon, 09 Jan 2012 14:55:38 -0800 Subject: [armedbear-cvs] r13739 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jan 9 14:55:37 2012 New Revision: 13739 Log: Annotations in class-file: - support for enum-value elements; - rectified boolean valued elements (Z instead of B which is Byte) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Jan 9 03:31:38 2012 (r13738) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Mon Jan 9 14:55:37 2012 (r13739) @@ -81,7 +81,7 @@ |# (defstruct (jvm-class-name (:conc-name class-) - (:constructor %make-jvm-class-name)) + (:constructor %make-jvm-class-name)) "Used for class identification. The caller should instantiate only one `class-name' per class, as they are @@ -373,15 +373,19 @@ (defun pool-add-class (pool class) "Returns the index of the constant-pool class item for `class'. -`class' must be an instance of `class-name'." - (let ((entry (gethash class (pool-entries pool)))) - (unless entry - (let ((utf8 (pool-add-utf8 pool (class-name-internal class)))) - (setf entry - (make-constant-class (incf (pool-index pool)) utf8) - (gethash class (pool-entries pool)) entry)) - (push entry (pool-entries-list pool))) - (constant-index entry))) +`class' must be an instance of `class-name' or a string (which will be converted +to a `class-name')." + (let ((class (if (jvm-class-name-p class) + class + (make-jvm-class-name class)))) + (let ((entry (gethash class (pool-entries pool)))) + (unless entry + (let ((utf8 (pool-add-utf8 pool (class-name-internal class)))) + (setf entry + (make-constant-class (incf (pool-index pool)) utf8) + (gethash class (pool-entries pool)) entry)) + (push entry (pool-entries-list pool))) + (constant-index entry)))) (defun pool-add-field-ref (pool class name type) "Returns the index of the constant-pool item which denotes a reference @@ -1348,7 +1352,7 @@ type elements) -(defstruct annotation-element name value) +(defstruct annotation-element (name "value") value) (defstruct annotation-element-value tag finalizer writer) @@ -1360,19 +1364,46 @@ (etypecase value (boolean (setf (annotation-element-value-tag self) - (char-code #\B) + (char-code #\Z) + (primitive-or-string-annotation-element-value self) + (pool-add-int (class-file-constants class) (if value 1 0)))) + (fixnum + (setf (annotation-element-value-tag self) + (char-code #\I) + (primitive-or-string-annotation-element-value self) + (pool-add-int (class-file-constants class) value))) + (string + (setf (annotation-element-value-tag self) + (char-code #\s) (primitive-or-string-annotation-element-value self) - (pool-add-int (class-file-constants class) (if value 1 0)))))))) + (pool-add-utf8 (class-file-constants class) value))))))) (writer (lambda (self stream) (write-u1 (annotation-element-value-tag self) stream) (write-u2 (primitive-or-string-annotation-element-value self) stream))))) value) +(defstruct (enum-value-annotation-element-value + (:conc-name enum-value-annotation-element-) + (:include annotation-element-value + (finalizer (lambda (self class) + (setf (annotation-element-value-tag self) + (char-code #\e) + (enum-value-annotation-element-type self) + (pool-add-utf8 (class-file-constants class) + (enum-value-annotation-element-type self)) ;;Binary name as string + (enum-value-annotation-element-name self) + (pool-add-utf8 (class-file-constants class) + (enum-value-annotation-element-name self))))) + (writer (lambda (self stream) + (write-u1 (annotation-element-value-tag self) stream) + (write-u2 (enum-value-annotation-element-type self) stream) + (write-u2 (enum-value-annotation-element-name self) stream))))) + type + name) + (defstruct (runtime-visible-annotations-attribute (:include annotations-attribute - (name "RuntimeVisibleAnnotations") - (finalizer #'finalize-annotations) - (writer #'write-annotations))) + (name "RuntimeVisibleAnnotations"))) "4.8.15 The RuntimeVisibleAnnotations attribute The RuntimeVisibleAnnotations attribute is a variable length attribute in the attributes table of the ClassFile, field_info, and method_info structures. The @@ -1388,10 +1419,7 @@ (declare (ignore code)) (dolist (ann (annotations-list annotations)) (setf (annotation-type ann) - (pool-add-class (class-file-constants class) - (if (jvm-class-name-p (annotation-type ann)) - (annotation-type ann) - (make-jvm-class-name (annotation-type ann))))) + (pool-add-class (class-file-constants class) (annotation-type ann))) (dolist (elem (annotation-elements ann)) (setf (annotation-element-name elem) (pool-add-utf8 (class-file-constants class) @@ -1405,7 +1433,9 @@ (write-u2 (annotation-type annotation) stream) (write-u2 (length (annotation-elements annotation)) stream) (dolist (elem (reverse (annotation-elements annotation))) - (funcall (annotation-element-value-writer elem) elem stream)))) + (write-u2 (annotation-element-name elem) stream) + (funcall (annotation-element-value-writer (annotation-element-value elem)) + (annotation-element-value elem) stream)))) #| Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 9 03:31:38 2012 (r13738) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 9 14:55:37 2012 (r13739) @@ -1,6 +1,9 @@ (require "COMPILER-PASS2") (require "JVM-CLASS-FILE") +;;The package is set to :jvm for convenience, since most of the symbols used +;;here come from that package. However, the functions we're definining belong +;;to the :java package. (in-package :jvm) (defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject")) @@ -138,7 +141,16 @@ :methods (list (list "foo" :void '("java.lang.Object") (lambda (this that) (print (list this that))) - :annotations (list (make-annotation :type "java.lang.Deprecated"))) + :annotations (list (make-annotation :type "java.lang.Deprecated") + (make-annotation :type "java.lang.annotation.Retention" + :elements (list (make-annotation-element + :value (make-enum-value-annotation-element-value + :type "java.lang.annotation.RetentionPolicy" + :name "RUNTIME")))) + (make-annotation :type "javax.xml.bind.annotation.XmlAttribute" + :elements (list (make-annotation-element + :name "required" + :value (make-primitive-or-string-annotation-element-value :value t)))))) (list "bar" :int '("java.lang.Object") (lambda (this that) (print (list this that)) 23)))) From mevenson at common-lisp.net Tue Jan 10 08:13:14 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 00:13:14 -0800 Subject: [armedbear-cvs] r13740 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 10 00:13:11 2012 New Revision: 13740 Log: Push 1.0.1-RC1 version tag. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Mon Jan 9 14:55:37 2012 (r13739) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Tue Jan 10 00:13:11 2012 (r13740) @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "1.0.1-dev"; + static final String baseVersion = "1.0.1-rc1"; static void init() { try { From mevenson at common-lisp.net Tue Jan 10 14:04:25 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:04:25 -0800 Subject: [armedbear-cvs] r13741 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:04:24 2012 New Revision: 13741 Log: Correct to valid XHTML. Modified: public_html/release-notes-0.13.shtml public_html/release-notes-0.14.shtml public_html/release-notes-0.15.shtml public_html/release-notes-0.16.shtml public_html/release-notes-0.17.shtml public_html/release-notes-0.18.shtml public_html/release-notes-0.19.shtml public_html/release-notes-0.20.shtml public_html/release-notes-0.21.shtml public_html/release-notes-0.22.shtml public_html/release-notes-0.23.shtml public_html/release-notes-0.24.shtml public_html/release-notes-0.25.shtml public_html/release-notes-0.26.shtml Modified: public_html/release-notes-0.13.shtml ============================================================================== --- public_html/release-notes-0.13.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.13.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -6,7 +6,7 @@ <!--#include virtual="project-name" --> - Modified: public_html/release-notes-0.14.shtml ============================================================================== --- public_html/release-notes-0.14.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.14.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -6,7 +6,7 @@ <!--#include virtual="project-name" --> - Modified: public_html/release-notes-0.15.shtml ============================================================================== --- public_html/release-notes-0.15.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.15.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -6,7 +6,7 @@ <!--#include virtual="project-name" --> - @@ -59,8 +59,7 @@
Fixed special bindings un-binding in compiled code for MULTIPLE-VALUE-BIND, LET, LET*, PROGV and function bodies
- -
Special bindings now will get unbound even in case of (non-Lisp) +
Special bindings now will get unbound even in case of (non-Lisp) exceptions.
Reduced ANSI failures in interpreted mode
Modified: public_html/release-notes-0.16.shtml ============================================================================== --- public_html/release-notes-0.16.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.16.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -47,7 +47,7 @@
Various performance improvements
- + Modified: public_html/release-notes-0.17.shtml ============================================================================== --- public_html/release-notes-0.17.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.17.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -51,6 +51,7 @@ options). + Modified: public_html/release-notes-0.18.shtml ============================================================================== --- public_html/release-notes-0.18.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.18.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -53,7 +53,7 @@ being unused were incorrectly not GC-ed. This has now been resolved. - + Modified: public_html/release-notes-0.19.shtml ============================================================================== --- public_html/release-notes-0.19.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.19.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -41,7 +41,7 @@ - +
Modified: public_html/release-notes-0.20.shtml ============================================================================== --- public_html/release-notes-0.20.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.20.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -35,7 +35,7 @@
Several bugs have been fixed and many small speed improvements have been introduced.
- +
Modified: public_html/release-notes-0.21.shtml ============================================================================== --- public_html/release-notes-0.21.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.21.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -35,6 +35,8 @@
Including a few fixes on how certain objects are printed, a MACROLET bug, and support for JSR-223 with Java 1.5. Consult the CHANGES file distributed with ABCL for more details.
+ + Modified: public_html/release-notes-0.22.shtml ============================================================================== --- public_html/release-notes-0.22.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.22.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -34,6 +34,7 @@ +
Modified: public_html/release-notes-0.23.shtml ============================================================================== --- public_html/release-notes-0.23.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.23.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -55,7 +55,7 @@ - +
Modified: public_html/release-notes-0.24.shtml ============================================================================== --- public_html/release-notes-0.24.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.24.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -49,7 +49,7 @@ - +
Modified: public_html/release-notes-0.25.shtml ============================================================================== --- public_html/release-notes-0.25.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.25.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -55,7 +55,7 @@ the situation. - + Modified: public_html/release-notes-0.26.shtml ============================================================================== --- public_html/release-notes-0.26.shtml Tue Jan 10 00:13:11 2012 (r13740) +++ public_html/release-notes-0.26.shtml Tue Jan 10 06:04:24 2012 (r13741) @@ -52,7 +52,7 @@ since 0.25. - + From mevenson at common-lisp.net Tue Jan 10 14:05:46 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:05:46 -0800 Subject: [armedbear-cvs] r13742 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:05:45 2012 New Revision: 13742 Log: Add missing release notes for abcl-1.0.0. Start listing of release notes instead of merely linking to previous version. Added: public_html/release-notes-1.0.0.shtml public_html/release-notes.shtml Added: public_html/release-notes-1.0.0.shtml ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/release-notes-1.0.0.shtml Tue Jan 10 06:05:45 2012 (r13742) @@ -0,0 +1,65 @@ + + + + + ABCL - Release notes v1.0.0 + + + + + +
+

ABCL - Release notes for version v1.0.0

+
+ + + +
+ +

Most notable changes in ABCL 1.0.0

+ +

Release notes for older releases.

+"release-notes.shtml">Release notes for older releases.

+ +
+
ANSI Conformance
+
+ With a functioning long form of + DEFINE-METHOD-COMBINATION, Armed Bear Common Lisp is + plausibly now a conforming Common Lisp implementation. +
+ +
User Manual
+
+ A manual for users of the implementation has been drafted. +
+ +
Quicklisp
+
+ Extensive testing and the attendent bug fixing has resulted in + substantially improved capabilities vis a vis the ASDF systems + distributed with Quicklisp. Most notably + trivial-garbage, bordeaux-threads, parenscript, hunchentoot, and + cxml now work. +
+ +
ASDF-2.017.22
+
The ASDF shipped with the distribution has been updated to asdf-2.017.22
+ +
+ +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+ +
$Id: release-notes-0.27.shtml 13564 2011-09-03 18:26:55Z mevenson $
+ +
+ + Added: public_html/release-notes.shtml ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/release-notes.shtml Tue Jan 10 06:05:45 2012 (r13742) @@ -0,0 +1,59 @@ + + + + + Index of Armed Bear Common List Release Notes + + + + + + +
+

+
+ + + +
+ + +

Index of Armed Bear Common List Release Notes

+ + + +
+ +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id: release-notes-0.13.shtml 12008 2009-06-07 21:25:48Z ehuelsmann $
+
+ + From mevenson at common-lisp.net Tue Jan 10 14:06:16 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:06:16 -0800 Subject: [armedbear-cvs] r13743 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:06:15 2012 New Revision: 13743 Log: Release notes for upcoming abcl-1.0.1 release. Added: public_html/release-notes-1.0.1.shtml Added: public_html/release-notes-1.0.1.shtml ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/release-notes-1.0.1.shtml Tue Jan 10 06:06:15 2012 (r13743) @@ -0,0 +1,65 @@ + + + + + ABCL - Release notes v1.0.1 + + + + + +
+

ABCL - Release notes for version v1.0.1

+
+ + + +
+ +

Most notable changes in ABCL 1.0.1

+ +

+ abcl-1.0.1 is a maintenance release. +

+ +
+
ASDF
+ +
The ASDF included with the implementation has been updated to 2.019.
+ +
User Manaul
+
The User + manuala now contains more polished formating from docstring + groveling, an index of symbols, and additional enhancements. +
+ + +
ABCL-CONTRIB[#181]
+ +
The implementation now correctly loads ASDF definitions + from jar archives. This had prevented the ABCL-CONTRIB loading + mechanism from working.
+
+ +

The distribution contains a more detailed CHANGES

+ + +

Release notes for older releases.

+ +
+ + + +
+
+

Back to Common-lisp.net.

+ +
+ Valid XHTML 1.0 Strict +
+
$Id: release-notes-0.27.shtml 13564 2011-09-03 18:26:55Z mevenson $
+
+ + From mevenson at common-lisp.net Tue Jan 10 14:12:36 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:12:36 -0800 Subject: [armedbear-cvs] r13744 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:12:35 2012 New Revision: 13744 Log: Validation problems. Modified: public_html/left-menu public_html/release-notes-1.0.0.shtml public_html/release-notes-1.0.1.shtml Modified: public_html/left-menu ============================================================================== --- public_html/left-menu Tue Jan 10 06:06:15 2012 (r13743) +++ public_html/left-menu Tue Jan 10 06:12:35 2012 (r13744) @@ -2,7 +2,7 @@ Project page
FAQ
Testimonials
-Release notes
+Release notes
Paid support
Modified: public_html/release-notes-1.0.0.shtml ============================================================================== --- public_html/release-notes-1.0.0.shtml Tue Jan 10 06:06:15 2012 (r13743) +++ public_html/release-notes-1.0.0.shtml Tue Jan 10 06:12:35 2012 (r13744) @@ -19,9 +19,6 @@

Most notable changes in ABCL 1.0.0

-

Release notes for older releases.

-"release-notes.shtml">Release notes for older releases.

-
ANSI Conformance
@@ -47,6 +44,10 @@
ASDF-2.017.22
The ASDF shipped with the distribution has been updated to asdf-2.017.22
+
+ +

Release notes for older releases.

+ Modified: public_html/release-notes-1.0.1.shtml ============================================================================== --- public_html/release-notes-1.0.1.shtml Tue Jan 10 06:06:15 2012 (r13743) +++ public_html/release-notes-1.0.1.shtml Tue Jan 10 06:12:35 2012 (r13744) @@ -24,34 +24,32 @@

-
ASDF
+
ASDF
-
The ASDF included with the implementation has been updated to 2.019.
+
The ASDF included with the implementation has been updated to 2.019.
-
User Manaul
-
The User Manual
+
The User manuala now contains more polished formating from docstring groveling, an index of symbols, and additional enhancements. - +
-
ABCL-CONTRIB[#181]
+
ABCL-CONTRIB[#181]
-
The implementation now correctly loads ASDF definitions +
The implementation now correctly loads ASDF definitions from jar archives. This had prevented the ABCL-CONTRIB loading - mechanism from working. + mechanism from working.
-

The distribution contains a more detailed CHANGES

+

The distribution contains a more detailed documentation of CHANGES.

Release notes for older releases.

- -

Back to Common-lisp.net.

From mevenson at common-lisp.net Tue Jan 10 14:15:21 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:15:21 -0800 Subject: [armedbear-cvs] r13745 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:15:21 2012 New Revision: 13745 Log: Increase vertical space on release notes paragraphs. Modified: public_html/style.css Modified: public_html/style.css ============================================================================== --- public_html/style.css Tue Jan 10 06:12:35 2012 (r13744) +++ public_html/style.css Tue Jan 10 06:15:21 2012 (r13745) @@ -85,3 +85,8 @@ padding-left: 2ex; } +div.rn dl dd { + margin-top: 1em; + margin-bottom: 1em; +} + From mevenson at common-lisp.net Tue Jan 10 14:25:49 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:25:49 -0800 Subject: [armedbear-cvs] r13746 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:25:48 2012 New Revision: 13746 Log: Set Id keywords Modified: public_html/bugreporting.shtml (contents, props changed) public_html/commercial-support.shtml (contents, props changed) public_html/release-notes-0.23.shtml (contents, props changed) public_html/release-notes-1.0.0.shtml (contents, props changed) public_html/release-notes-1.0.1.shtml (contents, props changed) public_html/release-notes.shtml (contents, props changed) Modified: public_html/bugreporting.shtml ============================================================================== --- public_html/bugreporting.shtml Tue Jan 10 06:15:21 2012 (r13745) +++ public_html/bugreporting.shtml Tue Jan 10 06:25:48 2012 (r13746) @@ -69,7 +69,7 @@
Valid XHTML 1.0 Strict
-
$Id: contributing.shtml 12008 2009-06-07 21:25:48Z ehuelsmann $
+
$Id$
Modified: public_html/commercial-support.shtml ============================================================================== --- public_html/commercial-support.shtml Tue Jan 10 06:15:21 2012 (r13745) +++ public_html/commercial-support.shtml Tue Jan 10 06:25:48 2012 (r13746) @@ -68,7 +68,7 @@
Valid XHTML 1.0 Strict
-
$Id: index.shtml 12203 2009-10-17 19:43:18Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-0.23.shtml ============================================================================== --- public_html/release-notes-0.23.shtml Tue Jan 10 06:15:21 2012 (r13745) +++ public_html/release-notes-0.23.shtml Tue Jan 10 06:25:48 2012 (r13746) @@ -65,7 +65,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.22.shtml 12925 2010-09-26 17:39:13Z ehuelsmann $
+
$Id$
Modified: public_html/release-notes-1.0.0.shtml ============================================================================== --- public_html/release-notes-1.0.0.shtml Tue Jan 10 06:15:21 2012 (r13745) +++ public_html/release-notes-1.0.0.shtml Tue Jan 10 06:25:48 2012 (r13746) @@ -59,7 +59,7 @@ Valid XHTML 1.0 Strict -
$Id: release-notes-0.27.shtml 13564 2011-09-03 18:26:55Z mevenson $
+
$Id$
Modified: public_html/release-notes-1.0.1.shtml ============================================================================== --- public_html/release-notes-1.0.1.shtml Tue Jan 10 06:15:21 2012 (r13745) +++ public_html/release-notes-1.0.1.shtml Tue Jan 10 06:25:48 2012 (r13746) @@ -57,7 +57,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.27.shtml 13564 2011-09-03 18:26:55Z mevenson $
+
$Id$
Modified: public_html/release-notes.shtml ============================================================================== --- public_html/release-notes.shtml Tue Jan 10 06:15:21 2012 (r13745) +++ public_html/release-notes.shtml Tue Jan 10 06:25:48 2012 (r13746) @@ -53,7 +53,7 @@
Valid XHTML 1.0 Strict
-
$Id: release-notes-0.13.shtml 12008 2009-06-07 21:25:48Z ehuelsmann $
+
$Id$
From mevenson at common-lisp.net Tue Jan 10 14:26:33 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 06:26:33 -0800 Subject: [armedbear-cvs] r13747 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 06:26:33 2012 New Revision: 13747 Log: Let the typography in the release note headers 'breathe' a bit. Modified: public_html/style.css Modified: public_html/style.css ============================================================================== --- public_html/style.css Tue Jan 10 06:25:48 2012 (r13746) +++ public_html/style.css Tue Jan 10 06:26:33 2012 (r13747) @@ -83,6 +83,8 @@ background: #369; color: #fff; padding-left: 2ex; + padding-top: 0.2em; + padding-bottom: 0.2em; } div.rn dl dd { From mevenson at common-lisp.net Tue Jan 10 18:58:51 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 10:58:51 -0800 Subject: [armedbear-cvs] r13748 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 10:58:49 2012 New Revision: 13748 Log: More polishing the release notes for abcl-1.0.1 Modified: public_html/release-notes-1.0.1.shtml Modified: public_html/release-notes-1.0.1.shtml ============================================================================== --- public_html/release-notes-1.0.1.shtml Tue Jan 10 06:26:33 2012 (r13747) +++ public_html/release-notes-1.0.1.shtml Tue Jan 10 10:58:49 2012 (r13748) @@ -30,7 +30,7 @@
User Manual
The User + href="http://code.google.com/p/abcl-dynamic-install/downloads/detail?name=abcl-20120110a.pdf">User manuala now contains more polished formating from docstring groveling, an index of symbols, and additional enhancements.
@@ -46,12 +46,13 @@

The distribution contains a more detailed documentation of CHANGES.

-

Release notes for older releases.

+

Release notes for older releases of ABCL.

+

ABCL is Armed Bear Common Lisp.

Back to Common-lisp.net.

From mevenson at common-lisp.net Tue Jan 10 20:11:15 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 12:11:15 -0800 Subject: [armedbear-cvs] r13749 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Tue Jan 10 12:11:14 2012 New Revision: 13749 Log: Manual updates for abcl-1.0.1. Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Tue Jan 10 10:58:49 2012 (r13748) +++ trunk/abcl/doc/manual/abcl.tex Tue Jan 10 12:11:14 2012 (r13749) @@ -5,7 +5,7 @@ \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{January 5, 2012} +\date{January 10, 2012} \author{Mark~Evenson, Erik~H\"{u}lsmann, Alessio~Stalla, Ville~Voutilainen} \maketitle @@ -21,7 +21,7 @@ implementation for users of the system. \subsection{Version} -This manual corresponds to abcl-1.0.1. +This manual corresponds to abcl-1.0.1 released on January 10, 2012. \subsection{License} @@ -36,28 +36,32 @@ % TODO format this better, optionally link to URI -% Thanks for the markup -Philipp Marek +\begin{itemize} +\item Philipp Marek +\texttt{Thanks for the markup} +\item Douglas Miles +\texttt{Thanks for the whacky IKVM stuff and keeping the flame alive + in the dark years.} + -% Thanks for the whacky IKVM stuff and keeping the flame alive -Douglas Miles +\item Alan Ruttenberg +\texttt{Thanks for JSS.} -% Thanks for JSS -Alan Ruttenberg -and of course +\item and of course +\emph{Peter Graves} +\end{itemize} -Peter Graves \chapter{Running} \textsc{ABCL} is packaged as a single jar file usually named either -``abcl.jar'' or possibly``abcl-1.0.0.jar'' if one is using a versioned -package from your system vendor. This byte archive can be executed -under the control of a suitable JVM \footnote {Java Virtual Machine} -by using the ``-jar'' option to parse the manifest, and select the -class named therein ``\code{org.armedbear.lisp.Main}'' for execution, -viz: +``abcl.jar'' or possibly``abcl-1.0.1.jar'' if one is using a versioned +package on the local filesytem from your system vendor. This byte +archive can be executed under the control of a suitable JVM \footnote +{Java Virtual Machine} by using the ``-jar'' option to parse the +manifest, and select the class named therein +``\code{org.armedbear.lisp.Main}'' for execution, viz: \begin{listing-shell} cmd$ java -jar abcl.jar @@ -1054,6 +1058,9 @@ systems the code in this package will recursively package all the required source and fasls in a jar archive. +\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown} + + \section{jss} \label{section:jss} @@ -1065,13 +1072,17 @@ Example: \begin{listing-lisp} + CL-USER> (require 'jss) CL-USER) (#"getProperties" 'java.lang.System) CL-USER) (#"propertyNames" (#"getProperties" 'java.lang.System)) + \end{listing-lisp} +\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/jss/README.markdown} + \section{asdf-install} The asdf-install contrib provides an implementation of ASDF-INSTALL. @@ -1101,8 +1112,8 @@ contemporary Common Lisp implementation. On October 22, 2011, with the publication of this Manual explicitly -stating the conformance of Armed Bear Common Lisp to \textsc{ANSI}, we released -abcl-1.0.0. +stating the conformance of Armed Bear Common Lisp to \textsc{ANSI}, we +released abcl-1.0.0. From mevenson at common-lisp.net Tue Jan 10 20:11:28 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 12:11:28 -0800 Subject: [armedbear-cvs] r13750 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 10 12:11:27 2012 New Revision: 13750 Log: Fix #172: DOCUMENTATION now works for generic functions. LispObject.java didn't know that things other than Function could be in a symbol's function slot. # From: Rudolf Schlatte # Subject: [armedbear-devel] Patch for bug 172 # Date: January 10, 2012 8:54:16 PM GMT+01:00 Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java Modified: trunk/abcl/src/org/armedbear/lisp/LispObject.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispObject.java Tue Jan 10 12:11:14 2012 (r13749) +++ trunk/abcl/src/org/armedbear/lisp/LispObject.java Tue Jan 10 12:11:27 2012 (r13750) @@ -658,7 +658,7 @@ return ((Cons)entry).cdr; } if(docType == Symbol.FUNCTION && this instanceof Symbol) { - Object fn = ((Symbol)this).getSymbolFunction(); + LispObject fn = ((Symbol)this).getSymbolFunction(); if(fn instanceof Function) { DocString ds = fn.getClass().getAnnotation(DocString.class); if(ds != null) { @@ -670,6 +670,10 @@ SimpleString doc = new SimpleString(docstring); ((Symbol)this).setDocumentation(Symbol.FUNCTION, doc); return doc; + } else if (fn instanceof StandardGenericFunction) { + return + StandardGenericFunction.checkStandardGenericFunction(fn) + .slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION]; } } } From mevenson at common-lisp.net Tue Jan 10 20:19:04 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 12:19:04 -0800 Subject: [armedbear-cvs] r13751 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 10 12:19:03 2012 New Revision: 13751 Log: Go for abcl-1.0.1 Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Tue Jan 10 12:11:27 2012 (r13750) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Tue Jan 10 12:19:03 2012 (r13751) @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "1.0.1-rc1"; + static final String baseVersion = "1.0.1"; static void init() { try { From mevenson at common-lisp.net Tue Jan 10 20:23:56 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 12:23:56 -0800 Subject: [armedbear-cvs] r13752 - public_html/releases/1.0.1 Message-ID: Author: mevenson Date: Tue Jan 10 12:23:56 2012 New Revision: 13752 Log: Binaries for abcl-1.0.1 release. Added: public_html/releases/1.0.1/abcl-bin-1.0.1.tar.gz (contents, props changed) public_html/releases/1.0.1/abcl-bin-1.0.1.zip (contents, props changed) public_html/releases/1.0.1/abcl-src-1.0.1.tar.gz (contents, props changed) public_html/releases/1.0.1/abcl-src-1.0.1.zip (contents, props changed) Added: public_html/releases/1.0.1/abcl-bin-1.0.1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/1.0.1/abcl-bin-1.0.1.zip ============================================================================== Binary file. No diff available. Added: public_html/releases/1.0.1/abcl-src-1.0.1.tar.gz ============================================================================== Binary file. No diff available. Added: public_html/releases/1.0.1/abcl-src-1.0.1.zip ============================================================================== Binary file. No diff available. From mevenson at common-lisp.net Tue Jan 10 20:27:30 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 12:27:30 -0800 Subject: [armedbear-cvs] r13753 - public_html/releases/1.0.1 Message-ID: Author: mevenson Date: Tue Jan 10 12:27:29 2012 New Revision: 13753 Log: Cryptographic signatures from . Added: public_html/releases/1.0.1/abcl-bin-1.0.1.tar.gz.asc public_html/releases/1.0.1/abcl-bin-1.0.1.zip.asc public_html/releases/1.0.1/abcl-src-1.0.1.tar.gz.asc public_html/releases/1.0.1/abcl-src-1.0.1.zip.asc Added: public_html/releases/1.0.1/abcl-bin-1.0.1.tar.gz.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/1.0.1/abcl-bin-1.0.1.tar.gz.asc Tue Jan 10 12:27:29 2012 (r13753) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.11 (Darwin) + +iEYEABECAAYFAk8MnvsACgkQ/r0B/5bBSUpWIgCghGuPEj4ctv+llVZ/hMKQw6uw +VB8AnAycDTi6oYkKw9vBuECJ6NQRcTQJ +=1+UK +-----END PGP SIGNATURE----- Added: public_html/releases/1.0.1/abcl-bin-1.0.1.zip.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/1.0.1/abcl-bin-1.0.1.zip.asc Tue Jan 10 12:27:29 2012 (r13753) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.11 (Darwin) + +iEYEABECAAYFAk8MntoACgkQ/r0B/5bBSUolsgCaAklZH0Uz9frpWP2P8SW8I/Lb +nx8AoJhR0mIIVCwvk4QbWdKeZUy8DDvN +=Ca7g +-----END PGP SIGNATURE----- Added: public_html/releases/1.0.1/abcl-src-1.0.1.tar.gz.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/1.0.1/abcl-src-1.0.1.tar.gz.asc Tue Jan 10 12:27:29 2012 (r13753) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.11 (Darwin) + +iEYEABECAAYFAk8MnvMACgkQ/r0B/5bBSUqozQCgi54NDl/2W1kSSHjzJX1HIbrk ++EYAn03EnSqWSZmFnQ4vaz+3PeaMmQ0x +=nbLv +-----END PGP SIGNATURE----- Added: public_html/releases/1.0.1/abcl-src-1.0.1.zip.asc ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ public_html/releases/1.0.1/abcl-src-1.0.1.zip.asc Tue Jan 10 12:27:29 2012 (r13753) @@ -0,0 +1,7 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.11 (Darwin) + +iEYEABECAAYFAk8Mnw4ACgkQ/r0B/5bBSUp4ZwCfT/0u6DsrhRbeL2GxdSchFjc6 +qhQAn2bMz+NgkTgKZLzWmRxqmS5F5iN0 +=23Iy +-----END PGP SIGNATURE----- From mevenson at common-lisp.net Tue Jan 10 21:06:40 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 13:06:40 -0800 Subject: [armedbear-cvs] r13754 - public_html Message-ID: Author: mevenson Date: Tue Jan 10 13:06:39 2012 New Revision: 13754 Log: Release abcl-1.0.1 with signatures to tag. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Tue Jan 10 12:27:29 2012 (r13753) +++ public_html/index.shtml Tue Jan 10 13:06:39 2012 (r13754) @@ -61,25 +61,33 @@ Binary - abcl-bin-1.0.0.tar.gz - (pgp) + abcl-bin-1.0.1.tar.gz + (pgp) - abcl-bin-1.0.0.zip - (pgp) + abcl-bin-1.0.1.zip + (pgp) + + + abcl-contrib-1.0.1.jar + (pgp) - abcl-contrib-1.0.0.jar Source - abcl-src-1.0.0.tar.gz - (pgp) + abcl-src-1.0.1.tar.gz + (pgp) + + + abcl-src-1.0.1.zip + (pgp) - abcl-src-1.0.0.zip - (pgp) + + abcl-contrib source + From astalla at common-lisp.net Tue Jan 10 23:07:59 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Tue, 10 Jan 2012 15:07:59 -0800 Subject: [armedbear-cvs] r13755 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jan 10 15:07:58 2012 New Revision: 13755 Log: [jvm-class-file] Coalesce annotation-element and annotation-element-value into a single struct for simplicity. Array- and annotation-valued elements. Small refactor of annotation finalizers and writers. Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jan 10 13:06:39 2012 (r13754) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jan 10 15:07:58 2012 (r13755) @@ -1352,54 +1352,72 @@ type elements) -(defstruct annotation-element (name "value") value) +(defstruct annotation-element (name "value") tag finalizer writer) -(defstruct annotation-element-value tag finalizer writer) - -(defstruct (primitive-or-string-annotation-element-value - (:conc-name primitive-or-string-annotation-element-) - (:include annotation-element-value +(defstruct (primitive-or-string-annotation-element + (:include annotation-element (finalizer (lambda (self class) (let ((value (primitive-or-string-annotation-element-value self))) (etypecase value (boolean - (setf (annotation-element-value-tag self) + (setf (annotation-element-tag self) (char-code #\Z) (primitive-or-string-annotation-element-value self) (pool-add-int (class-file-constants class) (if value 1 0)))) (fixnum - (setf (annotation-element-value-tag self) + (setf (annotation-element-tag self) (char-code #\I) (primitive-or-string-annotation-element-value self) (pool-add-int (class-file-constants class) value))) (string - (setf (annotation-element-value-tag self) + (setf (annotation-element-tag self) (char-code #\s) (primitive-or-string-annotation-element-value self) (pool-add-utf8 (class-file-constants class) value))))))) (writer (lambda (self stream) - (write-u1 (annotation-element-value-tag self) stream) + (write-u1 (annotation-element-tag self) stream) (write-u2 (primitive-or-string-annotation-element-value self) stream))))) value) -(defstruct (enum-value-annotation-element-value - (:conc-name enum-value-annotation-element-) - (:include annotation-element-value +(defstruct (enum-value-annotation-element + (:include annotation-element + (tag (char-code #\e)) (finalizer (lambda (self class) - (setf (annotation-element-value-tag self) - (char-code #\e) - (enum-value-annotation-element-type self) + (setf (enum-value-annotation-element-type self) (pool-add-utf8 (class-file-constants class) (enum-value-annotation-element-type self)) ;;Binary name as string - (enum-value-annotation-element-name self) + (enum-value-annotation-element-value self) (pool-add-utf8 (class-file-constants class) - (enum-value-annotation-element-name self))))) + (enum-value-annotation-element-value self))))) (writer (lambda (self stream) - (write-u1 (annotation-element-value-tag self) stream) + (write-u1 (annotation-element-tag self) stream) (write-u2 (enum-value-annotation-element-type self) stream) - (write-u2 (enum-value-annotation-element-name self) stream))))) + (write-u2 (enum-value-annotation-element-value self) stream))))) type - name) + value) + +(defstruct (annotation-value-annotation-element + (:include annotation-element + (tag (char-code #\@)) + (finalizer (lambda (self class) + (finalize-annotation (annotation-value-annotation-element-value self) class))) + (writer (lambda (self stream) + (write-u1 (annotation-element-tag self) stream) + (write-annotation (annotation-value-annotation-element-value self) stream))))) + value) + +(defstruct (array-annotation-element + (:include annotation-element + (tag (char-code #\[)) + (finalizer (lambda (self class) + (dolist (elem (array-annotation-element-values self)) + (finalize-annotation-element elem class)))) + (writer (lambda (self stream) + (write-u1 (annotation-element-tag self) stream) + (write-u2 (length (array-annotation-element-values self)) stream) + (dolist (elem (array-annotation-element-values self)) + (write-annotation-element elem stream)))))) + values) ;;In proper order (defstruct (runtime-visible-annotations-attribute (:include annotations-attribute @@ -1418,24 +1436,38 @@ (defun finalize-annotations (annotations code class) (declare (ignore code)) (dolist (ann (annotations-list annotations)) - (setf (annotation-type ann) - (pool-add-class (class-file-constants class) (annotation-type ann))) - (dolist (elem (annotation-elements ann)) - (setf (annotation-element-name elem) - (pool-add-utf8 (class-file-constants class) - (annotation-element-name elem))) - (funcall (annotation-element-value-finalizer (annotation-element-value elem)) - (annotation-element-value elem) class)))) + (finalize-annotation ann class))) + +(defun finalize-annotation (ann class) + (setf (annotation-type ann) + (pool-add-class (class-file-constants class) (annotation-type ann))) + (dolist (elem (annotation-elements ann)) + (finalize-annotation-element elem class))) + +(defun finalize-annotation-element (elem class) + (when (annotation-element-name elem) + (setf (annotation-element-name elem) + (pool-add-utf8 (class-file-constants class) + (annotation-element-name elem)))) + (funcall (annotation-element-finalizer elem) + elem class)) (defun write-annotations (annotations stream) (write-u2 (length (annotations-list annotations)) stream) (dolist (annotation (reverse (annotations-list annotations))) - (write-u2 (annotation-type annotation) stream) - (write-u2 (length (annotation-elements annotation)) stream) - (dolist (elem (reverse (annotation-elements annotation))) - (write-u2 (annotation-element-name elem) stream) - (funcall (annotation-element-value-writer (annotation-element-value elem)) - (annotation-element-value elem) stream)))) + (write-annotation annotation stream))) + +(defun write-annotation (annotation stream) + (write-u2 (annotation-type annotation) stream) + (write-u2 (length (annotation-elements annotation)) stream) + (dolist (elem (reverse (annotation-elements annotation))) + (write-annotation-element elem stream))) + +(defun write-annotation-element (elem stream) + (when (annotation-element-name elem) + (write-u2 (annotation-element-name elem) stream)) + (funcall (annotation-element-writer elem) + elem stream)) #| Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 10 13:06:39 2012 (r13754) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 10 15:07:58 2012 (r13755) @@ -143,14 +143,13 @@ (lambda (this that) (print (list this that))) :annotations (list (make-annotation :type "java.lang.Deprecated") (make-annotation :type "java.lang.annotation.Retention" - :elements (list (make-annotation-element - :value (make-enum-value-annotation-element-value - :type "java.lang.annotation.RetentionPolicy" - :name "RUNTIME")))) + :elements (list (make-enum-value-annotation-element + :type "java.lang.annotation.RetentionPolicy" + :value "RUNTIME"))) (make-annotation :type "javax.xml.bind.annotation.XmlAttribute" - :elements (list (make-annotation-element + :elements (list (make-primitive-or-string-annotation-element :name "required" - :value (make-primitive-or-string-annotation-element-value :value t)))))) + :value t))))) (list "bar" :int '("java.lang.Object") (lambda (this that) (print (list this that)) 23)))) From astalla at common-lisp.net Tue Jan 10 23:15:26 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Tue, 10 Jan 2012 15:15:26 -0800 Subject: [armedbear-cvs] r13756 - in trunk/abcl: . contrib Message-ID: Author: astalla Date: Tue Jan 10 15:15:26 2012 New Revision: 13756 Log: Update POMs and readme for 1.0.1 release to Sonatype Modified: trunk/abcl/build.xml trunk/abcl/contrib/pom.xml trunk/abcl/maven-release.txt trunk/abcl/pom.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Tue Jan 10 15:07:58 2012 (r13755) +++ trunk/abcl/build.xml Tue Jan 10 15:15:26 2012 (r13756) @@ -491,6 +491,10 @@ + + + + @@ -523,6 +527,20 @@ + + + + + + + + + + + + + + Invoke ABCL with JPDA listener on port 6789 org.armedbear.lisp abcl-contrib - 0.28.0-SNAPSHOT + 1.0.1 jar Armed Bear Common Lisp (ABCL) Contribs Extra packages--contribs--for ABCL Modified: trunk/abcl/maven-release.txt ============================================================================== --- trunk/abcl/maven-release.txt Tue Jan 10 15:07:58 2012 (r13755) +++ trunk/abcl/maven-release.txt Tue Jan 10 15:15:26 2012 (r13756) @@ -29,7 +29,10 @@ mvn gpg:sign-and-deploy-file -Dfile=dist/abcl.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-${abcl.version}-sources.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging -Dclassifier=sources mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-${abcl.version}-javadoc.jar -DpomFile=pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging -Dclassifier=javadoc -mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-contrib-${abcl.version}.jar -DpomFile=contrib/pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging +# Contrib releases +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-contrib.jar -DpomFile=contrib/pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-contrib-sources.jar -DpomFile=contrib/pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging -Dclassifier=sources +mvn gpg:sign-and-deploy-file -Dfile=dist/abcl-contrib-javadoc.jar -DpomFile=contrib/pom.xml -Durl=https://oss.sonatype.org/service/local/staging/deploy/maven2/ -DrepositoryId=sonatype-nexus-staging -Dclassifier=javadoc Modified: trunk/abcl/pom.xml ============================================================================== --- trunk/abcl/pom.xml Tue Jan 10 15:07:58 2012 (r13755) +++ trunk/abcl/pom.xml Tue Jan 10 15:15:26 2012 (r13756) @@ -13,7 +13,7 @@ org.armedbear.lisp abcl - 0.28.0-SNAPSHOT + 1.0.1 jar ABCL - Armed Bear Common Lisp Common Lisp implementation running on the JVM From mevenson at common-lisp.net Tue Jan 10 23:21:18 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 15:21:18 -0800 Subject: [armedbear-cvs] r13757 - in tags/1.0.1: . abcl Message-ID: Author: mevenson Date: Tue Jan 10 15:21:17 2012 New Revision: 13757 Log: Tag the abcl-1.0.1 release. Added: tags/1.0.1/ tags/1.0.1/abcl/ - copied from r13756, branches/1.0.x/abcl/ From mevenson at common-lisp.net Tue Jan 10 23:22:42 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 10 Jan 2012 15:22:42 -0800 Subject: [armedbear-cvs] r13758 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Tue Jan 10 15:22:41 2012 New Revision: 13758 Log: Bump version to abcl-1.0.2-dev. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Tue Jan 10 15:21:17 2012 (r13757) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Version.java Tue Jan 10 15:22:41 2012 (r13758) @@ -41,7 +41,7 @@ { private Version() {} - static final String baseVersion = "1.0.1"; + static final String baseVersion = "1.0.2-dev"; static void init() { try { From mevenson at common-lisp.net Wed Jan 11 10:23:39 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 11 Jan 2012 02:23:39 -0800 Subject: [armedbear-cvs] r13759 - public_html Message-ID: Author: mevenson Date: Wed Jan 11 02:23:38 2012 New Revision: 13759 Log: Update FAQ with location of ~/.abclrc file Modified: public_html/faq.shtml Modified: public_html/faq.shtml ============================================================================== --- public_html/faq.shtml Tue Jan 10 15:22:41 2012 (r13758) +++ public_html/faq.shtml Wed Jan 11 02:23:38 2012 (r13759) @@ -39,10 +39,16 @@
  • Running
      -
    1. Java is running out of memory - with an error reporting something about - "java.lang.OutOfMemoryError: PermGen space". What can I - do?
      2. +
    2. + Java is running out of memory + with an error reporting something about + "java.lang.OutOfMemoryError: PermGen space". What can I + do? +
      3. +
    3. + What's the name of the startup configuration file? +
      4. +
    • @@ -119,9 +125,8 @@

    -Developers can also usually be found on the #abcl -irc channel. +Developers can also usually be found on the +#abcl irc channel.

    @@ -171,7 +176,7 @@ Additionally, compilation of AP5 is used to improve this measure too.

    -

    ABCL 0.26.2 fails roughly 20 out of 21702 tests in the ANSI test +

    ABCL 1.0.1 fails roughly 20 out of 21702 tests in the ANSI test suite in interpreted and compiled modes, a constant number over the past releases.

    @@ -202,6 +207,7 @@ kind of documentation you're looking for.

      +
    1. Users of the system are invited to start with the Armed Bear Common Lisp User Manual
    2. Our wiki
    3. The source code (JavaDoc and general comments)
      4. @@ -266,6 +272,14 @@ 'abcl.properties', and then ensure that the 'java.options' variable is set to the desired options.

      + +
      +

      Is there a file that customizes the startup of the ABCL process?

      + +

      + The file ~/.abclrc is loaded by the implementation if the --noinit flag is not specified. +

      +
    From mevenson at common-lisp.net Wed Jan 11 10:23:55 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 11 Jan 2012 02:23:55 -0800 Subject: [armedbear-cvs] r13760 - public_html Message-ID: Author: mevenson Date: Wed Jan 11 02:23:54 2012 New Revision: 13760 Log: Correct URI for abcl-contrib source. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Wed Jan 11 02:23:38 2012 (r13759) +++ public_html/index.shtml Wed Jan 11 02:23:54 2012 (r13760) @@ -85,7 +85,7 @@ (pgp) - + abcl-contrib source From ehuelsmann at common-lisp.net Wed Jan 11 16:28:54 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 11 Jan 2012 08:28:54 -0800 Subject: [armedbear-cvs] r13761 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 11 08:28:53 2012 New Revision: 13761 Log: Better context reporting during initarg checking. 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 Wed Jan 11 02:23:54 2012 (r13760) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 11 08:28:53 2012 (r13761) @@ -696,7 +696,7 @@ (check-initargs (list #'allocate-instance #'initialize-instance) (list* class initargs) class t initargs - *make-instance-initargs-cache*) + *make-instance-initargs-cache* 'make-instance) (%set-class-name name class) (%set-class-layout nil class) (%set-class-direct-subclasses () class) @@ -2764,7 +2764,7 @@ (defun check-initargs (gf-list args instance shared-initialize-param initargs - cache) + cache call-site) "Checks the validity of `initargs' for the generic functions in `gf-list' when called with `args' by calculating the applicable methods for each gf. The applicable methods for SHARED-INITIALIZE based on `instance', @@ -2790,8 +2790,9 @@ ((null tail)) (unless (memq initarg allowable-initargs) (error 'program-error - :format-control "Invalid initarg ~S." - :format-arguments (list initarg)))))))) + :format-control "Invalid initarg ~S in call to ~S ~ +with arglist ~S." + :format-arguments (list initarg call-site args)))))))) (defun merge-initargs-sets (list1 list2) (cond @@ -2837,7 +2838,7 @@ (check-initargs (list #'allocate-instance #'initialize-instance) (list* instance initargs) instance t initargs - *make-instance-initargs-cache*) + *make-instance-initargs-cache* 'make-instance) (apply #'initialize-instance instance initargs) instance)) @@ -2860,7 +2861,7 @@ (defmethod reinitialize-instance ((instance standard-object) &rest initargs) (check-initargs (list #'reinitialize-instance) (list* instance initargs) instance () initargs - *reinitialize-instance-initargs-cache*) + *reinitialize-instance-initargs-cache* 'reinitialize-instance) (apply #'shared-initialize instance () initargs)) (defun std-shared-initialize (instance slot-names all-keys) @@ -2874,7 +2875,7 @@ ((null tail)) (unless (symbolp initarg) (error 'program-error - :format-control "Invalid initarg ~S." + :format-control "Initarg ~S not a symbol." :format-arguments (list initarg)))) (dolist (slot (class-slots (class-of instance))) (let ((slot-name (slot-definition-name slot))) @@ -2952,7 +2953,7 @@ (check-initargs (list #'update-instance-for-different-class) (list old new initargs) new added-slots initargs - nil) + nil 'update-instance-for-different-class) (apply #'shared-initialize new added-slots initargs))) ;;; make-instances-obsolete @@ -2985,7 +2986,7 @@ (list* instance added-slots discarded-slots property-list initargs) instance added-slots initargs - nil) + nil 'update-instance-for-redefined-class) (apply #'shared-initialize instance added-slots initargs)) ;;; Methods having to do with class metaobjects. @@ -3002,7 +3003,7 @@ #'initialize-instance) (list* class all-keys) class t all-keys - nil) + nil 'reinitialize-instance) (apply #'std-after-initialization-for-classes class all-keys)) ;;; Finalize inheritance From rschlatte at common-lisp.net Wed Jan 11 21:07:07 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 11 Jan 2012 13:07:07 -0800 Subject: [armedbear-cvs] r13762 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jan 11 13:07:07 2012 New Revision: 13762 Log: Fix short-method-combination object creation ... fixes a number of failing ANSI tests. 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 Wed Jan 11 08:28:53 2012 (r13761) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 11 13:07:07 2012 (r13762) @@ -837,16 +837,6 @@ ;;; The class method-combination and its subclasses are defined in ;;; StandardClass.java, but we cannot use make-instance and slot-value ;;; yet. -(defun make-short-method-combination (&key name documentation operator identity-with-one-argument) - (let ((instance (std-allocate-instance (find-class 'short-method-combination)))) - (when name (setf (std-slot-value instance 'sys::name) name)) - (when documentation - (setf (std-slot-value instance 'documentation) documentation)) - (when operator (setf (std-slot-value instance 'operator) operator)) - (when identity-with-one-argument - (setf (std-slot-value instance 'identity-with-one-argument) - identity-with-one-argument)) - instance)) (defun make-long-method-combination (&key name documentation lambda-list method-group-specs args-lambda-list @@ -933,13 +923,16 @@ (operator (getf (cddr whole) :operator name))) `(progn - (setf (get ',name 'method-combination-object) - (make-short-method-combination - :name ',name - :operator ',operator - :identity-with-one-argument ',identity-with-one-arg - :documentation ',documentation)) - ',name))) + ;; Class short-method-combination is defined in StandardClass.java. + (let ((instance (std-allocate-instance + (find-class 'short-method-combination)))) + (setf (std-slot-value instance 'sys::name) ',name) + (setf (std-slot-value instance 'documentation) ',documentation) + (setf (std-slot-value instance 'operator) ',operator) + (setf (std-slot-value instance 'identity-with-one-argument) + ',identity-with-one-arg) + (setf (get ',name 'method-combination-object) instance) + ',name)))) (defmacro define-method-combination (&whole form name &rest args) (if (and (cddr form) From rschlatte at common-lisp.net Wed Jan 11 21:07:10 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 11 Jan 2012 13:07:10 -0800 Subject: [armedbear-cvs] r13763 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jan 11 13:07:09 2012 New Revision: 13763 Log: fix (defpackage :foo (:import-from "COMMON-LISP" "NIL")) We used the primary value of find-symbol to check for the existence of the symbol, which works in all cases except NIL. Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/package.lisp Wed Jan 11 13:07:07 2012 (r13762) +++ trunk/abcl/src/org/armedbear/lisp/package.lisp Wed Jan 11 13:07:09 2012 (r13763) @@ -57,7 +57,7 @@ (mapcar #'(lambda (sym) (restart-case (progn - (unless (find-symbol sym package) + (unless (nth-value 1 (find-symbol sym package)) (error 'package-error "The symbol ~A is not present in package ~A." sym (package-name package))) sym) From astalla at common-lisp.net Wed Jan 11 21:17:24 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Wed, 11 Jan 2012 13:17:24 -0800 Subject: [armedbear-cvs] r13764 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Wed Jan 11 13:17:23 2012 New Revision: 13764 Log: More value types for primitive annotation elements. Syntax sugar for annotations in runtime-class. Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Jan 11 13:07:09 2012 (r13763) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Wed Jan 11 13:17:23 2012 (r13764) @@ -1364,11 +1364,31 @@ (char-code #\Z) (primitive-or-string-annotation-element-value self) (pool-add-int (class-file-constants class) (if value 1 0)))) + (character + (setf (annotation-element-tag self) + (char-code #\C) + (primitive-or-string-annotation-element-value self) + (pool-add-int (class-file-constants class) (char-code value)))) (fixnum (setf (annotation-element-tag self) (char-code #\I) (primitive-or-string-annotation-element-value self) (pool-add-int (class-file-constants class) value))) + (integer + (setf (annotation-element-tag self) + (char-code #\J) + (primitive-or-string-annotation-element-value self) + (pool-add-long (class-file-constants class) value))) + (double-float + (setf (annotation-element-tag self) + (char-code #\D) + (primitive-or-string-annotation-element-value self) + (pool-add-double (class-file-constants class) value))) + (single-float + (setf (annotation-element-tag self) + (char-code #\F) + (primitive-or-string-annotation-element-value self) + (pool-add-float (class-file-constants class) value))) (string (setf (annotation-element-tag self) (char-code #\s) Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Wed Jan 11 13:07:09 2012 (r13763) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Wed Jan 11 13:17:23 2012 (r13764) @@ -132,7 +132,28 @@ jclass))) (defun parse-annotation (annotation) - annotation) ;;TODO + (when (annotation-p annotation) + (return-from parse-annotation annotation)) + (destructuring-bind (class &rest elements) (if (listp annotation) annotation (list annotation)) + (let (actual-elements) + (dolist (elem elements) + (push (parse-annotation-element elem) actual-elements)) + (make-annotation :type class :elements (nreverse actual-elements))))) + +(defun parse-annotation-element (elem) + (cond + ((annotation-element-p elem) elem) + ((atom elem) (make-primitive-or-string-annotation-element :name nil :value elem)) + ((keywordp (car elem)) (parse-annotation-element `("value" , at elem))) + (t + (destructuring-bind (name &key value enum annotation) elem + (cond + (enum (make-enum-value-annotation-element :name name :type enum :value value)) + (annotation + (make-annotation-value-annotation-element :name name :value (parse-annotation annotation))) + ((listp value) + (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value))) + (t (make-primitive-or-string-annotation-element :name name :value value))))))) #+example (java:jnew-runtime-class @@ -141,15 +162,15 @@ :methods (list (list "foo" :void '("java.lang.Object") (lambda (this that) (print (list this that))) - :annotations (list (make-annotation :type "java.lang.Deprecated") - (make-annotation :type "java.lang.annotation.Retention" - :elements (list (make-enum-value-annotation-element - :type "java.lang.annotation.RetentionPolicy" - :value "RUNTIME"))) - (make-annotation :type "javax.xml.bind.annotation.XmlAttribute" - :elements (list (make-primitive-or-string-annotation-element - :name "required" - :value t))))) + :annotations (list "java.lang.Deprecated" + '("java.lang.annotation.Retention" + (:enum "java.lang.annotation.RetentionPolicy" :value "RUNTIME")) + '("javax.xml.bind.annotation.XmlAttribute" ("required" :value t)) + '("com.manydesigns.portofino.system.model.users.annotations.RequiresPermissions" + ("level" + :enum "com.manydesigns.portofino.model.pages.AccessLevel" + :value "EDIT") + ("permissions" :value ("foo" "bar"))))) (list "bar" :int '("java.lang.Object") (lambda (this that) (print (list this that)) 23)))) From rschlatte at common-lisp.net Wed Jan 11 21:36:10 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 11 Jan 2012 13:36:10 -0800 Subject: [armedbear-cvs] r13765 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jan 11 13:36:09 2012 New Revision: 13765 Log: Make #\Nul an alias for #\Null As reported on #lisp, and following the example of sbcl. Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Modified: trunk/abcl/src/org/armedbear/lisp/LispCharacter.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Wed Jan 11 13:17:23 2012 (r13764) +++ trunk/abcl/src/org/armedbear/lisp/LispCharacter.java Wed Jan 11 13:36:09 2012 (r13765) @@ -563,6 +563,8 @@ if (lower.equals("null")) return 0; + if (lower.equals("nul")) + return 0; if (lower.equals("bell")) return 7; if (lower.equals("backspace")) From rschlatte at common-lisp.net Wed Jan 11 22:04:11 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 11 Jan 2012 14:04:11 -0800 Subject: [armedbear-cvs] r13766 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jan 11 14:04:11 2012 New Revision: 13766 Log: export a bunch of required symbols from package "MOP". Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Wed Jan 11 13:36:09 2012 (r13765) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Wed Jan 11 14:04:11 2012 (r13766) @@ -33,7 +33,9 @@ (and (eql (class-name class) 'funcallable-standard-class) (eql (class-name superclass) 'standard-class))))) -(export '(funcallable-standard-class +(export '(funcallable-standard-object + funcallable-standard-class + forward-referenced-class validate-superclass direct-slot-definition-class effective-slot-definition-class @@ -44,7 +46,9 @@ finalize-inheritance slot-boundp-using-class slot-makunbound-using-class - + + ensure-class + class-default-initargs class-direct-default-initargs class-direct-slots @@ -55,8 +59,13 @@ generic-function-lambda-list + standard-method method-function - + standard-accessor-method + standard-reader-method + standard-writer-method + + slot-definition slot-definition-readers slot-definition-writers From mevenson at common-lisp.net Thu Jan 12 13:00:14 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 12 Jan 2012 05:00:14 -0800 Subject: [armedbear-cvs] r13767 - public_html Message-ID: Author: mevenson Date: Thu Jan 12 05:00:13 2012 New Revision: 13767 Log: Correct source URL locations. Modified: public_html/index.shtml Modified: public_html/index.shtml ============================================================================== --- public_html/index.shtml Wed Jan 11 14:04:11 2012 (r13766) +++ public_html/index.shtml Thu Jan 12 05:00:13 2012 (r13767) @@ -77,8 +77,8 @@ Source - abcl-src-1.0.1.tar.gz - (pgp) + abcl-src-1.0.1.tar.gz + (pgp) abcl-src-1.0.1.zip From rschlatte at common-lisp.net Thu Jan 12 19:14:17 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 12 Jan 2012 11:14:17 -0800 Subject: [armedbear-cvs] r13768 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Jan 12 11:13:53 2012 New Revision: 13768 Log: Allow zero-length symbols (written as ||). Fixes #193 (reported by Anton Vodonosov). 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 Thu Jan 12 05:00:13 2012 (r13767) +++ trunk/abcl/src/org/armedbear/lisp/Stream.java Thu Jan 12 11:13:53 2012 (r13768) @@ -1136,8 +1136,10 @@ packageName + '.', this)); } + } else { // token.length == 0 + Package pkg = (Package)Symbol._PACKAGE_.symbolValue(thread); + return pkg.intern(""); } - return error(new ReaderError("Can't intern zero-length symbol.", this)); } private final BitSet _readToken(StringBuilder sb, Readtable rt) From rschlatte at common-lisp.net Thu Jan 12 19:22:56 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Thu, 12 Jan 2012 11:22:56 -0800 Subject: [armedbear-cvs] r13769 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Thu Jan 12 11:22:42 2012 New Revision: 13769 Log: Remove spurious built-in class definition for method-combination Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Modified: trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Thu Jan 12 11:13:53 2012 (r13768) +++ trunk/abcl/src/org/armedbear/lisp/BuiltInClass.java Thu Jan 12 11:22:42 2012 (r13769) @@ -109,7 +109,6 @@ public static final BuiltInClass LIST = addClass(Symbol.LIST); public static final BuiltInClass LOGICAL_PATHNAME = addClass(Symbol.LOGICAL_PATHNAME); public static final BuiltInClass MAILBOX = addClass(Symbol.MAILBOX); - public static final BuiltInClass METHOD_COMBINATION = addClass(Symbol.METHOD_COMBINATION); public static final BuiltInClass MUTEX = addClass(Symbol.MUTEX); public static final BuiltInClass NIL_VECTOR = addClass(Symbol.NIL_VECTOR); public static final BuiltInClass NULL = addClass(Symbol.NULL); @@ -262,8 +261,6 @@ LOGICAL_PATHNAME.setCPL(LOGICAL_PATHNAME, PATHNAME, CLASS_T); MAILBOX.setDirectSuperclass(CLASS_T); MAILBOX.setCPL(MAILBOX, CLASS_T); - METHOD_COMBINATION.setDirectSuperclass(CLASS_T); - METHOD_COMBINATION.setCPL(METHOD_COMBINATION, CLASS_T); MUTEX.setDirectSuperclass(CLASS_T); MUTEX.setCPL(MUTEX, CLASS_T); NIL_VECTOR.setDirectSuperclass(STRING); From mevenson at common-lisp.net Thu Jan 12 19:36:28 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 12 Jan 2012 11:36:28 -0800 Subject: [armedbear-cvs] r13770 - trunk/abcl/contrib/abcl-asdf/tests Message-ID: Author: mevenson Date: Thu Jan 12 11:36:27 2012 New Revision: 13770 Log: Simple runtime maven test. CL-USER> (abcl-asdf:resolve-dependencies "log4j" "log4j") WARNING: Using LATEST for unspecified version. "/home/evenson/.m2/repository/log4j/log4j/1.2.16/log4j-1.2.16.jar:/home/evenson/.m2/repository/javax/mail/mail/1.4.1/mail-1.4.1.jar:/home/evenson/.m2/repository/javax/activation/activation/1.1/activation-1.1.jar:/home/evenson/.m2/repository/org/apache/geronimo/specs/geronimo-jms_1.1_spec/1.0/geronimo-jms_1.1_spec-1.0.jar" CL-USER> Notice the automatic dependency resolution for the javax.mail SPI and the (hopefully false) inclusion of the Geronimo JMS documentation in the returned JVM classpath fragrament. Added: trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Added: trunk/abcl/contrib/abcl-asdf/tests/maven.lisp ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Thu Jan 12 11:36:27 2012 (r13770) @@ -0,0 +1,5 @@ +#| +(abcl-asdf:resolve-dependencies "log4j" "log4j") +|# + +; TODO figure out what sort of test framework we can hook in. Probably ABCL-RT \ No newline at end of file From mevenson at common-lisp.net Thu Jan 12 19:38:51 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 12 Jan 2012 11:38:51 -0800 Subject: [armedbear-cvs] r13771 - trunk/abcl/contrib/abcl-asdf/tests Message-ID: Author: mevenson Date: Thu Jan 12 11:38:50 2012 New Revision: 13771 Log: The Bear eats its tail. Use Maven to locate, retrieve, and cache the latest binary of the implementation's jar archive. Modified: trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Modified: trunk/abcl/contrib/abcl-asdf/tests/maven.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Thu Jan 12 11:36:27 2012 (r13770) +++ trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Thu Jan 12 11:38:50 2012 (r13771) @@ -1,5 +1,8 @@ #| (abcl-asdf:resolve-dependencies "log4j" "log4j") + +(abcl-asdf:resolve-dependencies "org.armedbear.lisp" "abcl") + |# ; TODO figure out what sort of test framework we can hook in. Probably ABCL-RT \ No newline at end of file From mevenson at common-lisp.net Thu Jan 12 20:18:20 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Thu, 12 Jan 2012 12:18:20 -0800 Subject: [armedbear-cvs] r13772 - branches/1.0.x/abcl/src/org/armedbear/lisp Message-ID: Author: mevenson Date: Thu Jan 12 12:18:19 2012 New Revision: 13772 Log: backport r13768 to fix #193 for the abcl-1.0.2 release. Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java Modified: branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java ============================================================================== --- branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java Thu Jan 12 11:38:50 2012 (r13771) +++ branches/1.0.x/abcl/src/org/armedbear/lisp/Stream.java Thu Jan 12 12:18:19 2012 (r13772) @@ -1136,8 +1136,10 @@ packageName + '.', this)); } + } else { // token.length == 0 + Package pkg = (Package)Symbol._PACKAGE_.symbolValue(thread); + return pkg.intern(""); } - return error(new ReaderError("Can't intern zero-length symbol.", this)); } private final BitSet _readToken(StringBuilder sb, Readtable rt) From rschlatte at common-lisp.net Sat Jan 14 16:37:33 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 14 Jan 2012 08:37:33 -0800 Subject: [armedbear-cvs] r13773 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 14 08:37:32 2012 New Revision: 13773 Log: introduce funcallable-standard-object. Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Thu Jan 12 12:18:19 2012 (r13772) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 08:37:32 2012 (r13773) @@ -421,9 +421,13 @@ // BuiltInClass.FUNCTION is also null here (see previous comment). + public static final StandardClass FUNCALLABLE_STANDARD_OBJECT = + addStandardClass(Symbol.FUNCALLABLE_STANDARD_OBJECT, + list(STANDARD_OBJECT, BuiltInClass.FUNCTION)); + public static final StandardClass GENERIC_FUNCTION = - addStandardClass(Symbol.GENERIC_FUNCTION, list(METAOBJECT, - BuiltInClass.FUNCTION)); + addStandardClass(Symbol.GENERIC_FUNCTION, + list(METAOBJECT, FUNCALLABLE_STANDARD_OBJECT)); public static final StandardClass METHOD_COMBINATION = addStandardClass(Symbol.METHOD_COMBINATION, list(METAOBJECT)); @@ -581,8 +585,9 @@ // STANDARD_OBJECT). STANDARD_CLASS.setDirectSuperclass(CLASS); STANDARD_OBJECT.setDirectSuperclass(BuiltInClass.CLASS_T); + FUNCALLABLE_STANDARD_OBJECT.setDirectSuperclasses(list(STANDARD_OBJECT, BuiltInClass.FUNCTION)); GENERIC_FUNCTION.setDirectSuperclasses(list(METAOBJECT, - BuiltInClass.FUNCTION)); + FUNCALLABLE_STANDARD_OBJECT)); ARITHMETIC_ERROR.setCPL(ARITHMETIC_ERROR, ERROR, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -646,7 +651,9 @@ STANDARD_OBJECT, BuiltInClass.CLASS_T); FORWARD_REFERENCED_CLASS.setCPL(FORWARD_REFERENCED_CLASS, CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); - GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, METAOBJECT, STANDARD_OBJECT, + FUNCALLABLE_STANDARD_OBJECT.setCPL(FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); + GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, METAOBJECT, + FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); JAVA_EXCEPTION.setCPL(JAVA_EXCEPTION, ERROR, SERIOUS_CONDITION, CONDITION, @@ -765,7 +772,9 @@ // Condition classes. STANDARD_CLASS.finalizeClass(); STANDARD_OBJECT.finalizeClass(); + FUNCALLABLE_STANDARD_OBJECT.finalizeClass(); CLASS.finalizeClass(); + GENERIC_FUNCTION.finalizeClass(); ARITHMETIC_ERROR.finalizeClass(); CELL_ERROR.finalizeClass(); COMPILER_ERROR.finalizeClass(); @@ -855,6 +864,7 @@ Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized()); STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION, GENERIC_FUNCTION, METAOBJECT, + FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Thu Jan 12 12:18:19 2012 (r13772) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Jan 14 08:37:32 2012 (r13773) @@ -2971,6 +2971,8 @@ PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER"); public static final Symbol EQL_SPECIALIZER_OBJECT = PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER-OBJECT"); + public static final Symbol FUNCALLABLE_STANDARD_OBJECT = + PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-OBJECT"); public static final Symbol SHORT_METHOD_COMBINATION = PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); public static final Symbol LONG_METHOD_COMBINATION = @@ -3016,6 +3018,7 @@ PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-DECLARATIONS"); public static final Symbol LONG_METHOD_COMBINATION_FORMS = PACKAGE_MOP.addInternalSymbol("LONG-METHOD-COMBINATION-FORMS"); + // slot names of (long-|short-)method-combination classes public static final Symbol OPERATOR = PACKAGE_MOP.addInternalSymbol("OPERATOR"); public static final Symbol IDENTITY_WITH_ONE_ARGUMENT = From rschlatte at common-lisp.net Sat Jan 14 16:52:48 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 14 Jan 2012 08:52:48 -0800 Subject: [armedbear-cvs] r13774 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 14 08:52:48 2012 New Revision: 13774 Log: introduce funcallable-standard-class ... not yet usable as metaclass since various machinery is missing ... also make #'documentation work for all class objects, not just standard-class Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 08:37:32 2012 (r13773) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 08:52:48 2012 (r13774) @@ -450,6 +450,16 @@ public static final StandardClass STRUCTURE_CLASS = addStandardClass(Symbol.STRUCTURE_CLASS, list(CLASS)); + public static final StandardClass FUNCALLABLE_STANDARD_CLASS = + addStandardClass(Symbol.FUNCALLABLE_STANDARD_CLASS, list(CLASS)); + static + { + // funcallable-standard-class has more or less the same interface as + // standard-class. + FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass); + FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); + } + public static final StandardClass CONDITION = addStandardClass(Symbol.CONDITION, list(STANDARD_OBJECT)); @@ -571,6 +581,8 @@ addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD); } + // ### TODO move functionality upwards into funcallable-stanard-object + // and use addStandardClass() here public static final StandardClass STANDARD_GENERIC_FUNCTION = new StandardGenericFunctionClass(); static Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Jan 14 08:37:32 2012 (r13773) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sat Jan 14 08:52:48 2012 (r13774) @@ -2973,6 +2973,8 @@ PACKAGE_MOP.addExternalSymbol("EQL-SPECIALIZER-OBJECT"); public static final Symbol FUNCALLABLE_STANDARD_OBJECT = PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-OBJECT"); + public static final Symbol FUNCALLABLE_STANDARD_CLASS = + PACKAGE_CL.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS"); public static final Symbol SHORT_METHOD_COMBINATION = PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); public static final Symbol LONG_METHOD_COMBINATION = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 08:37:32 2012 (r13773) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 08:52:48 2012 (r13774) @@ -2472,18 +2472,18 @@ ,@(mapcar (if (consp name) #'(lambda (class-name) `(:method (new-value (class ,class-name)) - (,%name new-value class))) - #'(lambda (class-name) - `(:method ((class ,class-name)) - (,%name class)))) - '(built-in-class - forward-referenced-class - structure-class)) - (:method (,@(when (consp name) (list 'new-value)) - (class standard-class)) - ,(if (consp name) - `(setf (slot-value class ',slot) new-value) - `(slot-value class ',slot)))))) + (,%name new-value class))) + #'(lambda (class-name) + `(:method ((class ,class-name)) + (,%name class)))) + '(built-in-class forward-referenced-class structure-class)) + ,@(mapcar #'(lambda (class-name) + `(:method (,@(when (consp name) (list 'new-value)) + (class ,class-name)) + ,(if (consp name) + `(setf (slot-value class ',slot) new-value) + `(slot-value class ',slot)))) + '(standard-class funcallable-standard-class))))) (redefine-class-forwarder class-name name) @@ -2565,16 +2565,16 @@ (push (cons doc-type new-value) alist))))) new-value) -(defmethod documentation ((x standard-class) (doc-type (eql 't))) +(defmethod documentation ((x class) (doc-type (eql 't))) (class-documentation x)) -(defmethod documentation ((x standard-class) (doc-type (eql 'type))) +(defmethod documentation ((x class) (doc-type (eql 'type))) (class-documentation x)) -(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't))) +(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't))) (%set-class-documentation x new-value)) -(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type))) +(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type))) (%set-class-documentation x new-value)) (defmethod documentation ((x structure-class) (doc-type (eql 't))) @@ -3003,6 +3003,8 @@ (atomic-defgeneric finalize-inheritance (class) (:method ((class standard-class)) + (std-finalize-inheritance class)) + (:method ((class funcallable-standard-class)) (std-finalize-inheritance class))) ;;; Class precedence lists @@ -3016,6 +3018,8 @@ (defgeneric compute-slots (class)) (defmethod compute-slots ((class standard-class)) (std-compute-slots class)) +(defmethod compute-slots ((class funcallable-standard-class)) + (std-compute-slots class)) (defgeneric compute-effective-slot-definition (class name direct-slots)) (defmethod compute-effective-slot-definition Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jan 14 08:37:32 2012 (r13773) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jan 14 08:52:48 2012 (r13774) @@ -2,11 +2,6 @@ (in-package #:mop) -(defclass funcallable-standard-class (class)) - -(defmethod class-name ((class funcallable-standard-class)) - 'funcallable-standard-class) - ;;; StandardGenericFunction.java defines FUNCALLABLE-INSTANCE-FUNCTION and ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION. ;;; From rschlatte at common-lisp.net Sat Jan 14 20:07:01 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 14 Jan 2012 12:07:01 -0800 Subject: [armedbear-cvs] r13775 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 14 12:07:00 2012 New Revision: 13775 Log: Support for funcallable instances. ... Move execute, set-funcallable-instance-function upwards from StandardGenericFunction to new class FuncallableStandardObject. ... Add various MOPpy methods for funcallable-standard-class, which isn't a subclass of standard-class, unfortunately. Added: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Jan 14 08:52:48 2012 (r13774) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sat Jan 14 12:07:00 2012 (r13775) @@ -534,11 +534,11 @@ autoload(PACKAGE_JAVA, "%add-to-classpath", "JavaClassLoader"); autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader"); autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true); - autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false); + autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false); autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true); - autoload(PACKAGE_MOP, "set-funcallable-instance-function", "StandardGenericFunction", true); + autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true); autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true); autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true); autoload(PACKAGE_SYS, "%%string=", "StringFunctions"); @@ -693,6 +693,7 @@ autoload(PACKAGE_SYS, "simple-list-remove-duplicates", "simple_list_remove_duplicates"); autoload(PACKAGE_SYS, "single-float-bits", "FloatFunctions", true); autoload(PACKAGE_SYS, "%std-allocate-instance", "StandardObjectFunctions", true); + autoload(PACKAGE_SYS, "%allocate-funcallable-instance", "FuncallableStandardObject", true); autoload(PACKAGE_SYS, "unzip", "unzip", true); autoload(PACKAGE_SYS, "zip", "zip", true); Added: trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/FuncallableStandardObject.java Sat Jan 14 12:07:00 2012 (r13775) @@ -0,0 +1,287 @@ +/* + * FuncallableStandardObject.java + * + * Copyright (C) 2003-2006 Peter Graves, 2012 Rudolf Schlatte + * $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. + */ + + +// TODO: swap-slots is currently handled by StandardObject, so doesn't +// exchange the functions. +package org.armedbear.lisp; + +import static org.armedbear.lisp.Lisp.*; + +public class FuncallableStandardObject extends StandardObject +{ + protected LispObject function; + protected int numberOfRequiredArgs; + + protected FuncallableStandardObject() + { + super(); + } + + + protected FuncallableStandardObject(Layout layout) + { + this(layout, layout.getLength()); + } + + protected FuncallableStandardObject(Layout layout, int length) + { + super(layout, length); + } + + + protected FuncallableStandardObject(LispClass cls, int length) + { + super(cls, length); + } + + protected FuncallableStandardObject(LispClass cls) + { + super(cls); + } + + @Override + public LispObject typep(LispObject type) + { + if (type == Symbol.COMPILED_FUNCTION) + { + if (function != null) + return function.typep(type); + else + return NIL; + } + if (type == Symbol.FUNCALLABLE_STANDARD_OBJECT) + return T; + if (type == StandardClass.FUNCALLABLE_STANDARD_OBJECT) + return T; + return super.typep(type); + } + + @Override + public LispObject execute() + { + return function.execute(); + } + + @Override + public LispObject execute(LispObject arg) + { + return function.execute(arg); + } + + @Override + public LispObject execute(LispObject first, LispObject second) + + { + return function.execute(first, second); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + + { + return function.execute(first, second, third); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth) + + { + return function.execute(first, second, third, fourth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth) + + { + return function.execute(first, second, third, fourth, + fifth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth) + + { + return function.execute(first, second, third, fourth, + fifth, sixth); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh) + + { + return function.execute(first, second, third, fourth, + fifth, sixth, seventh); + } + + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third, LispObject fourth, + LispObject fifth, LispObject sixth, + LispObject seventh, LispObject eighth) + + { + return function.execute(first, second, third, fourth, + fifth, sixth, seventh, eighth); + } + + @Override + public LispObject execute(LispObject[] args) + { + return function.execute(args); + } + + private static final Primitive _ALLOCATE_FUNCALLABLE_INSTANCE + = new pf__allocate_funcallable_instance(); + @DocString(name="%allocate-funcallable-instance", + args="class", + returns="instance") + private static final class pf__allocate_funcallable_instance extends Primitive + { + pf__allocate_funcallable_instance() + { + super("%allocate-funcallable-instance", PACKAGE_SYS, true, "class"); + } + @Override + public LispObject execute(LispObject arg) + { + if (arg.typep(StandardClass.FUNCALLABLE_STANDARD_CLASS) != NIL) { + LispObject l = Symbol.CLASS_LAYOUT.execute(arg); + if (! (l instanceof Layout)) + return error(new ProgramError("Invalid standard class layout for: " + arg.princToString())); + + return new FuncallableStandardObject((Layout)l); + } + return type_error(arg, Symbol.FUNCALLABLE_STANDARD_CLASS); + } + }; + + // AMOP p. 230 + private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION + = new pf_set_funcallable_instance_function(); + @DocString(name="set-funcallable-instance-function", + args="funcallable-instance function", + returns="unspecified") + private static final class pf_set_funcallable_instance_function extends Primitive + { + pf_set_funcallable_instance_function() + { + super("set-funcallable-instance-function", PACKAGE_MOP, true, + "funcallable-instance function"); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + checkFuncallableStandardObject(first).function = second; + return second; + } + }; + + private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION + = new pf_funcallable_instance_function(); + @DocString(name="funcallable-instance-function", + args="funcallable-instance", + returns="function") + private static final class pf_funcallable_instance_function extends Primitive + { + pf_funcallable_instance_function() + { + super("funcallable-instance-function", PACKAGE_MOP, false, + "funcallable-instance"); + } + @Override + public LispObject execute(LispObject arg) + { + return checkFuncallableStandardObject(arg).function; + } + }; + + + // Profiling. + private int callCount; + private int hotCount; + + @Override + public final int getCallCount() + { + return callCount; + } + + @Override + public void setCallCount(int n) + { + callCount = n; + } + + @Override + public final void incrementCallCount() + { + ++callCount; + } + + @Override + public final int getHotCount() + { + return hotCount; + } + + @Override + public void setHotCount(int n) + { + hotCount = n; + } + + @Override + public final void incrementHotCount() + { + ++hotCount; + } + + public static final FuncallableStandardObject checkFuncallableStandardObject(LispObject obj) + { + if (obj instanceof FuncallableStandardObject) + return (FuncallableStandardObject) obj; + return (FuncallableStandardObject) // Not reached. + type_error(obj, Symbol.FUNCALLABLE_STANDARD_OBJECT); + } + +} Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 08:52:48 2012 (r13774) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Sat Jan 14 12:07:00 2012 (r13775) @@ -452,13 +452,6 @@ public static final StandardClass FUNCALLABLE_STANDARD_CLASS = addStandardClass(Symbol.FUNCALLABLE_STANDARD_CLASS, list(CLASS)); - static - { - // funcallable-standard-class has more or less the same interface as - // standard-class. - FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass); - FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); - } public static final StandardClass CONDITION = addStandardClass(Symbol.CONDITION, list(STANDARD_OBJECT)); @@ -581,8 +574,6 @@ addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD); } - // ### TODO move functionality upwards into funcallable-stanard-object - // and use addStandardClass() here public static final StandardClass STANDARD_GENERIC_FUNCTION = new StandardGenericFunctionClass(); static @@ -749,6 +740,13 @@ CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_CLASS.setCPL(STANDARD_CLASS, CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); + FUNCALLABLE_STANDARD_CLASS.setCPL(FUNCALLABLE_STANDARD_CLASS, CLASS, + SPECIALIZER, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + // funcallable-standard-class has the same interface as + // standard-class. + FUNCALLABLE_STANDARD_CLASS.setClassLayout(layoutStandardClass); + FUNCALLABLE_STANDARD_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); STANDARD_OBJECT.setCPL(STANDARD_OBJECT, BuiltInClass.CLASS_T); STORAGE_CONDITION.setCPL(STORAGE_CONDITION, SERIOUS_CONDITION, CONDITION, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -786,6 +784,7 @@ STANDARD_OBJECT.finalizeClass(); FUNCALLABLE_STANDARD_OBJECT.finalizeClass(); CLASS.finalizeClass(); + FUNCALLABLE_STANDARD_CLASS.finalizeClass(); GENERIC_FUNCTION.finalizeClass(); ARITHMETIC_ERROR.finalizeClass(); CELL_ERROR.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Jan 14 08:52:48 2012 (r13774) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Jan 14 12:07:00 2012 (r13775) @@ -37,11 +37,8 @@ import java.util.concurrent.ConcurrentHashMap; -public final class StandardGenericFunction extends StandardObject +public final class StandardGenericFunction extends FuncallableStandardObject { - LispObject function; - - int numberOfRequiredArgs; ConcurrentHashMap cache; ConcurrentHashMap slotCache; @@ -120,89 +117,6 @@ } @Override - public LispObject execute() - { - return function.execute(); - } - - @Override - public LispObject execute(LispObject arg) - { - return function.execute(arg); - } - - @Override - public LispObject execute(LispObject first, LispObject second) - - { - return function.execute(first, second); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third) - - { - return function.execute(first, second, third); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth) - - { - return function.execute(first, second, third, fourth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth) - - { - return function.execute(first, second, third, fourth, - fifth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth) - - { - return function.execute(first, second, third, fourth, - fifth, sixth); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh) - - { - return function.execute(first, second, third, fourth, - fifth, sixth, seventh); - } - - @Override - public LispObject execute(LispObject first, LispObject second, - LispObject third, LispObject fourth, - LispObject fifth, LispObject sixth, - LispObject seventh, LispObject eighth) - - { - return function.execute(first, second, third, fourth, - fifth, sixth, seventh, eighth); - } - - @Override - public LispObject execute(LispObject[] args) - { - return function.execute(args); - } - - @Override public String printObject() { LispObject name = getGenericFunctionName(); @@ -224,46 +138,6 @@ return super.printObject(); } - // Profiling. - private int callCount; - private int hotCount; - - @Override - public final int getCallCount() - { - return callCount; - } - - @Override - public void setCallCount(int n) - { - callCount = n; - } - - @Override - public final void incrementCallCount() - { - ++callCount; - } - - @Override - public final int getHotCount() - { - return hotCount; - } - - @Override - public void setHotCount(int n) - { - hotCount = n; - } - - @Override - public final void incrementHotCount() - { - ++hotCount; - } - // AMOP (p. 216) specifies the following readers as generic functions: // generic-function-argument-precedence-order // generic-function-declarations @@ -337,46 +211,6 @@ return second; } }; - - private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION - = new pf_funcallable_instance_function(); - @DocString(name="funcallable-instance-function", - args="funcallable-instance", - returns="function") - private static final class pf_funcallable_instance_function extends Primitive - { - pf_funcallable_instance_function() - { - super("funcallable-instance-function", PACKAGE_MOP, false, - "funcallable-instance"); - } - @Override - public LispObject execute(LispObject arg) - { - return checkStandardGenericFunction(arg).function; - } - }; - - // AMOP p. 230 - private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION - = new pf_set_funcallable_instance_function(); - @DocString(name="set-funcallable-instance-function", - args="funcallable-instance function", - returns="unspecified") - private static final class pf_set_funcallable_instance_function extends Primitive - { - pf_set_funcallable_instance_function() - { - super("set-funcallable-instance-function", PACKAGE_MOP, true, - "funcallable-instance function"); - } - @Override - public LispObject execute(LispObject first, LispObject second) - { - checkStandardGenericFunction(first).function = second; - return second; - } - }; private static final Primitive GF_REQUIRED_ARGS = new pf_gf_required_args(); Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 08:52:48 2012 (r13774) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 12:07:00 2012 (r13775) @@ -686,6 +686,11 @@ (std-finalize-inheritance class)) (sys::%std-allocate-instance class)) +(defun allocate-funcallable-instance (class) + (unless (class-finalized-p class) + (std-finalize-inheritance class)) + (sys::%allocate-funcallable-instance class)) + (defun make-instance-standard-class (metaclass &rest initargs &key name direct-superclasses direct-slots @@ -2650,7 +2655,9 @@ (defmethod slot-value-using-class ((class standard-class) instance slot-name) (std-slot-value instance slot-name)) - +(defmethod slot-value-using-class ((class funcallable-standard-class) + instance slot-name) + (std-slot-value instance slot-name)) (defmethod slot-value-using-class ((class structure-class) instance slot-name) (std-slot-value instance slot-name)) @@ -2663,6 +2670,12 @@ (setf (std-slot-value instance slot-name) new-value)) (defmethod (setf slot-value-using-class) (new-value + (class funcallable-standard-class) + instance + slot-name) + (setf (std-slot-value instance slot-name) new-value)) + +(defmethod (setf slot-value-using-class) (new-value (class structure-class) instance slot-name) @@ -2675,6 +2688,8 @@ (defmethod slot-exists-p-using-class ((class standard-class) instance slot-name) (std-slot-exists-p instance slot-name)) +(defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name) + (std-slot-exists-p instance slot-name)) (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name) (dolist (dsd (class-slots class)) @@ -2685,6 +2700,8 @@ (defgeneric slot-boundp-using-class (class instance slot-name)) (defmethod slot-boundp-using-class ((class standard-class) instance slot-name) (std-slot-boundp instance slot-name)) +(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance slot-name) + (std-slot-boundp instance slot-name)) (defmethod slot-boundp-using-class ((class structure-class) instance slot-name) "Structure slots can't be unbound, so this method always returns T." (declare (ignore class instance slot-name)) @@ -2695,6 +2712,10 @@ instance slot-name) (std-slot-makunbound instance slot-name)) +(defmethod slot-makunbound-using-class ((class funcallable-standard-class) + instance + slot-name) + (std-slot-makunbound instance slot-name)) (defmethod slot-makunbound-using-class ((class structure-class) instance slot-name) @@ -2720,6 +2741,10 @@ (declare (ignore initargs)) (std-allocate-instance class)) +(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) + (declare (ignore initargs)) + (allocate-funcallable-instance class)) + (defmethod allocate-instance ((class structure-class) &rest initargs) (declare (ignore initargs)) (%make-structure (class-name class) @@ -2811,7 +2836,7 @@ (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) -(defmethod make-instance ((class standard-class) &rest initargs) +(defmethod make-instance ((class class) &rest initargs) (when (oddp (length initargs)) (error 'program-error :format-control "Odd number of keyword arguments.")) (unless (class-finalized-p class) @@ -2827,7 +2852,7 @@ (setf default-initargs (append default-initargs (list key (funcall fn)))))) (setf initargs (append initargs default-initargs))))) - (let ((instance (std-allocate-instance class))) + (let ((instance (allocate-instance class))) (check-initargs (list #'allocate-instance #'initialize-instance) (list* instance initargs) instance t initargs @@ -2955,7 +2980,8 @@ (defmethod make-instances-obsolete ((class standard-class)) (%make-instances-obsolete class)) - +(defmethod make-instances-obsolete ((class funcallable-standard-class)) + (%make-instances-obsolete class)) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class)) class) @@ -2987,6 +3013,10 @@ (defmethod initialize-instance :after ((class standard-class) &rest args) (apply #'std-after-initialization-for-classes class args)) +(defmethod initialize-instance :after ((class funcallable-standard-class) + &rest args) + (apply #'std-after-initialization-for-classes class args)) + (defmethod reinitialize-instance :after ((class standard-class) &rest all-keys) (remhash class *make-instance-initargs-cache*) (remhash class *reinitialize-instance-initargs-cache*) @@ -3012,6 +3042,8 @@ (defgeneric compute-class-precedence-list (class)) (defmethod compute-class-precedence-list ((class standard-class)) (std-compute-class-precedence-list class)) +(defmethod compute-class-precedence-list ((class funcallable-standard-class)) + (std-compute-class-precedence-list class)) ;;; Slot inheritance @@ -3025,7 +3057,9 @@ (defmethod compute-effective-slot-definition ((class standard-class) name direct-slots) (std-compute-effective-slot-definition class name direct-slots)) - +(defmethod compute-effective-slot-definition + ((class funcallable-standard-class) name direct-slots) + (std-compute-effective-slot-definition class name direct-slots)) ;;; Methods having to do with generic function metaobjects. (defmethod initialize-instance :after ((gf standard-generic-function) &key) @@ -3313,6 +3347,9 @@ (defmethod class-prototype ((class standard-class)) (allocate-instance class)) +(defmethod class-prototype ((class funcallable-standard-class)) + (allocate-instance class)) + (defmethod class-prototype ((class structure-class)) (allocate-instance class)) From ehuelsmann at common-lisp.net Sun Jan 15 07:24:35 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sat, 14 Jan 2012 23:24:35 -0800 Subject: [armedbear-cvs] r13776 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sat Jan 14 23:24:34 2012 New Revision: 13776 Log: Remove ineffective LET binding which only returns its bound value immediately. 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 Sat Jan 14 12:07:00 2012 (r13775) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 14 23:24:34 2012 (r13776) @@ -1840,116 +1840,113 @@ location)) (defun std-compute-discriminating-function (gf) - (let ((code - (cond - ((and (= (length (generic-function-methods gf)) 1) - (typep (car (generic-function-methods gf)) 'standard-reader-method)) - ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) + (cond + ((and (= (length (generic-function-methods gf)) 1) + (typep (car (generic-function-methods gf)) 'standard-reader-method)) + ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) - (let* ((method (%car (generic-function-methods gf))) - (class (car (%method-specializers method))) - (slot-name (reader-method-slot-name method))) - #'(lambda (arg) - (declare (optimize speed)) - (let* ((layout (std-instance-layout arg)) - (location (get-cached-slot-location gf layout))) - (unless location - (unless (simple-typep arg class) - ;; FIXME no applicable method - (error 'simple-type-error - :datum arg - :expected-type class)) - (setf location (slow-reader-lookup gf layout slot-name))) - (if (consp location) - ;; Shared slot. - (cdr location) - (standard-instance-access arg location)))))) - - (t - (let* ((emf-table (classes-to-emf-table gf)) - (number-required (length (gf-required-args gf))) - (lambda-list (%generic-function-lambda-list gf)) - (exact (null (intersection lambda-list - '(&rest &optional &key - &allow-other-keys &aux))))) - (if exact - (cond - ((= number-required 1) - (cond - ((and (eq (generic-function-method-combination gf) 'standard) - (= (length (generic-function-methods gf)) 1)) - (let* ((method (%car (generic-function-methods gf))) - (specializer (car (%method-specializers method))) - (function (or (%method-fast-function method) - (%method-function method)))) - (if (typep specializer 'eql-specializer) - (let ((specializer-object (eql-specializer-object specializer))) - #'(lambda (arg) - (declare (optimize speed)) - (if (eql arg specializer-object) - (funcall function arg) - (no-applicable-method gf (list arg))))) - #'(lambda (arg) - (declare (optimize speed)) - (unless (simple-typep arg specializer) - ;; FIXME no applicable method - (error 'simple-type-error - :datum arg - :expected-type specializer)) - (funcall function arg))))) - (t - #'(lambda (arg) - (declare (optimize speed)) - (let* ((specialization - (%get-arg-specialization gf arg)) - (emfun (or (gethash1 specialization - emf-table) - (slow-method-lookup-1 - gf arg specialization)))) - (if emfun - (funcall emfun (list arg)) - (apply #'no-applicable-method gf (list arg)))))))) - ((= number-required 2) - #'(lambda (arg1 arg2) - (declare (optimize speed)) - (let* ((args (list arg1 arg2)) - (emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args))))) - ((= number-required 3) - #'(lambda (arg1 arg2 arg3) - (declare (optimize speed)) - (let* ((args (list arg1 arg2 arg3)) - (emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args))))) - (t - #'(lambda (&rest args) - (declare (optimize speed)) - (let ((len (length args))) - (unless (= len number-required) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf))))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args)))))) - #'(lambda (&rest args) - (declare (optimize speed)) - (let ((len (length args))) - (unless (>= len number-required) - (error 'program-error - :format-control "Not enough arguments for generic function ~S." - :format-arguments (list (%generic-function-name gf))))) - (let ((emfun (get-cached-emf gf args))) - (if emfun - (funcall emfun args) - (slow-method-lookup gf args)))))))))) + (let* ((method (%car (generic-function-methods gf))) + (class (car (%method-specializers method))) + (slot-name (reader-method-slot-name method))) + #'(lambda (arg) + (declare (optimize speed)) + (let* ((layout (std-instance-layout arg)) + (location (get-cached-slot-location gf layout))) + (unless location + (unless (simple-typep arg class) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type class)) + (setf location (slow-reader-lookup gf layout slot-name))) + (if (consp location) + ;; Shared slot. + (cdr location) + (standard-instance-access arg location)))))) - code)) + (t + (let* ((emf-table (classes-to-emf-table gf)) + (number-required (length (gf-required-args gf))) + (lambda-list (%generic-function-lambda-list gf)) + (exact (null (intersection lambda-list + '(&rest &optional &key + &allow-other-keys &aux))))) + (if exact + (cond + ((= number-required 1) + (cond + ((and (eq (generic-function-method-combination gf) 'standard) + (= (length (generic-function-methods gf)) 1)) + (let* ((method (%car (generic-function-methods gf))) + (specializer (car (%method-specializers method))) + (function (or (%method-fast-function method) + (%method-function method)))) + (if (typep specializer 'eql-specializer) + (let ((specializer-object (eql-specializer-object specializer))) + #'(lambda (arg) + (declare (optimize speed)) + (if (eql arg specializer-object) + (funcall function arg) + (no-applicable-method gf (list arg))))) + #'(lambda (arg) + (declare (optimize speed)) + (unless (simple-typep arg specializer) + ;; FIXME no applicable method + (error 'simple-type-error + :datum arg + :expected-type specializer)) + (funcall function arg))))) + (t + #'(lambda (arg) + (declare (optimize speed)) + (let* ((specialization + (%get-arg-specialization gf arg)) + (emfun (or (gethash1 specialization + emf-table) + (slow-method-lookup-1 + gf arg specialization)))) + (if emfun + (funcall emfun (list arg)) + (apply #'no-applicable-method gf (list arg)))))))) + ((= number-required 2) + #'(lambda (arg1 arg2) + (declare (optimize speed)) + (let* ((args (list arg1 arg2)) + (emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args))))) + ((= number-required 3) + #'(lambda (arg1 arg2 arg3) + (declare (optimize speed)) + (let* ((args (list arg1 arg2 arg3)) + (emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args))))) + (t + #'(lambda (&rest args) + (declare (optimize speed)) + (let ((len (length args))) + (unless (= len number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf))))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args)))))) + #'(lambda (&rest args) + (declare (optimize speed)) + (let ((len (length args))) + (unless (>= len number-required) + (error 'program-error + :format-control "Not enough arguments for generic function ~S." + :format-arguments (list (%generic-function-name gf))))) + (let ((emfun (get-cached-emf gf args))) + (if emfun + (funcall emfun args) + (slow-method-lookup gf args))))))))) (defun sort-methods (methods gf required-classes) (if (or (null methods) (null (%cdr methods))) From ehuelsmann at common-lisp.net Sun Jan 15 13:06:27 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 15 Jan 2012 05:06:27 -0800 Subject: [armedbear-cvs] r13777 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 15 05:06:26 2012 New Revision: 13777 Log: Record optional parameters in generic function objects for quick retrieval. Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sat Jan 14 23:24:34 2012 (r13776) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jan 15 05:06:26 2012 (r13777) @@ -66,6 +66,8 @@ lambdaList; slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] = lambdaList; + slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = + NIL; numberOfRequiredArgs = lambdaList.length(); slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = NIL; @@ -246,6 +248,40 @@ return second; } }; + + private static final Primitive GF_OPTIONAL_ARGS + = new pf_gf_optional_args(); + @DocString(name="gf-optional-args") + private static final class pf_gf_optional_args extends Primitive + { + pf_gf_optional_args() + { + super("gf-optional-args", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject arg) + { + return checkStandardGenericFunction(arg).slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS]; + } + }; + + private static final Primitive _SET_GF_OPTIONAL_ARGS + = new pf__set_gf_optional_args(); + @DocString(name="%set-gf-optional-args") + private static final class pf__set_gf_optional_args extends Primitive + { + pf__set_gf_optional_args() + { + super("%set-gf-optional-args", PACKAGE_SYS, true); + } + @Override + public LispObject execute(LispObject first, LispObject second) + { + final StandardGenericFunction gf = checkStandardGenericFunction(first); + gf.slots[StandardGenericFunctionClass.SLOT_INDEX_OPTIONAL_ARGS] = second; + return second; + } + }; private static final Primitive GENERIC_FUNCTION_INITIAL_METHODS = new pf_generic_function_initial_methods(); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Sat Jan 14 23:24:34 2012 (r13776) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java Sun Jan 15 05:06:26 2012 (r13777) @@ -40,13 +40,14 @@ public static final int SLOT_INDEX_NAME = 0; public static final int SLOT_INDEX_LAMBDA_LIST = 1; public static final int SLOT_INDEX_REQUIRED_ARGS = 2; - public static final int SLOT_INDEX_INITIAL_METHODS = 3; - public static final int SLOT_INDEX_METHODS = 4; - public static final int SLOT_INDEX_METHOD_CLASS = 5; - public static final int SLOT_INDEX_METHOD_COMBINATION = 6; - public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 7; - public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 8; - public static final int SLOT_INDEX_DOCUMENTATION = 9; + public static final int SLOT_INDEX_OPTIONAL_ARGS = 3; + public static final int SLOT_INDEX_INITIAL_METHODS = 4; + public static final int SLOT_INDEX_METHODS = 5; + public static final int SLOT_INDEX_METHOD_CLASS = 6; + public static final int SLOT_INDEX_METHOD_COMBINATION = 7; + public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 8; + public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE = 9; + public static final int SLOT_INDEX_DOCUMENTATION = 10; public StandardGenericFunctionClass() { @@ -58,6 +59,7 @@ pkg.intern("NAME"), pkg.intern("LAMBDA-LIST"), pkg.intern("REQUIRED-ARGS"), + pkg.intern("OPTIONAL-ARGS"), pkg.intern("INITIAL-METHODS"), pkg.intern("METHODS"), pkg.intern("METHOD-CLASS"), From rschlatte at common-lisp.net Sun Jan 15 14:04:59 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 15 Jan 2012 06:04:59 -0800 Subject: [armedbear-cvs] r13778 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jan 15 06:04:57 2012 New Revision: 13778 Log: Define make-instance for standard-class and funcallable-standard-class ... Don't define a method for class (which would cover built-in-class etc. as well) ... refactor out some common parts 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 Sun Jan 15 05:06:26 2012 (r13777) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 06:04:57 2012 (r13778) @@ -2833,23 +2833,35 @@ (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) -(defmethod make-instance ((class class) &rest initargs) +(defmethod make-instance :before ((class class) &rest initargs) (when (oddp (length initargs)) (error 'program-error :format-control "Odd number of keyword arguments.")) (unless (class-finalized-p class) - (std-finalize-inheritance class)) - (let ((class-default-initargs (class-default-initargs class))) - (when class-default-initargs - (let ((default-initargs '())) - (do* ((list class-default-initargs (cddr list)) - (key (car list) (car list)) - (fn (cadr list) (cadr list))) - ((null list)) - (when (eq (getf initargs key 'not-found) 'not-found) - (setf default-initargs (append default-initargs (list key (funcall fn)))))) - (setf initargs (append initargs default-initargs))))) + (finalize-inheritance class))) - (let ((instance (allocate-instance class))) +(defun augment-initargs-with-defaults (class initargs) + (let ((default-initargs '())) + (do* ((list (class-default-initargs class) (cddr list)) + (key (car list) (car list)) + (fn (cadr list) (cadr list))) + ((null list)) + (when (eq (getf initargs key 'not-found) 'not-found) + (setf default-initargs (append default-initargs (list key (funcall fn)))))) + (append initargs default-initargs))) + +(defmethod make-instance ((class standard-class) &rest initargs) + (setf initargs (augment-initargs-with-defaults class initargs)) + (let ((instance (std-allocate-instance class))) + (check-initargs (list #'allocate-instance #'initialize-instance) + (list* instance initargs) + instance t initargs + *make-instance-initargs-cache* 'make-instance) + (apply #'initialize-instance instance initargs) + instance)) + +(defmethod make-instance ((class funcallable-standard-class) &rest initargs) + (setf initargs (augment-initargs-with-defaults class initargs)) + (let ((instance (allocate-funcallable-instance class))) (check-initargs (list #'allocate-instance #'initialize-instance) (list* instance initargs) instance t initargs From rschlatte at common-lisp.net Sun Jan 15 19:45:22 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 15 Jan 2012 11:45:22 -0800 Subject: [armedbear-cvs] r13779 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jan 15 11:45:21 2012 New Revision: 13779 Log: slightly less dodgy long-form-method-combination initialization. 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 Sun Jan 15 06:04:57 2012 (r13778) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 11:45:21 2012 (r13779) @@ -843,31 +843,22 @@ ;;; StandardClass.java, but we cannot use make-instance and slot-value ;;; yet. -(defun make-long-method-combination (&key name documentation lambda-list +(defun %make-long-method-combination (&key name documentation lambda-list method-group-specs args-lambda-list generic-function-symbol function arguments declarations forms) (let ((instance (std-allocate-instance (find-class 'long-method-combination)))) - (when name (setf (std-slot-value instance 'sys::name) name)) - (when documentation - (setf (std-slot-value instance 'documentation) documentation)) - (when lambda-list - (setf (std-slot-value instance 'sys::lambda-list) lambda-list)) - (when method-group-specs - (setf (std-slot-value instance 'method-group-specs) method-group-specs)) - (when args-lambda-list - (setf (std-slot-value instance 'args-lambda-list) args-lambda-list)) - (when generic-function-symbol - (setf (std-slot-value instance 'generic-function-symbol) - generic-function-symbol)) - (when function - (setf (std-slot-value instance 'function) function)) - (when arguments - (setf (std-slot-value instance 'arguments) arguments)) - (when declarations - (setf (std-slot-value instance 'declarations) declarations)) - (when forms - (setf (std-slot-value instance 'forms) forms)) + (setf (std-slot-value instance 'sys::name) name) + (setf (std-slot-value instance 'documentation) documentation) + (setf (std-slot-value instance 'sys::lambda-list) lambda-list) + (setf (std-slot-value instance 'method-group-specs) method-group-specs) + (setf (std-slot-value instance 'args-lambda-list) args-lambda-list) + (setf (std-slot-value instance 'generic-function-symbol) + generic-function-symbol) + (setf (std-slot-value instance 'function) function) + (setf (std-slot-value instance 'arguments) arguments) + (setf (std-slot-value instance 'declarations) declarations) + (setf (std-slot-value instance 'forms) forms) instance)) (defun method-combination-name (method-combination) @@ -960,7 +951,7 @@ ;;; (defun define-method-combination-type (name &rest initargs) (setf (get name 'method-combination-object) - (apply 'make-long-method-combination initargs))) + (apply '%make-long-method-combination initargs))) (defun method-group-p (selecter qualifiers) ;; selecter::= qualifier-pattern | predicate From rschlatte at common-lisp.net Sun Jan 15 19:45:24 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 15 Jan 2012 11:45:24 -0800 Subject: [armedbear-cvs] r13780 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jan 15 11:45:23 2012 New Revision: 13780 Log: Don't export funcallable-standard-class from CL. ... fixes a newly-introduced ansi-test failure. Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Jan 15 11:45:21 2012 (r13779) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Sun Jan 15 11:45:23 2012 (r13780) @@ -2974,7 +2974,7 @@ public static final Symbol FUNCALLABLE_STANDARD_OBJECT = PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-OBJECT"); public static final Symbol FUNCALLABLE_STANDARD_CLASS = - PACKAGE_CL.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS"); + PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS"); public static final Symbol SHORT_METHOD_COMBINATION = PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); public static final Symbol LONG_METHOD_COMBINATION = From ehuelsmann at common-lisp.net Sun Jan 15 19:51:36 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 15 Jan 2012 11:51:36 -0800 Subject: [armedbear-cvs] r13781 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 15 11:51:35 2012 New Revision: 13781 Log: Support for the FUNCTION-KEYWORDS protocol, required to implement keyword argument verification for effective methods. Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 15 11:45:23 2012 (r13780) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 15 11:51:35 2012 (r13781) @@ -577,6 +577,7 @@ autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-method-fast-function", "StandardMethod", true); autoload(PACKAGE_SYS, "%set-method-function", "StandardMethod", true); + autoload(PACKAGE_SYS, "%set-function-keywords", "StandardMethod", true); autoload(PACKAGE_SYS, "%set-method-generic-function", "StandardMethod", true); autoload(PACKAGE_SYS, "%set-method-specializers", "StandardMethod", true); autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives"); @@ -637,6 +638,7 @@ autoload(PACKAGE_SYS, "float-nan-p", "FloatFunctions", true); autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true); autoload(PACKAGE_SYS, "function-info", "function_info"); + autoload(PACKAGE_SYS, "%function-keywords", "StandardMethod", true); autoload(PACKAGE_SYS, "generic-function-argument-precedence-order","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true); @@ -648,6 +650,7 @@ autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-function-info-value", "function_info"); autoload(PACKAGE_SYS, "gf-required-args", "StandardGenericFunction", true); + autoload(PACKAGE_SYS, "gf-optional-args", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); autoload(PACKAGE_SYS, "hash-table-entries", "HashTableFunctions"); autoload(PACKAGE_SYS, "layout-class", "Layout", true); Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Jan 15 11:45:23 2012 (r13780) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethod.java Sun Jan 15 11:51:35 2012 (r13781) @@ -56,6 +56,8 @@ this(); slots[StandardMethodClass.SLOT_INDEX_GENERIC_FUNCTION] = gf; slots[StandardMethodClass.SLOT_INDEX_LAMBDA_LIST] = lambdaList; + slots[StandardMethodClass.SLOT_INDEX_KEYWORDS] = NIL; + slots[StandardMethodClass.SLOT_INDEX_OTHER_KEYWORDS_P] = NIL; slots[StandardMethodClass.SLOT_INDEX_SPECIALIZERS] = specializers; slots[StandardMethodClass.SLOT_INDEX_QUALIFIERS] = NIL; slots[StandardMethodClass.SLOT_INDEX_FUNCTION] = NIL; @@ -63,8 +65,8 @@ slots[StandardMethodClass.SLOT_INDEX_DOCUMENTATION] = NIL; } - private static final Primitive METHOD_LAMBDA_LIST - = new pf_method_lambda_list(); + private static final Primitive METHOD_LAMBDA_LIST + = new pf_method_lambda_list(); @DocString(name="method-lambda-list", args="generic-method") private static final class pf_method_lambda_list extends Primitive @@ -98,6 +100,50 @@ return second; } }; + + private static final Primitive _FUNCTION_KEYWORDS + = new pf__function_keywords(); + @DocString(name="%function-keywords", + args="standard-method") + private static final class pf__function_keywords extends Primitive + { + pf__function_keywords() + { + super("%function-keywords", PACKAGE_SYS, true, "method"); + } + @Override + public LispObject execute(LispObject arg) + { + StandardMethod method = checkStandardMethod(arg); + LispThread thread = LispThread.currentThread(); + + return thread + .setValues(method.slots[StandardMethodClass.SLOT_INDEX_KEYWORDS], + method.slots[StandardMethodClass.SLOT_INDEX_OTHER_KEYWORDS_P]); + } + }; + + private static final Primitive _SET_FUNCTION_KEYWORDS + = new pf__set_function_keywords(); + @DocString(name="%set-function-keywords", + args="standard-method keywords other-keywords-p") + private static final class pf__set_function_keywords extends Primitive + { + pf__set_function_keywords() + { + super("%set-function-keywords", PACKAGE_SYS, true, + "method keywords"); + } + @Override + public LispObject execute(LispObject first, LispObject second, + LispObject third) + { + StandardMethod method = checkStandardMethod(first); + method.slots[StandardMethodClass.SLOT_INDEX_KEYWORDS] = second; + method.slots[StandardMethodClass.SLOT_INDEX_OTHER_KEYWORDS_P] = third; + return second; + } + }; private static final Primitive _METHOD_QUALIFIERS Modified: trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java Sun Jan 15 11:45:23 2012 (r13780) +++ trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java Sun Jan 15 11:51:35 2012 (r13781) @@ -37,13 +37,17 @@ public final class StandardMethodClass extends StandardClass { + // When changing this list, don't forget to edit + // StandardReaderMethodClass as well public static final int SLOT_INDEX_GENERIC_FUNCTION = 0; public static final int SLOT_INDEX_LAMBDA_LIST = 1; - public static final int SLOT_INDEX_SPECIALIZERS = 2; - public static final int SLOT_INDEX_QUALIFIERS = 3; - public static final int SLOT_INDEX_FUNCTION = 4; - public static final int SLOT_INDEX_FAST_FUNCTION = 5; - public static final int SLOT_INDEX_DOCUMENTATION = 6; + public static final int SLOT_INDEX_KEYWORDS = 2; + public static final int SLOT_INDEX_OTHER_KEYWORDS_P = 3; + public static final int SLOT_INDEX_SPECIALIZERS = 4; + public static final int SLOT_INDEX_QUALIFIERS = 5; + public static final int SLOT_INDEX_FUNCTION = 6; + public static final int SLOT_INDEX_FAST_FUNCTION = 7; + public static final int SLOT_INDEX_DOCUMENTATION = 8; public StandardMethodClass() { @@ -53,6 +57,8 @@ { Symbol.GENERIC_FUNCTION, pkg.intern("LAMBDA-LIST"), + pkg.intern("KEYWORDS"), + pkg.intern("OTHER_KEYWORDS_P"), pkg.intern("SPECIALIZERS"), pkg.intern("QUALIFIERS"), Symbol.FUNCTION, Modified: trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java Sun Jan 15 11:45:23 2012 (r13780) +++ trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java Sun Jan 15 11:51:35 2012 (r13781) @@ -40,14 +40,17 @@ // From StandardMethodClass.java: public static final int SLOT_INDEX_GENERIC_FUNCTION = 0; public static final int SLOT_INDEX_LAMBDA_LIST = 1; - public static final int SLOT_INDEX_SPECIALIZERS = 2; - public static final int SLOT_INDEX_QUALIFIERS = 3; - public static final int SLOT_INDEX_FUNCTION = 4; - public static final int SLOT_INDEX_FAST_FUNCTION = 5; - public static final int SLOT_INDEX_DOCUMENTATION = 6; + public static final int SLOT_INDEX_KEYWORDS = 2; + public static final int SLOT_INDEX_OTHER_KEYWORDS_P = 3; + public static final int SLOT_INDEX_SPECIALIZERS = 4; + public static final int SLOT_INDEX_QUALIFIERS = 5; + public static final int SLOT_INDEX_FUNCTION = 6; + public static final int SLOT_INDEX_FAST_FUNCTION = 7; + public static final int SLOT_INDEX_DOCUMENTATION = 8; + // Added: - public static final int SLOT_INDEX_SLOT_NAME = 7; + public static final int SLOT_INDEX_SLOT_NAME = 9; public StandardReaderMethodClass() { @@ -58,6 +61,8 @@ { Symbol.GENERIC_FUNCTION, pkg.intern("LAMBDA-LIST"), + pkg.intern("KEYWORDS"), + pkg.intern("OTHER_KEYWORDS_P"), pkg.intern("SPECIALIZERS"), pkg.intern("QUALIFIERS"), Symbol.FUNCTION, Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 11:45:23 2012 (r13780) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 11:51:35 2012 (r13781) @@ -128,6 +128,10 @@ (defun ,name (&rest args) (apply #',%name args))))) +;; +;; DEFINE PLACE HOLDER FUNCTIONS +;; + (define-class->%class-forwarder class-name) (define-class->%class-forwarder (setf class-name)) (define-class->%class-forwarder class-slots) @@ -156,6 +160,9 @@ generic-function args)) +(defun function-keywords (method) + (%function-keywords method)) + (defmacro push-on-end (value location) @@ -1419,6 +1426,7 @@ (let* ((plist (analyze-lambda-list lambda-list)) (required-args (getf plist ':required-args))) (%set-gf-required-args gf required-args) + (%set-gf-optional-args gf (getf plist :optional-args)) (when apo-p (setf (generic-function-argument-precedence-order gf) (if argument-precedence-order @@ -1757,7 +1765,9 @@ function fast-function) (declare (ignore gf)) - (let ((method (std-allocate-instance +the-standard-method-class+))) + (let ((method (std-allocate-instance +the-standard-method-class+)) + (analyzed-args (analyze-lambda-list lambda-list)) + ) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) (%set-method-specializers method (canonicalize-specializers specializers)) @@ -1765,6 +1775,9 @@ (%set-method-generic-function method nil) (%set-method-function method function) (%set-method-fast-function method fast-function) + (%set-function-keywords method + (getf analyzed-args :keywords) + (getf analyzed-args :allow-other-keys)) method)) (defun %add-method (gf method) @@ -1927,6 +1940,8 @@ (if emfun (funcall emfun args) (slow-method-lookup gf args)))))) +;; (let ((non-key-args (+ number-required +;; (length (gf-optional-args gf)))))) #'(lambda (&rest args) (declare (optimize speed)) (let ((len (length args))) @@ -3328,8 +3343,9 @@ ;; FIXME (defgeneric no-next-method (generic-function method &rest args)) -;; FIXME -(defgeneric function-keywords (method)) +(atomic-defgeneric function-keywords (method) + (:method ((method standard-method)) + (%function-keywords method))) (setf *gf-initialize-instance* (symbol-function 'initialize-instance)) From rschlatte at common-lisp.net Sun Jan 15 21:55:47 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 15 Jan 2012 13:55:47 -0800 Subject: [armedbear-cvs] r13782 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jan 15 13:55:45 2012 New Revision: 13782 Log: Implement readers for generic-function objects as generic functions (AMOP pg. 216) ... rename predefined low-level accessors (e.g. generic-function-name -> sys:%generic-function-name) Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 15 11:51:35 2012 (r13781) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Sun Jan 15 13:55:45 2012 (r13782) @@ -535,7 +535,6 @@ autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader"); autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true); autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false); - autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true); autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true); @@ -639,13 +638,13 @@ autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true); autoload(PACKAGE_SYS, "function-info", "function_info"); autoload(PACKAGE_SYS, "%function-keywords", "StandardMethod", true); - autoload(PACKAGE_SYS, "generic-function-argument-precedence-order","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%generic-function-argument-precedence-order","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-initial-methods","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "generic-function-method-class","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "generic-function-method-combination","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "generic-function-methods","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%generic-function-method-class","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%generic-function-method-combination","StandardGenericFunction", true); + autoload(PACKAGE_SYS, "%generic-function-methods","StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-cached-emf", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-cached-slot-location", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "get-function-info-value", "function_info"); Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jan 15 11:51:35 2012 (r13781) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Sun Jan 15 13:55:45 2012 (r13782) @@ -318,12 +318,12 @@ private static final Primitive GENERIC_FUNCTION_METHODS = new pf_generic_function_methods(); - @DocString(name="generic-function-methods") + @DocString(name="%generic-function-methods") private static final class pf_generic_function_methods extends Primitive { pf_generic_function_methods() { - super("generic-function-methods", PACKAGE_SYS, true); + super("%generic-function-methods", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) @@ -351,12 +351,12 @@ private static final Primitive GENERIC_FUNCTION_METHOD_CLASS = new pf_generic_function_method_class(); - @DocString(name="generic-function-method-class") + @DocString(name="%generic-function-method-class") private static final class pf_generic_function_method_class extends Primitive { pf_generic_function_method_class() { - super("generic-function-method-class", PACKAGE_SYS, true); + super("%generic-function-method-class", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) @@ -384,12 +384,12 @@ private static final Primitive GENERIC_FUNCTION_METHOD_COMBINATION = new pf_generic_function_method_combination(); - @DocString(name="generic-function-method-combination") + @DocString(name="%generic-function-method-combination") private static final class pf_generic_function_method_combination extends Primitive { pf_generic_function_method_combination() { - super("generic-function-method-combination", PACKAGE_SYS, true); + super("%generic-function-method-combination", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) @@ -418,12 +418,12 @@ private static final Primitive GENERIC_FUNCTION_ARGUMENT_PRECEDENCE_ORDER = new pf_generic_function_argument_precedence_order(); - @DocString(name="generic-function-argument-precedence-order") + @DocString(name="%generic-function-argument-precedence-order") private static final class pf_generic_function_argument_precedence_order extends Primitive { pf_generic_function_argument_precedence_order() { - super("generic-function-argument-precedence-order", PACKAGE_SYS, true); + super("%generic-function-argument-precedence-order", PACKAGE_SYS, true); } @Override public LispObject execute(LispObject arg) Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 11:51:35 2012 (r13781) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 15 13:55:45 2012 (r13782) @@ -1268,6 +1268,9 @@ ;; generic-function-methods ;; generic-function-name +;;; These are defined with % in package SYS, defined as functions here +;;; and redefined as generic functions once we're all set up. + (defun generic-function-lambda-list (gf) (%generic-function-lambda-list gf)) (defsetf generic-function-lambda-list %set-generic-function-lambda-list) @@ -1278,15 +1281,23 @@ (defun (setf generic-function-initial-methods) (new-value gf) (set-generic-function-initial-methods gf new-value)) +(defun generic-function-methods (gf) + (sys:%generic-function-methods gf)) (defun (setf generic-function-methods) (new-value gf) (set-generic-function-methods gf new-value)) +(defun generic-function-method-class (gf) + (sys:%generic-function-method-class gf)) (defun (setf generic-function-method-class) (new-value gf) (set-generic-function-method-class gf new-value)) +(defun generic-function-method-combination (gf) + (sys:%generic-function-method-combination gf)) (defun (setf generic-function-method-combination) (new-value gf) (set-generic-function-method-combination gf new-value)) +(defun generic-function-argument-precedence-order (gf) + (sys:%generic-function-argument-precedence-order gf)) (defun (setf generic-function-argument-precedence-order) (new-value gf) (set-generic-function-argument-precedence-order gf new-value)) @@ -1844,12 +1855,13 @@ location)) (defun std-compute-discriminating-function (gf) + ;; In this function, we know that gf is of class + ;; standard-generic-function, so we call various + ;; sys:%generic-function-foo readers to break circularities. (cond - ((and (= (length (generic-function-methods gf)) 1) - (typep (car (generic-function-methods gf)) 'standard-reader-method)) - ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) - - (let* ((method (%car (generic-function-methods gf))) + ((and (= (length (sys:%generic-function-methods gf)) 1) + (typep (car (sys:%generic-function-methods gf)) 'standard-reader-method)) + (let* ((method (%car (sys:%generic-function-methods gf))) (class (car (%method-specializers method))) (slot-name (reader-method-slot-name method))) #'(lambda (arg) @@ -1879,9 +1891,9 @@ (cond ((= number-required 1) (cond - ((and (eq (generic-function-method-combination gf) 'standard) - (= (length (generic-function-methods gf)) 1)) - (let* ((method (%car (generic-function-methods gf))) + ((and (eq (sys:%generic-function-method-combination gf) 'standard) + (= (length (sys:%generic-function-methods gf)) 1)) + (let* ((method (%car (sys:%generic-function-methods gf))) (specializer (car (%method-specializers method))) (function (or (%method-fast-function method) (%method-function method)))) @@ -3369,6 +3381,37 @@ (defmethod class-prototype ((class structure-class)) (allocate-instance class)) +;;; Readers for generic function metaobjects +;;; See AMOP pg. 216ff. +(atomic-defgeneric generic-function-argument-precedence-order (generic-function) + (:method ((generic-function standard-generic-function)) + (sys:%generic-function-argument-precedence-order generic-function))) + +(atomic-defgeneric generic-function-declarations (generic-function) + (:method ((generic-function standard-generic-function)) + ;; TODO: add slot to StandardGenericFunctionClass.java, use it + nil)) + +(atomic-defgeneric generic-function-lambda-list (generic-function) + (:method ((generic-function standard-generic-function)) + (sys:%generic-function-lambda-list generic-function))) + +(atomic-defgeneric generic-function-method-class (generic-function) + (:method ((generic-function standard-generic-function)) + (sys:%generic-function-method-class generic-function))) + +(atomic-defgeneric generic-function-method-combination (generic-function) + (:method ((generic-function standard-generic-function)) + (sys:%generic-function-method-combination generic-function))) + +(atomic-defgeneric generic-function-methods (generic-function) + (:method ((generic-function standard-generic-function)) + (sys:%generic-function-methods generic-function))) + +(atomic-defgeneric generic-function-name (generic-function) + (:method ((generic-function standard-generic-function)) + (sys:%generic-function-name generic-function))) + (eval-when (:compile-toplevel :load-toplevel :execute) (require "MOP")) From rschlatte at common-lisp.net Mon Jan 16 12:36:35 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Mon, 16 Jan 2012 04:36:35 -0800 Subject: [armedbear-cvs] r13783 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Mon Jan 16 04:36:33 2012 New Revision: 13783 Log: Robustify funcallable-instances with respect to unspecified behavior. 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 Sun Jan 15 13:55:45 2012 (r13782) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jan 16 04:36:33 2012 (r13783) @@ -696,7 +696,13 @@ (defun allocate-funcallable-instance (class) (unless (class-finalized-p class) (std-finalize-inheritance class)) - (sys::%allocate-funcallable-instance class)) + (let ((instance (sys::%allocate-funcallable-instance class))) + (set-funcallable-instance-function + instance + #'(lambda (&rest args) + (declare (ignore args)) + (error 'program-error "Called a funcallable-instance with unset function."))) + instance)) (defun make-instance-standard-class (metaclass &rest initargs From ehuelsmann at common-lisp.net Mon Jan 16 22:08:42 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 16 Jan 2012 14:08:42 -0800 Subject: [armedbear-cvs] r13784 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 16 14:08:40 2012 New Revision: 13784 Log: Update function signatures of functions involved in object creation and (re)initialization to match the CLHS. 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 Mon Jan 16 04:36:33 2012 (r13783) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Mon Jan 16 14:08:40 2012 (r13784) @@ -2896,12 +2896,14 @@ (defmethod make-instance ((class symbol) &rest initargs) (apply #'make-instance (find-class class) initargs)) -(defgeneric initialize-instance (instance &key)) +(defgeneric initialize-instance (instance &rest initargs + &key &allow-other-keys)) (defmethod initialize-instance ((instance standard-object) &rest initargs) (apply #'shared-initialize instance t initargs)) -(defgeneric reinitialize-instance (instance &key)) +(defgeneric reinitialize-instance (instance &rest initargs + &key &allow-other-keys)) ;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the ;; validity of initargs and signals an error if an initarg is supplied that is @@ -2942,7 +2944,9 @@ (funcall initfunction))))))))) instance) -(defgeneric shared-initialize (instance slot-names &key)) +(defgeneric shared-initialize (instance slot-names + &rest initargs + &key &allow-other-keys)) (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) (std-shared-initialize instance slot-names initargs)) @@ -2963,7 +2967,7 @@ ;;; change-class -(defgeneric change-class (instance new-class &key)) +(defgeneric change-class (instance new-class &key &allow-other-keys)) (defmethod change-class ((old-instance standard-object) (new-class standard-class) &rest initargs) @@ -2992,7 +2996,9 @@ (defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs) (apply #'change-class instance (find-class new-class) initargs)) -(defgeneric update-instance-for-different-class (old new &key)) +(defgeneric update-instance-for-different-class (old new + &rest initargs + &key &allow-other-keys)) (defmethod update-instance-for-different-class ((old standard-object) (new standard-object) &rest initargs) From astalla at common-lisp.net Mon Jan 16 23:38:53 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Mon, 16 Jan 2012 15:38:53 -0800 Subject: [armedbear-cvs] r13785 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Mon Jan 16 15:38:52 2012 New Revision: 13785 Log: Refactoring in runtime-class. Added annotations on class. Added fields (with annotations as well). Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Mon Jan 16 14:08:40 2012 (r13784) +++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Mon Jan 16 15:38:52 2012 (r13785) @@ -278,6 +278,8 @@ (autoload 'jmember-protected-p "java") (export 'jnew-runtime-class "JAVA") (autoload 'jnew-runtime-class "runtime-class") +(export 'define-java-class "JAVA") +(autoload-macro 'define-java-class "runtime-class") (export 'ensure-java-class "JAVA") (autoload 'ensure-java-class "java") (export 'chain "JAVA") @@ -285,7 +287,7 @@ (export 'jmethod-let "JAVA") (autoload-macro 'jmethod-let "java") (export 'jequal "JAVA") -(autoload-macro 'jequal "java") +(autoload 'jequal "java") ;; Profiler. (in-package "PROFILER") Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 16 14:08:40 2012 (r13784) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Mon Jan 16 15:38:52 2012 (r13785) @@ -9,14 +9,14 @@ (defconstant +abcl-java-object+ (make-jvm-class-name "org.armedbear.lisp.JavaObject")) (defun java:jnew-runtime-class - (class-name &key (superclass (make-jvm-class-name "java.lang.Object")) - interfaces constructors methods fields (access-flags '(:public))) + (class-name &rest args &key (superclass "java.lang.Object") + interfaces constructors methods fields (access-flags '(:public)) annotations) "Creates and loads a Java class with methods calling Lisp closures as given in METHODS. CLASS-NAME and SUPER-NAME are strings, INTERFACES is a list of strings, CONSTRUCTORS, METHODS and FIELDS are lists of constructor, method and field definitions. - Constructor definitions are lists of the form + Constructor definitions - currently NOT supported - are lists of the form (argument-types function &optional super-invocation-arguments) where argument-types is a list of strings and function is a lisp function of (1+ (length argument-types)) arguments; the instance (`this') is passed in as @@ -34,19 +34,59 @@ primitive types (:void, :int, etc.), and function is a Lisp function of minimum arity (1+ (length argument-types)); the instance (`this') is passed in as the first argument. - Field definitions are lists of the form - (field-name type modifier*) - - If FILE-NAME is given, a .class file will be written; this is useful for debugging only." - (declare (ignorable constructors fields)) - (let* ((jvm-class-name (make-jvm-class-name class-name)) - (class-file (make-class-file jvm-class-name superclass access-flags)) - (stream (sys::%make-byte-array-output-stream)) + Field definitions are lists of the form (field-name type &key modifiers annotations)." + (declare (ignorable superclass interfaces constructors methods fields access-flags annotations)) + (let ((stream (sys::%make-byte-array-output-stream)) ;;TODO provide constructor in MemoryClassLoader - (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" "")) + (memory-class-loader (java:jnew "org.armedbear.lisp.MemoryClassLoader" ""))) + (multiple-value-bind (class-file method-implementation-fields) + (apply #'java::%jnew-runtime-class class-name stream args) + (sys::put-memory-function memory-class-loader + class-name (sys::%get-output-stream-bytes stream)) + (let ((jclass (java:jcall "loadClass" memory-class-loader class-name))) + (dolist (method method-implementation-fields) + (setf (java:jfield jclass (car method)) (cdr method))) + jclass)))) + +(defun java::%jnew-runtime-class + (class-name stream &key (superclass "java.lang.Object") + interfaces constructors methods fields (access-flags '(:public)) annotations) + "Actual implementation of jnew-runtime-class. Writes the class bytes to a stream. Returns two values: the finalized class-file structure and the alist of method implementation fields." + (let* ((jvm-class-name (make-jvm-class-name class-name)) + (class-file (make-class-file jvm-class-name (make-jvm-class-name superclass) access-flags)) method-implementation-fields) (setf (class-file-interfaces class-file) (mapcar #'make-jvm-class-name interfaces)) + (when annotations + (class-add-attribute class-file (make-runtime-visible-annotations-attribute + :list (mapcar #'parse-annotation annotations)))) + (setf method-implementation-fields (java::runtime-class-add-methods class-file methods)) + (dolist (field-spec fields) + (destructuring-bind (name type &key (modifiers '(:public)) annotations) field-spec + (let ((field (make-field name (if (keywordp type) type (make-jvm-class-name type)) + :flags modifiers))) + (when annotations + (field-add-attribute field (make-runtime-visible-annotations-attribute + :list (mapcar #'parse-annotation annotations)))) + (class-add-field class-file field)))) + (if (null constructors) + (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) + (class-add-method class-file ctor) + (with-code-to-method (class-file ctor) + (aload 0) + (emit-invokespecial-init (class-file-superclass class-file) nil) + (emit 'return))) + (error "constructors not supported")) + (finalize-class-file class-file) + (write-class-file class-file stream) + (finish-output stream) + #+test-record-generated-class-file + (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8)) + (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) + (values class-file method-implementation-fields))) + +(defun java::runtime-class-add-methods (class-file methods) + (let (method-implementation-fields) (dolist (m methods) (destructuring-bind (name return-type argument-types function &key (modifiers '(:public)) annotations) m (let* ((argument-types (mapcar #'make-jvm-class-name argument-types)) @@ -88,7 +128,7 @@ (list +java-object+ :boolean) +lisp-object+))) (astore (+ i (1+ argc))))) ;;Load the Lisp function from its static field - (emit-getstatic jvm-class-name field-name +lisp-object+) + (emit-getstatic (class-file-class class-file) field-name +lisp-object+) (if (<= (1+ argc) call-registers-limit) (progn ;;Load the boxed this @@ -111,25 +151,9 @@ (emit 'areturn)) (t (error "Unsupported return type: ~A" return-type))))))) - (when (null constructors) - (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) - (class-add-method class-file ctor) - (with-code-to-method (class-file ctor) - (aload 0) - (emit-invokespecial-init (class-file-superclass class-file) nil) - (emit 'return)))) - (finalize-class-file class-file) - (write-class-file class-file stream) - (finish-output stream) - #+test-record-generated-class-file - (with-open-file (f (format nil "~A.class" class-name) :direction :output :element-type '(signed-byte 8)) - (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) - (sys::put-memory-function memory-class-loader - class-name (sys::%get-output-stream-bytes stream)) - (let ((jclass (java:jcall "loadClass" memory-class-loader class-name))) - (dolist (method method-implementation-fields) - (setf (java:jfield jclass (car method)) (cdr method))) - jclass))) + method-implementation-fields)) + +(defmacro java:define-java-class () :todo) (defun parse-annotation (annotation) (when (annotation-p annotation) @@ -155,6 +179,13 @@ (make-array-annotation-element :name name :values (mapcar #'parse-annotation-element value))) (t (make-primitive-or-string-annotation-element :name name :value value))))))) +;;TODO: +;; - Fields: test +;; - Properties + optional accessors (CLOS methods) +;; - Function calls with 8+ args +;; - super? +;; - Constructors? + #+example (java:jnew-runtime-class "Foo" From ehuelsmann at common-lisp.net Tue Jan 17 19:38:02 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 17 Jan 2012 11:38:02 -0800 Subject: [armedbear-cvs] r13786 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 17 11:38:01 2012 New Revision: 13786 Log: Initialize the OPTIONAL-ARGUMENTS slot in one more place. 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 Mon Jan 16 15:38:52 2012 (r13785) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 11:38:01 2012 (r13786) @@ -1518,6 +1518,7 @@ (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) (required-args (getf plist ':required-args))) (%set-gf-required-args gf required-args) + (%set-gf-optional-args gf (getf plist :optional-args)) (setf (generic-function-argument-precedence-order gf) (if argument-precedence-order (canonicalize-argument-precedence-order argument-precedence-order From ehuelsmann at common-lisp.net Tue Jan 17 19:39:55 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Tue, 17 Jan 2012 11:39:55 -0800 Subject: [armedbear-cvs] r13787 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Tue Jan 17 11:39:54 2012 New Revision: 13787 Log: Implement keyword argument verification in the method invocation protocol. 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 Tue Jan 17 11:38:01 2012 (r13786) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 11:39:54 2012 (r13787) @@ -2027,13 +2027,72 @@ (unless (subclassp (car classes) specializer) (return (values nil t))))))) +(defun check-applicable-method-keyword-args (gf args + keyword-args + applicable-keywords) + (when (oddp (length keyword-args)) + (error 'program-error + :format-control "Odd number of keyword arguments in call to ~S ~ +with arguments list ~S" + :format-arguments (list gf args))) + (unless (getf keyword-args :allow-other-keys) + (loop for key in keyword-args by #'cddr + unless (or (member key applicable-keywords) + (eq key :allow-other-keys)) + do (error 'program-error + :format-control "Invalid keyword argument ~S in call ~ +to ~S with argument list ~S." + :format-arguments (list key gf args))))) + +(defun compute-applicable-keywords (gf applicable-methods) + (let ((applicable-keywords + (getf (analyze-lambda-list (generic-function-lambda-list gf)) + :keywords))) + (loop for method in applicable-methods + do (multiple-value-bind + (keywords allow-other-keys) + (function-keywords method) + (when allow-other-keys + (setf applicable-keywords :any) + (return)) + (setf applicable-keywords + (union applicable-keywords keywords)))) + applicable-keywords)) + +(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args + applicable-keywords) + #'(lambda (args) + (check-applicable-method-keyword-args + gf args + (nthcdr non-keyword-args args) applicable-keywords) + (funcall emfun args))) + (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) +the-standard-generic-function-class+) - #'std-compute-effective-method-function - #'compute-effective-method-function) - gf applicable-methods))) + (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)) + (non-keyword-args + (+ (length (gf-required-args gf)) + (length (gf-optional-args gf)))) + (gf-lambda-list (generic-function-lambda-list gf)) + (checks-required (and (member '&key gf-lambda-list) + (not (member '&allow-other-keys + gf-lambda-list))) + ) + (applicable-keywords + (when checks-required + ;; Don't do applicable keyword checks when this is + ;; one of the 'exceptional four' or when the gf allows + ;; other keywords. + (compute-applicable-keywords gf applicable-methods)))) + (when (and checks-required + (not (eq applicable-keywords :any))) + (setf emfun + (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args + applicable-keywords))) (cache-emf gf args emfun) (funcall emfun args)) (apply #'no-applicable-method gf args)))) @@ -2407,6 +2466,7 @@ (%set-method-function method function) (%set-method-fast-function method fast-function) (set-reader-method-slot-name method slot-name) + (%set-function-keywords method nil nil) method)) (defun add-reader-method (class function-name slot-name) @@ -2830,8 +2890,7 @@ ((null tail)) (unless (memq initarg allowable-initargs) (error 'program-error - :format-control "Invalid initarg ~S in call to ~S ~ -with arglist ~S." + :format-control "Invalid initarg ~S in call to ~S with arglist ~S." :format-arguments (list initarg call-site args)))))))) (defun merge-initargs-sets (list1 list2) @@ -2949,7 +3008,8 @@ &rest initargs &key &allow-other-keys)) -(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) +(defmethod shared-initialize ((instance standard-object) slot-names + &rest initargs) (std-shared-initialize instance slot-names initargs)) (defmethod shared-initialize ((slot slot-definition) slot-names @@ -3372,7 +3432,6 @@ (:method ((method standard-method)) (%function-keywords method))) - (setf *gf-initialize-instance* (symbol-function 'initialize-instance)) (setf *gf-allocate-instance* (symbol-function 'allocate-instance)) (setf *gf-shared-initialize* (symbol-function 'shared-initialize)) From rschlatte at common-lisp.net Tue Jan 17 20:15:55 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 17 Jan 2012 12:15:55 -0800 Subject: [armedbear-cvs] r13788 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jan 17 12:15:55 2012 New Revision: 13788 Log: move error checking into canonicalize-direct-superclasses 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 Tue Jan 17 11:39:54 2012 (r13787) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 12:15:55 2012 (r13788) @@ -289,12 +289,16 @@ (defun canonicalize-direct-superclasses (direct-superclasses) (let ((classes '())) (dolist (class-specifier direct-superclasses) - (if (classp class-specifier) - (push class-specifier classes) - (let ((class (find-class class-specifier nil))) - (unless class - (setf class (make-forward-referenced-class class-specifier))) - (push class classes)))) + (let ((class (if (classp class-specifier) + class-specifier + (find-class class-specifier nil)))) + (unless class + (setf class (make-forward-referenced-class class-specifier))) + (when (and (typep class 'built-in-class) + (not (member class *extensible-built-in-classes*))) + (error "Attempt to define a subclass of built-in-class ~S." + class-specifier)) + (push class classes))) (nreverse classes))) (defun canonicalize-defclass-options (options) @@ -790,11 +794,6 @@ (error 'program-error :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." :format-arguments (list name))))) - (let ((direct-superclasses (getf all-keys :direct-superclasses))) - (dolist (class direct-superclasses) - (when (and (typep class 'built-in-class) - (not (member class *extensible-built-in-classes*))) - (error "Attempt to define a subclass of a built-in-class: ~S" class)))) (let ((old-class (find-class name nil))) (cond ((and old-class (eq name (class-name old-class))) (cond ((typep old-class 'built-in-class) From rschlatte at common-lisp.net Tue Jan 17 20:15:58 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 17 Jan 2012 12:15:58 -0800 Subject: [armedbear-cvs] r13789 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jan 17 12:15:57 2012 New Revision: 13789 Log: Implement ensure-class-using-class. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 12:15:55 2012 (r13788) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 12:15:57 2012 (r13789) @@ -772,77 +772,6 @@ (make-hash-table :test #'eq) "Cached sets of allowable initargs, keyed on the class they belong to.") -(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys) - ;; Check for duplicate slots. - (remf all-keys :metaclass) - (let ((slots (getf all-keys :direct-slots))) - (dolist (s1 slots) - (let ((name1 (canonical-slot-name s1))) - (dolist (s2 (cdr (memq s1 slots))) - (when (eq name1 (canonical-slot-name s2)) - (error 'program-error "Duplicate slot ~S" name1)))))) - ;; Check for duplicate argument names in :DEFAULT-INITARGS. - (let ((names ())) - (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs)) - (name (car initargs) (car initargs))) - ((null initargs)) - (push name names)) - (do* ((names names (cdr names)) - (name (car names) (car names))) - ((null names)) - (when (memq name (cdr names)) - (error 'program-error - :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." - :format-arguments (list name))))) - (let ((old-class (find-class name nil))) - (cond ((and old-class (eq name (class-name old-class))) - (cond ((typep old-class 'built-in-class) - (error "The symbol ~S names a built-in class." name)) - ((typep old-class 'forward-referenced-class) - (let ((new-class (apply #'make-instance-standard-class - +the-standard-class+ - :name name all-keys))) - (%set-find-class name new-class) - (setf (class-direct-subclasses new-class) - (class-direct-subclasses old-class)) - (dolist (subclass (class-direct-subclasses old-class)) - (setf (class-direct-superclasses subclass) - (substitute new-class old-class - (class-direct-superclasses subclass)))) - (maybe-finalize-class-subtree new-class) - new-class)) - (t - ;; We're redefining the class. - (apply #'reinitialize-instance old-class all-keys) - old-class))) - (t - (let ((class (apply (if metaclass - #'make-instance - #'make-instance-standard-class) - (or metaclass - +the-standard-class+) - :name name all-keys))) - (%set-find-class name class) - class))))) - - -(defun maybe-finalize-class-subtree (class) - (when (every #'class-finalized-p (class-direct-superclasses class)) - (finalize-inheritance class) - (dolist (subclass (class-direct-subclasses class)) - (maybe-finalize-class-subtree subclass)))) - -(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) - (unless (>= (length form) 3) - (error 'program-error "Wrong number of arguments for DEFCLASS.")) - (check-declaration-type name) - `(ensure-class ',name - :direct-superclasses - (canonicalize-direct-superclasses ',direct-superclasses) - :direct-slots - ,(canonicalize-direct-slots direct-slots) - ,@(canonicalize-defclass-options options))) - (defun expand-long-defcombin (name args) (destructuring-bind (lambda-list method-groups &rest body) args `(apply #'define-long-form-method-combination @@ -2595,6 +2524,112 @@ (redefine-class-forwarder class-direct-default-initargs direct-default-initargs) (redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs) +;;; Class definition + +(defun check-duplicate-slots (slots) + (dolist (s1 slots) + (let ((name1 (canonical-slot-name s1))) + (dolist (s2 (cdr (memq s1 slots))) + (when (eq name1 (canonical-slot-name s2)) + (error 'program-error "Duplicate slot ~S" name1)))))) + +(defun check-duplicate-default-initargs (initargs) + (let ((names ())) + (do* ((initargs initargs (cddr initargs)) + (name (car initargs) (car initargs))) + ((null initargs)) + (push name names)) + (do* ((names names (cdr names)) + (name (car names) (car names))) + ((null names)) + (when (memq name (cdr names)) + (error 'program-error + :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." + :format-arguments (list name)))))) + + ;;; AMOP pg. 182 +(defun ensure-class (name &rest all-keys &key &allow-other-keys) + (apply #'ensure-class-using-class (find-class name nil) name all-keys)) + +;;; AMOP pg. 183ff. +(defgeneric ensure-class-using-class (class name &key direct-default-initargs + direct-slots direct-superclasses name + metaclass &allow-other-keys)) + +(defmethod ensure-class-using-class :before (class name &key direct-slots + direct-default-initargs + &allow-other-keys) + (check-duplicate-slots direct-slots) + (check-duplicate-default-initargs direct-default-initargs)) + +(defmethod ensure-class-using-class ((class null) name &rest all-keys + &key (metaclass +the-standard-class+) + direct-superclasses + &allow-other-keys) + (setf all-keys (copy-list all-keys)) ; since we modify it + (remf all-keys :metaclass) + (let ((class (apply (if (eq metaclass +the-standard-class+) + #'make-instance-standard-class + #'make-instance) + metaclass :name name + :direct-superclasses (canonicalize-direct-superclasses + direct-superclasses) + all-keys))) + (%set-find-class name class) + class)) + +(defmethod ensure-class-using-class ((class built-in-class) name &rest all-keys + &key &allow-other-keys) + (declare (ignore all-keys)) + (error "The symbol ~S names a built-in class." name)) + + (defmethod ensure-class-using-class ((class forward-referenced-class) name + &key (metaclass +the-standard-class+) + direct-superclasses + &rest all-keys &key &allow-other-keys) + (setf all-keys (copy-list all-keys)) ; since we modify it + (remf all-keys :metaclass) + (change-class class metaclass) + (apply #'reinitialize-instance class + :direct-superclasses (canonicalize-direct-superclasses + direct-superclasses) + all-keys) + class) + +(defmethod ensure-class-using-class ((class class) name + &key (metaclass +the-standard-class+ metaclassp) + direct-superclasses &rest all-keys + &allow-other-keys) + (setf all-keys (copy-list all-keys)) ; since we modify it + (remf all-keys :metaclass) + (when (and metaclassp (not (eq (class-of class) metaclass))) + (error 'program-error + "Trying to redefine class ~S with different metaclass." + (class-name class))) + (apply #'reinitialize-instance class + :direct-superclasses (canonicalize-direct-superclasses direct-superclasses) + all-keys) + class) + +(defun maybe-finalize-class-subtree (class) + (when (every #'class-finalized-p (class-direct-superclasses class)) + (finalize-inheritance class) + (dolist (subclass (class-direct-subclasses class)) + (maybe-finalize-class-subtree subclass)))) + +(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) + (unless (>= (length form) 3) + (error 'program-error "Wrong number of arguments for DEFCLASS.")) + (check-declaration-type name) + `(ensure-class ',name + :direct-superclasses + (canonicalize-direct-superclasses ',direct-superclasses) + :direct-slots + ,(canonicalize-direct-slots direct-slots) + ,@(canonicalize-defclass-options options))) + + + (defgeneric direct-slot-definition-class (class &rest initargs)) (defmethod direct-slot-definition-class ((class class) &rest initargs) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jan 17 12:15:55 2012 (r13788) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jan 17 12:15:57 2012 (r13789) @@ -43,6 +43,7 @@ slot-makunbound-using-class ensure-class + ensure-class-using-class class-default-initargs class-direct-default-initargs From astalla at common-lisp.net Tue Jan 17 20:26:21 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Tue, 17 Jan 2012 12:26:21 -0800 Subject: [armedbear-cvs] r13790 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Tue Jan 17 12:26:21 2012 New Revision: 13790 Log: [runtime-class] added auto getter/setter generation for fields. Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 17 12:15:57 2012 (r13789) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 17 12:26:21 2012 (r13790) @@ -61,14 +61,7 @@ (class-add-attribute class-file (make-runtime-visible-annotations-attribute :list (mapcar #'parse-annotation annotations)))) (setf method-implementation-fields (java::runtime-class-add-methods class-file methods)) - (dolist (field-spec fields) - (destructuring-bind (name type &key (modifiers '(:public)) annotations) field-spec - (let ((field (make-field name (if (keywordp type) type (make-jvm-class-name type)) - :flags modifiers))) - (when annotations - (field-add-attribute field (make-runtime-visible-annotations-attribute - :list (mapcar #'parse-annotation annotations)))) - (class-add-field class-file field)))) + (java::runtime-class-add-fields class-file fields) (if (null constructors) (let ((ctor (make-jvm-method :constructor :void nil :flags '(:public)))) (class-add-method class-file ctor) @@ -85,6 +78,11 @@ (write-sequence (java::list-from-jarray (sys::%get-output-stream-bytes stream)) f)) (values class-file method-implementation-fields))) +(defun java::make-accessor-name (prefix name) + (let ((initial (char-upcase (aref name 0))) + (rest (subseq name 1))) + (format nil "~A~A~A" prefix initial rest))) + (defun java::runtime-class-add-methods (class-file methods) (let (method-implementation-fields) (dolist (m methods) @@ -153,6 +151,46 @@ (error "Unsupported return type: ~A" return-type))))))) method-implementation-fields)) +(defun java::runtime-class-add-fields (class-file fields) + (dolist (field-spec fields) + (destructuring-bind (name type &key (modifiers '(:public)) annotations + (getter nil getter-p) (setter nil setter-p) + (property (and (not getter-p) (not setter-p)))) + field-spec + (let* ((type (if (keywordp type) type (make-jvm-class-name type))) + (field (make-field name type :flags modifiers))) + (when (member :static modifiers) + (setf property nil getter nil setter nil)) + (when annotations + (field-add-attribute field (make-runtime-visible-annotations-attribute + :list (mapcar #'parse-annotation annotations)))) + (class-add-field class-file field) + (when (or getter property) + (unless (stringp getter) + (setf getter (java::make-accessor-name "get" (if (stringp property) property name)))) + (let ((jmethod (make-jvm-method getter type nil :flags '(:public)))) + (class-add-method class-file jmethod) + (with-code-to-method (class-file jmethod) + (aload 0) + (emit-getfield (class-file-class class-file) name type) + (cond + ((jvm-class-name-p type) (emit 'areturn)) + ((eq type :int) (emit 'ireturn)) + (t (error "Unsupported getter return type: ~A" type)))))) + (when (or setter property) + (unless (stringp setter) + (setf setter (java::make-accessor-name "set" (if (stringp property) property name)))) + (let ((jmethod (make-jvm-method setter :void (list type) :flags '(:public)))) + (class-add-method class-file jmethod) + (with-code-to-method (class-file jmethod) + (aload 0) + (cond + ((jvm-class-name-p type) (aload 1)) + ((eq type :int) (iload 1)) + (t (error "Unsupported setter parameter type: ~A" type))) + (emit-putfield (class-file-class class-file) name type) + (emit 'return)))))))) + (defmacro java:define-java-class () :todo) (defun parse-annotation (annotation) @@ -180,16 +218,16 @@ (t (make-primitive-or-string-annotation-element :name name :value value))))))) ;;TODO: -;; - Fields: test -;; - Properties + optional accessors (CLOS methods) ;; - Function calls with 8+ args -;; - super? -;; - Constructors? +;; - super method invocation. Idea: generate companion methods super_... to use with plain jcall. Add a flag per method to optionally disable this when not needed. +;; - Constructors +;; - optional accessors (CLOS methods) for properties? #+example (java:jnew-runtime-class "Foo" :interfaces (list "java.lang.Comparable") + :fields (list '("someField" "java.lang.String") '("anotherField" "java.lang.Object" :getter t)) :methods (list (list "foo" :void '("java.lang.Object") (lambda (this that) (print (list this that))) From rschlatte at common-lisp.net Tue Jan 17 22:44:38 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 17 Jan 2012 14:44:38 -0800 Subject: [armedbear-cvs] r13791 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jan 17 14:44:37 2012 New Revision: 13791 Log: Merge branch 'mop-work' Deleted: trunk/abcl/src/org/armedbear/lisp/ForwardReferencedClass.java Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Jan 17 12:26:21 2012 (r13790) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Jan 17 14:44:37 2012 (r13791) @@ -654,7 +654,14 @@ STANDARD_OBJECT, BuiltInClass.CLASS_T); FORWARD_REFERENCED_CLASS.setCPL(FORWARD_REFERENCED_CLASS, CLASS, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); - FUNCALLABLE_STANDARD_OBJECT.setCPL(FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, BuiltInClass.CLASS_T); + // Not all of these slots are necessary, but for now we take the + // standard layout. Instances of this class will be redefined and + // get a new layout in due course. + FORWARD_REFERENCED_CLASS.setClassLayout(layoutStandardClass); + FORWARD_REFERENCED_CLASS.setDirectSlotDefinitions(standardClassSlotDefinitions()); + FUNCALLABLE_STANDARD_OBJECT.setCPL(FUNCALLABLE_STANDARD_OBJECT, + STANDARD_OBJECT, BuiltInClass.FUNCTION, + BuiltInClass.CLASS_T); GENERIC_FUNCTION.setCPL(GENERIC_FUNCTION, METAOBJECT, FUNCALLABLE_STANDARD_OBJECT, STANDARD_OBJECT, BuiltInClass.FUNCTION, @@ -785,6 +792,7 @@ FUNCALLABLE_STANDARD_OBJECT.finalizeClass(); CLASS.finalizeClass(); FUNCALLABLE_STANDARD_CLASS.finalizeClass(); + FORWARD_REFERENCED_CLASS.finalizeClass(); GENERIC_FUNCTION.finalizeClass(); ARITHMETIC_ERROR.finalizeClass(); CELL_ERROR.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 12:26:21 2012 (r13790) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 17 14:44:37 2012 (r13791) @@ -102,6 +102,8 @@ (defconstant +the-structure-class+ (find-class 'structure-class)) (defconstant +the-standard-object-class+ (find-class 'standard-object)) (defconstant +the-standard-method-class+ (find-class 'standard-method)) +(defconstant +the-forward-referenced-class+ + (find-class 'forward-referenced-class)) (defconstant +the-standard-reader-method-class+ (find-class 'standard-reader-method)) (defconstant +the-standard-generic-function-class+ @@ -286,21 +288,6 @@ (when (fboundp 'note-name-defined) (note-name-defined name))) -(defun canonicalize-direct-superclasses (direct-superclasses) - (let ((classes '())) - (dolist (class-specifier direct-superclasses) - (let ((class (if (classp class-specifier) - class-specifier - (find-class class-specifier nil)))) - (unless class - (setf class (make-forward-referenced-class class-specifier))) - (when (and (typep class 'built-in-class) - (not (member class *extensible-built-in-classes*))) - (error "Attempt to define a subclass of built-in-class ~S." - class-specifier)) - (push class classes))) - (nreverse classes))) - (defun canonicalize-defclass-options (options) (mapappend #'canonicalize-defclass-option options)) @@ -2547,13 +2534,30 @@ :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." :format-arguments (list name)))))) +(defun canonicalize-direct-superclasses (direct-superclasses) + (let ((classes '())) + (dolist (class-specifier direct-superclasses) + (let ((class (if (classp class-specifier) + class-specifier + (find-class class-specifier nil)))) + (unless class + (setf class (make-instance +the-forward-referenced-class+ + :name class-specifier)) + (setf (find-class class-specifier) class)) + (when (and (typep class 'built-in-class) + (not (member class *extensible-built-in-classes*))) + (error "Attempt to define a subclass of built-in-class ~S." + class-specifier)) + (push class classes))) + (nreverse classes))) + ;;; AMOP pg. 182 (defun ensure-class (name &rest all-keys &key &allow-other-keys) (apply #'ensure-class-using-class (find-class name nil) name all-keys)) ;;; AMOP pg. 183ff. (defgeneric ensure-class-using-class (class name &key direct-default-initargs - direct-slots direct-superclasses name + direct-slots direct-superclasses metaclass &allow-other-keys)) (defmethod ensure-class-using-class :before (class name &key direct-slots @@ -2583,23 +2587,25 @@ (declare (ignore all-keys)) (error "The symbol ~S names a built-in class." name)) - (defmethod ensure-class-using-class ((class forward-referenced-class) name - &key (metaclass +the-standard-class+) - direct-superclasses - &rest all-keys &key &allow-other-keys) - (setf all-keys (copy-list all-keys)) ; since we modify it - (remf all-keys :metaclass) - (change-class class metaclass) - (apply #'reinitialize-instance class - :direct-superclasses (canonicalize-direct-superclasses - direct-superclasses) - all-keys) - class) +(defmethod ensure-class-using-class ((class forward-referenced-class) name + &rest all-keys + &key (metaclass +the-standard-class+) + direct-superclasses &allow-other-keys) + (setf all-keys (copy-list all-keys)) ; since we modify it + (remf all-keys :metaclass) + (change-class class metaclass) + (apply #'reinitialize-instance class + :name name + :direct-superclasses (canonicalize-direct-superclasses + direct-superclasses) + all-keys) + class) (defmethod ensure-class-using-class ((class class) name &key (metaclass +the-standard-class+ metaclassp) direct-superclasses &rest all-keys &allow-other-keys) + (declare (ignore name)) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :metaclass) (when (and metaclassp (not (eq (class-of class) metaclass))) @@ -3046,6 +3052,24 @@ &rest initargs) (std-shared-initialize instance slot-names initargs)) +(defmethod shared-initialize :after ((instance standard-class) slot-names + &key direct-superclasses + direct-slots direct-default-initargs + &allow-other-keys) + (std-after-initialization-for-classes + instance :direct-superclasses direct-superclasses + :direct-slots direct-slots + :direct-default-initargs direct-default-initargs)) + +(defmethod shared-initialize :after ((instance funcallable-standard-class) + slot-names &key direct-superclasses + direct-slots direct-default-initargs + &allow-other-keys) + (std-after-initialization-for-classes + instance :direct-superclasses direct-superclasses + :direct-slots direct-slots + :direct-default-initargs direct-default-initargs)) + (defmethod shared-initialize ((slot slot-definition) slot-names &rest args &key name initargs initform initfunction From astalla at common-lisp.net Fri Jan 20 01:10:41 2012 From: astalla at common-lisp.net (astalla at common-lisp.net) Date: Thu, 19 Jan 2012 17:10:41 -0800 Subject: [armedbear-cvs] r13792 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: astalla Date: Thu Jan 19 17:10:39 2012 New Revision: 13792 Log: A small reorganization of compiler/jvm code. Runtime-class wasn't autoloading properly in certain situations due to a wrong dependency graph among some system files. Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Tue Jan 17 14:44:37 2012 (r13791) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Thu Jan 19 17:10:39 2012 (r13792) @@ -42,6 +42,7 @@ (require "KNOWN-SYMBOLS") (require "DUMP-FORM") (require "JVM-INSTRUCTIONS") + (require "JVM-CLASS-FILE") (require "JAVA")) Modified: trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Tue Jan 17 14:44:37 2012 (r13791) +++ trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp Thu Jan 19 17:10:39 2012 (r13792) @@ -30,6 +30,7 @@ ;;; exception statement from your version. (in-package "JVM") +(require '#:compiler-types) #| @@ -1511,3 +1512,4 @@ |# +(provide '#:jvm-class-file) \ No newline at end of file Modified: trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Tue Jan 17 14:44:37 2012 (r13791) +++ trunk/abcl/src/org/armedbear/lisp/jvm-instructions.lisp Thu Jan 19 17:10:39 2012 (r13792) @@ -32,6 +32,36 @@ (in-package #:jvm) +(declaim (inline u2 s1 s2)) + +(defknown u2 (fixnum) cons) +(defun u2 (n) + (declare (optimize speed)) + (declare (type (unsigned-byte 16) n)) + (when (not (<= 0 n 65535)) + (error "u2 argument ~A out of 65k range." n)) + (list (logand (ash n -8) #xff) + (logand n #xff))) + +(defknown s1 (fixnum) fixnum) +(defun s1 (n) + (declare (optimize speed)) + (declare (type (signed-byte 8) n)) + (when (not (<= -128 n 127)) + (error "s1 argument ~A out of 8-bit signed range." n)) + (if (< n 0) + (1+ (logxor (- n) #xFF)) + n)) + + +(defknown s2 (fixnum) cons) +(defun s2 (n) + (declare (optimize speed)) + (declare (type (signed-byte 16) n)) + (when (not (<= -32768 n 32767)) + (error "s2 argument ~A out of 16-bit signed range." n)) + (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) + n))) ;; OPCODES Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Tue Jan 17 14:44:37 2012 (r13791) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Thu Jan 19 17:10:39 2012 (r13792) @@ -70,41 +70,6 @@ (defmacro dformat (&rest ignored) (declare (ignore ignored))) -(declaim (inline u2 s1 s2)) - -(defknown u2 (fixnum) cons) -(defun u2 (n) - (declare (optimize speed)) - (declare (type (unsigned-byte 16) n)) - (when (not (<= 0 n 65535)) - (error "u2 argument ~A out of 65k range." n)) - (list (logand (ash n -8) #xff) - (logand n #xff))) - -(defknown s1 (fixnum) fixnum) -(defun s1 (n) - (declare (optimize speed)) - (declare (type (signed-byte 8) n)) - (when (not (<= -128 n 127)) - (error "s1 argument ~A out of 8-bit signed range." n)) - (if (< n 0) - (1+ (logxor (- n) #xFF)) - n)) - - -(defknown s2 (fixnum) cons) -(defun s2 (n) - (declare (optimize speed)) - (declare (type (signed-byte 16) n)) - (when (not (<= -32768 n 32767)) - (error "s2 argument ~A out of 16-bit signed range." n)) - (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF)) - n))) - - - - - (defmacro with-saved-compiler-policy (&body body) "Saves compiler policy variables, restoring them after evaluating `body'." `(let ((*speed* *speed*) Modified: trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp Tue Jan 17 14:44:37 2012 (r13791) +++ trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp Thu Jan 19 17:10:39 2012 (r13792) @@ -31,6 +31,7 @@ (in-package #:system) +(require "JVM-CLASS-FILE") (require "JAVA") (export '(lookup-known-symbol)) Modified: trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Tue Jan 17 14:44:37 2012 (r13791) +++ trunk/abcl/src/org/armedbear/lisp/runtime-class.lisp Thu Jan 19 17:10:39 2012 (r13792) @@ -1,5 +1,4 @@ -(require "COMPILER-PASS2") -(require "JVM-CLASS-FILE") +(require "JVM") ;;The package is set to :jvm for convenience, since most of the symbols used ;;here come from that package. However, the functions we're definining belong @@ -186,7 +185,7 @@ (aload 0) (cond ((jvm-class-name-p type) (aload 1)) - ((eq type :int) (iload 1)) + ((eq type :int) (emit 'iload 1)) (t (error "Unsupported setter parameter type: ~A" type))) (emit-putfield (class-file-class class-file) name type) (emit 'return)))))))) @@ -218,6 +217,7 @@ (t (make-primitive-or-string-annotation-element :name name :value value))))))) ;;TODO: +;; - Returning nil as null is broken ;; - Function calls with 8+ args ;; - super method invocation. Idea: generate companion methods super_... to use with plain jcall. Add a flag per method to optionally disable this when not needed. ;; - Constructors From mevenson at common-lisp.net Sun Jan 22 07:52:54 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 21 Jan 2012 23:52:54 -0800 Subject: [armedbear-cvs] r13793 - trunk/abcl Message-ID: Author: mevenson Date: Sat Jan 21 23:52:53 2012 New Revision: 13793 Log: Comment on desired buildtime bytecode JVM compilance Modified: trunk/abcl/build.xml Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Thu Jan 19 17:10:39 2012 (r13792) +++ trunk/abcl/build.xml Sat Jan 21 23:52:53 2012 (r13793) @@ -174,6 +174,7 @@ depends="abcl.init,abcl.java.warning,abcl.jsr-223.notice"> + Author: mevenson Date: Sat Jan 21 23:52:54 2012 New Revision: 13794 Log: Bless abcl-asdf-0.5.0 to fix bugs. Outstanding issue is that it doesn't work on MSFT. Modified: trunk/abcl/contrib/abcl-asdf/README.markdown Modified: trunk/abcl/contrib/abcl-asdf/README.markdown ============================================================================== --- trunk/abcl/contrib/abcl-asdf/README.markdown Sat Jan 21 23:52:53 2012 (r13793) +++ trunk/abcl/contrib/abcl-asdf/README.markdown Sat Jan 21 23:52:54 2012 (r13794) @@ -110,13 +110,33 @@ Problems -------- +-------- -0.4.1 2011-09-06 +### 0.5.0 2012-01-22 -o locating the proper Maven3 libraries could work in more places + o just bless this as a release to stablize its offered API "as is" -o untested under Windows + o definitely failing under MSFT -o more information should be optionally available when downloading - as this process can potentially take a long time. + o ASDF version has to be a three value integer (i.e. no "-snapshot" + after version). Should be fixed with appropiate :AROUND method + as implementation specific monkeypatch. + + +### 0.4.1 2011-09-06 + + o locating the proper Maven3 libraries could work in more places + + o untested under Windows + + o more information should be optionally available when downloading + as this process can potentially take a long time. + + +#### Colophone + + Mark + + Created: 2011-01-01 + Revised: 2012-01-22 + From mevenson at common-lisp.net Sun Jan 22 08:47:02 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sun, 22 Jan 2012 00:47:02 -0800 Subject: [armedbear-cvs] r13795 - trunk/abcl/contrib/asdf-jar Message-ID: Author: mevenson Date: Sun Jan 22 00:47:02 2012 New Revision: 13795 Log: Yong patches asdf-jar for MSFT. See http://article.gmane.org/gmane.lisp.armedbear.devel/2190 Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp ============================================================================== --- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sat Jan 21 23:52:54 2012 (r13794) +++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sun Jan 22 00:47:02 2012 (r13795) @@ -35,9 +35,11 @@ (handler-case (slot-value system 'asdf:version) (unbound-slot () "unknown"))) (package-jar-name - (format nil "~A~A-~A.jar" name (if recursive "-all" "") version)) + (format nil "~A~A-~A" name (if recursive "-all" "") version)) (package-jar - (make-pathname :directory (pathname-directory out) :defaults package-jar-name)) + (make-pathname :name package-jar-name + :type "jar" + :defaults out)) (mapping (make-hash-table :test 'equal)) (dependencies (dependent-systems system))) (when verbose @@ -55,10 +57,10 @@ (let ((base (slot-value system 'asdf::absolute-pathname)) (name (slot-value system 'asdf::name)) (asdf (slot-value system 'asdf::source-file))) - (setf (gethash asdf mapping) (relative-path base name asdf)) + (setf (gethash asdf mapping) (archive-relative-path base name asdf)) (loop :for component :in (all-files system) :for source = (slot-value component 'asdf::absolute-pathname) - :for source-entry = (relative-path base name source) + :for source-entry = (archive-relative-path base name source) :do (setf (gethash source mapping) source-entry) :do (when *debug* @@ -96,11 +98,12 @@ :when sub :append sub))) (remove-duplicates `(, at dependencies , at sub-depends)))) -(defun relative-path (base dir file) +(defun archive-relative-path (base dir file) (let* ((relative (nthcdr (length (pathname-directory base)) (pathname-directory file))) - (entry-dir `(:relative ,dir ,@(when relative relative)))) - (make-pathname :directory entry-dir + (entry-dir `(:relative ,dir , at relative))) + (make-pathname :device nil + :directory entry-dir :defaults file))) (defun tmpdir (name) @@ -117,7 +120,7 @@ The parameter passed to :USE-JAR-FASLS determines whether to instruct asdf to use the fasls packaged in the jar. If this is nil, the fasls -will be compiled with respect to the ususual asdf output translation +will be compiled with respect to the usual asdf output translation conventions." (when (not (typep jar 'pathname)) (setf jar (pathname jar))) From mevenson at common-lisp.net Mon Jan 23 15:18:39 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Mon, 23 Jan 2012 07:18:39 -0800 Subject: [armedbear-cvs] r13796 - trunk/abcl Message-ID: Author: mevenson Date: Mon Jan 23 07:18:38 2012 New Revision: 13796 Log: Add DOAP description for Armed Bear Common Lisp. Turtles all the way down ... Added: trunk/abcl/abcl.rdf Added: trunk/abcl/abcl.rdf ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/abcl.rdf Mon Jan 23 07:18:38 2012 (r13796) @@ -0,0 +1,25 @@ +# -*- Mode: n3 -*- + + at prefix abcl: + at prefix doap: . + at prefix rdf: . + at prefix rdfs: . + +<> a doap:Project. +<> rdfs:seeAlso . + + + a doap:Project ; + doap:label "Armed Bear Common Lisp" ; + doap:download-page ; + doap:license ; + + doap:programming-language "Java"^^xsd:string ; + doap:shortname "ABCL"^^xsd:string . + +doap:Project rdfs:seeAlso + , + , + . + + \ No newline at end of file From mevenson at common-lisp.net Tue Jan 24 19:56:41 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 24 Jan 2012 11:56:41 -0800 Subject: [armedbear-cvs] r13797 - trunk/abcl Message-ID: Author: mevenson Date: Tue Jan 24 11:56:40 2012 New Revision: 13797 Log: Speculative use of N3. Not even sure it is valid N3. Need to bootstrap G Modified: trunk/abcl/abcl.rdf Modified: trunk/abcl/abcl.rdf ============================================================================== --- trunk/abcl/abcl.rdf Mon Jan 23 07:18:38 2012 (r13796) +++ trunk/abcl/abcl.rdf Tue Jan 24 11:56:40 2012 (r13797) @@ -14,8 +14,10 @@ doap:download-page ; doap:license ; - doap:programming-language "Java"^^xsd:string ; - doap:shortname "ABCL"^^xsd:string . + doap:programming-language """("Common Lisp" "Java" "Ant" "Shell Script") """" ; + doap:shortname "ABCL"^^xsd:string + doap:contributors """( ehu, easye, v-ille, astalla, rudi, peter)""" + doap:Project rdfs:seeAlso , From mevenson at common-lisp.net Wed Jan 25 07:48:03 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 24 Jan 2012 23:48:03 -0800 Subject: [armedbear-cvs] r13798 - trunk/abcl/doc/manual Message-ID: Author: mevenson Date: Tue Jan 24 23:48:02 2012 New Revision: 13798 Log: Merge User manual from what we tagged as 1.0.1 Modified: trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Tue Jan 24 11:56:40 2012 (r13797) +++ trunk/abcl/doc/manual/abcl.tex Tue Jan 24 23:48:02 2012 (r13798) @@ -5,7 +5,7 @@ \begin{document} \title{A Manual for Armed Bear Common Lisp} -\date{January 10, 2012} +\date{January 25, 2012} \author{Mark~Evenson, Erik~H\"{u}lsmann, Alessio~Stalla, Ville~Voutilainen} \maketitle @@ -21,7 +21,7 @@ implementation for users of the system. \subsection{Version} -This manual corresponds to abcl-1.0.1 released on January 10, 2012. +This manual corresponds to abcl-1.1.0-dev, as yet unreleased.. \subsection{License} @@ -47,7 +47,6 @@ \item Alan Ruttenberg \texttt{Thanks for JSS.} - \item and of course \emph{Peter Graves} \end{itemize} @@ -57,7 +56,7 @@ \textsc{ABCL} is packaged as a single jar file usually named either ``abcl.jar'' or possibly``abcl-1.0.1.jar'' if one is using a versioned -package on the local filesytem from your system vendor. This byte +package on the local filesystem from your system vendor. This byte archive can be executed under the control of a suitable JVM \footnote {Java Virtual Machine} by using the ``-jar'' option to parse the manifest, and select the class named therein @@ -163,7 +162,7 @@ at an arbitrarily selected call frame. \item An incomplete implementation of a properly named metaobject - protocol (viz. (A)MOP \footnote{The Art of the Metaobject Protocol} ) + protocol (c.f. the (A)MOP \footnote{The Art of the Metaobject Protocol} specification) % N.b. % TODO go through AMOP with symbols, starting by looking for @@ -560,7 +559,7 @@ ABCL can be built with support for JSR-223, which offers a language-agnostic API to invoke other languages from Java. The binary -distribution downloadable from ABCL's common-lisp.net home is built +distribution download-able from ABCL's common-lisp.net home is built with JSR-223 support. If you're building ABCL from source on a pre-1.6 JVM, you need to have a JSR-223 implementation in your CLASSPATH (such as Apache Commons BSF 3.x or greater) in order to build ABCL with @@ -602,13 +601,13 @@ AbclScriptEngineFactory or by using the service provider mechanism through ScriptEngineManager (refer to the javax.script documentation). -\subsubsection{Startup and configuration file} +\subsubsection{Start-up and configuration file} -At startup (i.e. when its constructor is invoked, as part of the +At start-up (i.e. when its constructor is invoked, as part of the static initialization phase of AbclScriptEngineFactory) the ABCL script engine attempts to load an "init file" from the classpath (/abcl-script-config.lisp). If present, this file can be used to -customize the behaviour of the engine, by setting a number of +customize the behavior of the engine, by setting a number of variables in the ABCL-SCRIPT package. Here is a list of the available variables: @@ -1058,17 +1057,23 @@ systems the code in this package will recursively package all the required source and fasls in a jar archive. -\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown} +See \url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown}. \section{jss} \label{section:jss} -To one used to a syntax that can construct macros the Java syntax -may be said to suck, so we introduce the \code{SHARPSIGN-DOUBLE-QUOTE} \#" macro. +To one used to the more universal syntax of Lisp pairs for which the +definition of read and compile time macros is quite natural, the Java +syntax available to the Java programmer may be said to suck. To +alleviate this situation, we introduce the +\code{SHARPSIGN-DOUBLE-QUOTE} (``\\#"Q'') macro, the first of perhaps + many exper \subsection{JSS usage} +\label{section:jss} + Example: \begin{listing-lisp} @@ -1113,8 +1118,8 @@ On October 22, 2011, with the publication of this Manual explicitly stating the conformance of Armed Bear Common Lisp to \textsc{ANSI}, we -released abcl-1.0.0. - +released abcl-1.0.0. We released abcl-1.0.1 as a maintainence release +on January 10, 2012. \begin{thebibliography}{9} @@ -1130,6 +1135,7 @@ ``Quicklisp: A system for quickly constructing Common Lisp'' \url{http://www.quicklisp.org/} +\label{_:RHODES2007} \bibitem{Rhodes2007} Christopher Rhodes ``User-extensible Sequences in Common Lisp'' @@ -1137,6 +1143,12 @@ % An early draft. XXX where is the real one? \url{http://jcsu.jesus.cam.ac.uk/~csr21/spec.pdf} +\label{_:AMOP} +\bibitem{AMOP} +Gregor Kiczales, Jim de Rivieres, and Daniel G. Bobrow +The Art of the Metaobject Protocol +% XXX online citation + \end{thebibliography} \printindex From rschlatte at common-lisp.net Wed Jan 25 08:53:50 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 25 Jan 2012 00:53:50 -0800 Subject: [armedbear-cvs] r13799 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jan 25 00:53:50 2012 New Revision: 13799 Log: Handle metaclasses given as symbols. 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 Tue Jan 24 23:48:02 2012 (r13798) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 25 00:53:50 2012 (r13799) @@ -2572,6 +2572,7 @@ &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :metaclass) + (unless (classp metaclass) (setf metaclass (find-class metaclass))) (let ((class (apply (if (eq metaclass +the-standard-class+) #'make-instance-standard-class #'make-instance) @@ -2593,6 +2594,7 @@ direct-superclasses &allow-other-keys) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :metaclass) + (unless (classp metaclass) (setf metaclass (find-class metaclass))) (change-class class metaclass) (apply #'reinitialize-instance class :name name @@ -2608,6 +2610,7 @@ (declare (ignore name)) (setf all-keys (copy-list all-keys)) ; since we modify it (remf all-keys :metaclass) + (unless (classp metaclass) (setf metaclass (find-class metaclass))) (when (and metaclassp (not (eq (class-of class) metaclass))) (error 'program-error "Trying to redefine class ~S with different metaclass." From rschlatte at common-lisp.net Wed Jan 25 08:53:54 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 25 Jan 2012 00:53:54 -0800 Subject: [armedbear-cvs] r13800 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Wed Jan 25 00:53:54 2012 New Revision: 13800 Log: minor refactorings in the vicinity of standard-generic-function. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/jvm.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 25 00:53:50 2012 (r13799) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Wed Jan 25 00:53:54 2012 (r13800) @@ -78,6 +78,7 @@ ;; * BuiltInClass.java ;; * StandardObject.java ;; * StandardObjectFunctions.java +;; * FuncallableStandardObject.java ;; * Layout.java ;; ;; In case of function names, those defined on the Java side can be @@ -1327,12 +1328,19 @@ (when (fboundp function-name) (let ((gf (fdefinition function-name))) (when (typep gf 'generic-function) - ;; Remove methods defined by previous DEFGENERIC forms. + ;; Remove methods defined by previous DEFGENERIC forms, as + ;; specified by CLHS, 7.7 (Macro DEFGENERIC). (dolist (method (generic-function-initial-methods gf)) - (%remove-method gf method)) + (if (typep gf 'standard-generic-function) + (std-remove-method gf method) + (remove-method gf method))) (setf (generic-function-initial-methods gf) '())))) (apply 'ensure-generic-function function-name all-keys)) +;;; Bootstrap version of ensure-generic-function, handling only +;;; standard-generic-function. This function will be replaced in +;;; mop.lisp. +(declaim (notinline ensure-generic-function)) (defun ensure-generic-function (function-name &rest all-keys &key @@ -1365,7 +1373,7 @@ (canonicalize-argument-precedence-order argument-precedence-order required-args) nil))) - (finalize-generic-function gf)) + (finalize-standard-generic-function gf)) gf) (progn (when (and (null *clos-booting*) @@ -1402,9 +1410,11 @@ :test 'eql)))) result)) -(defun finalize-generic-function (gf) +(defun finalize-standard-generic-function (gf) (%finalize-generic-function gf) - (setf (classes-to-emf-table gf) (make-hash-table :test #'equal)) + (unless (generic-function-classes-to-emf-table gf) + (set-generic-function-classes-to-emf-table gf (make-hash-table :test #'equal))) + (clrhash (generic-function-classes-to-emf-table gf)) (%init-eql-specializations gf (collect-eql-specializer-objects gf)) (set-funcallable-instance-function gf #'(lambda (&rest args) @@ -1420,26 +1430,27 @@ method-combination argument-precedence-order documentation) + ;; to avoid circularities, we do not call generic functions in here. (declare (ignore generic-function-class)) (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) ()) - (setf (generic-function-methods gf) ()) - (setf (generic-function-method-class gf) method-class) - (setf (generic-function-method-combination gf) method-combination) - (setf (generic-function-documentation gf) documentation) - (setf (classes-to-emf-table gf) nil) + (%set-generic-function-lambda-list gf lambda-list) + (set-generic-function-initial-methods gf ()) + (set-generic-function-methods gf ()) + (set-generic-function-method-class gf method-class) + (set-generic-function-method-combination gf method-combination) + (set-generic-function-documentation gf documentation) + (set-generic-function-classes-to-emf-table gf nil) (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) (required-args (getf plist ':required-args))) (%set-gf-required-args gf required-args) (%set-gf-optional-args gf (getf plist :optional-args)) - (setf (generic-function-argument-precedence-order gf) + (set-generic-function-argument-precedence-order gf (if argument-precedence-order (canonicalize-argument-precedence-order argument-precedence-order required-args) nil))) - (finalize-generic-function gf) + (finalize-standard-generic-function gf) gf)) (defun canonicalize-specializers (specializers) @@ -1686,7 +1697,7 @@ (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) + (std-add-method gf method) method))) (defun make-instance-standard-method (gf @@ -1713,7 +1724,7 @@ (getf analyzed-args :allow-other-keys)) method)) -(defun %add-method (gf method) +(defun std-add-method (gf method) (when (%method-generic-function method) (error 'simple-error :format-control "ADD-METHOD: ~S is a method of ~S." @@ -1722,16 +1733,16 @@ (let ((old-method (%find-method gf (method-qualifiers method) (%method-specializers method) nil))) (when old-method - (%remove-method gf old-method))) + (std-remove-method gf old-method))) (%set-method-generic-function method gf) (push method (generic-function-methods gf)) (dolist (specializer (%method-specializers method)) (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? (pushnew method (class-direct-methods specializer)))) - (finalize-generic-function gf) + (finalize-standard-generic-function gf) gf) -(defun %remove-method (gf method) +(defun std-remove-method (gf method) (setf (generic-function-methods gf) (remove method (generic-function-methods gf))) (%set-method-generic-function method nil) @@ -1739,7 +1750,7 @@ (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? (setf (class-direct-methods specializer) (remove method (class-direct-methods specializer))))) - (finalize-generic-function gf) + (finalize-standard-generic-function gf) gf) (defun %find-method (gf qualifiers specializers &optional (errorp t)) @@ -2410,7 +2421,7 @@ fast-function (autocompile fast-function)) :slot-name slot-name))) - (%add-method gf method) + (std-add-method gf method) method)))) (defun add-writer-method (class function-name slot-name) @@ -3224,7 +3235,7 @@ ;;; Methods having to do with generic function metaobjects. (defmethod initialize-instance :after ((gf standard-generic-function) &key) - (finalize-generic-function gf)) + (finalize-standard-generic-function gf)) ;;; Methods having to do with generic function invocation. @@ -3476,12 +3487,12 @@ (gf-lambda-list (generic-function-lambda-list generic-function))) (check-method-lambda-list (%generic-function-name generic-function) method-lambda-list gf-lambda-list)) - (%add-method generic-function method)) + (std-add-method generic-function method)) (defgeneric remove-method (generic-function method)) (defmethod remove-method ((generic-function standard-generic-function) method) - (%remove-method generic-function method)) + (std-remove-method generic-function method)) ;; See describe.lisp. (defgeneric describe-object (object stream)) Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/jvm.lisp Wed Jan 25 00:53:50 2012 (r13799) +++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Wed Jan 25 00:53:54 2012 (r13800) @@ -748,9 +748,9 @@ initialize-instance shared-initialize)) (let ((gf (and (fboundp sym) (fdefinition sym)))) - (when (typep gf 'generic-function) + (when (typep gf 'standard-generic-function) (unless (compiled-function-p gf) - (mop::finalize-generic-function gf)))))) + (mop::finalize-standard-generic-function gf)))))) (finalize-generic-functions) From rschlatte at common-lisp.net Wed Jan 25 10:03:57 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 25 Jan 2012 02:03:57 -0800 Subject: [armedbear-cvs] r13801 - trunk/abcl/doc/manual Message-ID: Author: rschlatte Date: Wed Jan 25 02:03:56 2012 New Revision: 13801 Log: Make manual compile again. Also BibTeX-ify bibliography. Added: trunk/abcl/doc/manual/abcl.bib Modified: trunk/abcl/doc/manual/README.markdown trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/README.markdown ============================================================================== --- trunk/abcl/doc/manual/README.markdown Wed Jan 25 00:53:54 2012 (r13800) +++ trunk/abcl/doc/manual/README.markdown Wed Jan 25 02:03:56 2012 (r13801) @@ -3,4 +3,4 @@ With a suitable TexLive installed, to build simply issue: - cmd$ pdflatex abcl.tex && makeindex abcl && pdflatex abcl.tex + cmd$ pdflatex abcl.tex && bibtex abcl && makeindex abcl && pdflatex abcl.tex && pdflatex abcl.tex Added: trunk/abcl/doc/manual/abcl.bib ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/abcl.bib Wed Jan 25 02:03:56 2012 (r13801) @@ -0,0 +1,54 @@ + at Misc{maso2000, + author = {Brian Maso}, + title = {A New Era for Java Protocol Handlers}, + howpublished = {\url{http://java.sun.com/developer/onlineTraining/protocolhandlers/}}, + month = 8, + year = 2000, + note = {Last accessed Jan 25, 2012}} + + at Misc{quicklisp, + author = {Zach Beane}, + title = {Quicklisp}, + howpublished = {\url{http://www.quicklisp.org/}}, + note = {Quicklisp makes it easy to get started with a rich set of + community-developed Common Lisp libraries. Last + accessed Jan 25, 2012}} + + at InProceedings{Rhodes2007, + author = {Christophe Rhodes}, + title = {User-extensible sequences in {Common Lisp}}, + booktitle = {Proceedings of the 2007 International Lisp Conference}, + year = 2007, + publisher = {ACM}, + note = {Also available at + \url{http://doc.gold.ac.uk/~mas01cr/papers/ilc2007/sequences-20070301.pdf}}} + + + + at InProceedings{, + author = {}, + title = {}, + OPTcrossref = {}, + OPTkey = {}, + OPTbooktitle = {}, + OPTyear = {}, + OPTeditor = {}, + OPTvolume = {}, + OPTnumber = {}, + OPTseries = {}, + OPTpages = {}, + OPTmonth = {}, + OPTaddress = {}, + OPTorganization = {}, + OPTpublisher = {}, + OPTnote = {}, + OPTannote = {} +} + + at Book{AMOP, + author = {Kiczales, Gregor and des Rivi?res, Jim and Bobrow, Daniel G.}, + title = {The Art of the Metaobject Protocol}, + publisher = {MIT Press}, + year = {1991}, +} + Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Wed Jan 25 00:53:54 2012 (r13800) +++ trunk/abcl/doc/manual/abcl.tex Wed Jan 25 02:03:56 2012 (r13801) @@ -228,9 +228,9 @@ \begin{itemize} \item Call a specific method reference (which was previously acquired) -\item Dynamic dispatch using the method name and - the call-specific arguments provided by finding the - \ref{section:Parameter matching for FFI dynamic dispatch}{best match}. +\item Dynamic dispatch using the method name and the call-specific + arguments provided by finding the best match (see + Section~\ref{sec:param-matching-for-ffi}). \end{itemize} The dynamic dispatch variant is discussed in the next section. @@ -352,6 +352,7 @@ a specification of classes for each parameter. \subsubsection{Parameter matching for FFI dynamic dispatch} +\label{sec:param-matching-for-ffi} The algorithm used to resolve the best matching method given the name and the arguments' types is the same as described in the Java Language @@ -788,7 +789,7 @@ running external programs, registering object finalizers, constructing reference weakly held by the garbage collector and others. -See \ref{Rhodes2007} for a generic function interface to the native +See \cite{RHODES2007} for a generic function interface to the native JVM contract for \code{java.util.List}. % include autogen docs for the EXTENSIONS package. @@ -814,7 +815,7 @@ JVM ``understands''. Support is built-in to the ``http'' and ``https'' implementations but additional protocol handlers may be installed at runtime by having JVM symbols present in the -sun.net.protocol.dynmamic pacakge. See Java2007 \cite{Java2007} for more +sun.net.protocol.dynamic pacakge. See \cite{maso2000} for more details. ABCL has created specializations of the ANSI Pathname object to @@ -850,7 +851,7 @@ \end{itemize} The implementation of URL-PATHNAME allows the ABCL user to laod dynamically -code from the network. For example, for Quicklisp (\cite{Xach2011}): +code from the network. For example, for Quicklisp (\cite{quicklisp}): \begin{listing-lisp} CL-USER> (load "http://beta.quicklisp.org/quicklisp.lisp") @@ -858,7 +859,7 @@ will load and execute the Quicklisp setup code. -See \ref{_:XACH2011} on page \pageref{_:XACH2011}. +%See \ref{_:quicklisp} on page \pageref{_:quicklisp}. \subsubsection{Implementation} @@ -889,7 +890,7 @@ CL-USER> (require 'extensible-sequences) \end{listing-lisp} -if only the extensible sequences API as specified in \ref{RHODES2007} is +if only the extensible sequences API as specified in \cite{RHODES2007} is required. Note that \code{(require 'java-collections)} must be issued before @@ -1067,13 +1068,11 @@ definition of read and compile time macros is quite natural, the Java syntax available to the Java programmer may be said to suck. To alleviate this situation, we introduce the -\code{SHARPSIGN-DOUBLE-QUOTE} (``\\#"Q'') macro, the first of perhaps +\code{SHARPSIGN-DOUBLE-QUOTE} (\code{\#"}) reader macro, the first of perhaps many exper \subsection{JSS usage} -\label{section:jss} - Example: \begin{listing-lisp} @@ -1091,7 +1090,7 @@ \section{asdf-install} The asdf-install contrib provides an implementation of ASDF-INSTALL. -Superseded by Quicklisp (see Xach2011 \cite{Xach2011}). +Superseded by Quicklisp (see Xach2011 \cite{quicklisp}). The \code{require} of the \code{asdf-install} symbol has the side effect of pushing the directory ``~/.asdf-install-dir/systems/'' into @@ -1121,35 +1120,8 @@ released abcl-1.0.0. We released abcl-1.0.1 as a maintainence release on January 10, 2012. - -\begin{thebibliography}{9} - -\label{_:1} -\bibitem{Java2000} - ``A New Era for Java Protocol Handlers.'' - \url{http://java.sun.com/developer/onlineTraining/protocolhandlers/} - -\label{_:XACH2011} -\bibitem{Xach2011} - Zach Beene - ``Quicklisp: A system for quickly constructing Common Lisp'' - \url{http://www.quicklisp.org/} - -\label{_:RHODES2007} -\bibitem{Rhodes2007} -Christopher Rhodes -``User-extensible Sequences in Common Lisp'' -ILC '07 Proceedings of the 2007 International Lisp Conference -% An early draft. XXX where is the real one? -\url{http://jcsu.jesus.cam.ac.uk/~csr21/spec.pdf} - -\label{_:AMOP} -\bibitem{AMOP} -Gregor Kiczales, Jim de Rivieres, and Daniel G. Bobrow -The Art of the Metaobject Protocol -% XXX online citation - -\end{thebibliography} +\bibliography{abcl} +\bibliographystyle{alpha} \printindex From rschlatte at common-lisp.net Wed Jan 25 10:45:05 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 25 Jan 2012 02:45:05 -0800 Subject: [armedbear-cvs] r13802 - trunk/abcl/doc/manual Message-ID: Author: rschlatte Date: Wed Jan 25 02:45:05 2012 New Revision: 13802 Log: Add Makefile for manual. Added: trunk/abcl/doc/manual/Makefile Modified: trunk/abcl/doc/manual/README.markdown Added: trunk/abcl/doc/manual/Makefile ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/doc/manual/Makefile Wed Jan 25 02:45:05 2012 (r13802) @@ -0,0 +1,12 @@ + +all: abcl.pdf + +abcl.pdf: abcl.tex abcl.bib + pdflatex abcl.tex + bibtex abcl + makeindex abcl + pdflatex abcl.tex + pdflatex abcl.tex + +clean: + rm -f *.aux *.bbl *.blg *.idx *.ilg *.ind *.log *.out *.toc abcl.pdf Modified: trunk/abcl/doc/manual/README.markdown ============================================================================== --- trunk/abcl/doc/manual/README.markdown Wed Jan 25 02:03:56 2012 (r13801) +++ trunk/abcl/doc/manual/README.markdown Wed Jan 25 02:45:05 2012 (r13802) @@ -1,6 +1,8 @@ ABCL User Manual ================ -With a suitable TexLive installed, to build simply issue: +With a suitable TexLive installed, to build simply run `make`. If you +cannot run make, the following sequence of commands also gets you a pdf +of the manual: cmd$ pdflatex abcl.tex && bibtex abcl && makeindex abcl && pdflatex abcl.tex && pdflatex abcl.tex From mevenson at common-lisp.net Wed Jan 25 11:32:00 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 25 Jan 2012 03:32:00 -0800 Subject: [armedbear-cvs] r13803 - in trunk/abcl: . contrib/abcl-asdf/tests Message-ID: Author: mevenson Date: Wed Jan 25 03:31:59 2012 New Revision: 13803 Log: Add Ant convenience target for "abcl-contrib.jar". Modified: trunk/abcl/build.xml trunk/abcl/contrib/abcl-asdf/tests/example.lisp Modified: trunk/abcl/build.xml ============================================================================== --- trunk/abcl/build.xml Wed Jan 25 02:45:05 2012 (r13802) +++ trunk/abcl/build.xml Wed Jan 25 03:31:59 2012 (r13803) @@ -506,6 +506,7 @@ + Author: mevenson Date: Wed Jan 25 03:32:09 2012 New Revision: 13804 Log: Fix for maven-3.0.4. Part of the process of cleaning up ABCL-ASDF to work with more Maven versions. Seems to be failing for OS X Maven 3.0.4, so need to do a round of testing. Add system definition of ABCL-ASDF-TEST which becomes the behavior for invoking ASDF:TEST-SYSTEM on ABCL-ASDF. Really update to version "0.5.0". Correct misspellings. TODO: figure out a list of repos to iteratively search. TODO: overload the system defintion version mechanism to allow non-integer values, or just use the IRI class? TODO: be more verbose on searching/downloading Maven artifacts as it can be quite slow for large amounts of artifacts. Modified: trunk/abcl/contrib/abcl-asdf/README.markdown trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp trunk/abcl/contrib/abcl-asdf/packages.lisp trunk/abcl/contrib/abcl-asdf/tests/example.lisp trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Modified: trunk/abcl/contrib/abcl-asdf/README.markdown ============================================================================== --- trunk/abcl/contrib/abcl-asdf/README.markdown Wed Jan 25 03:31:59 2012 (r13803) +++ trunk/abcl/contrib/abcl-asdf/README.markdown Wed Jan 25 03:32:09 2012 (r13804) @@ -133,10 +133,10 @@ as this process can potentially take a long time. -#### Colophone +#### Colophon Mark Created: 2011-01-01 - Revised: 2012-01-22 + Revised: 2012-01-24 Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 03:31:59 2012 (r13803) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 03:32:09 2012 (r13804) @@ -3,7 +3,7 @@ (defsystem :abcl-asdf :author "Mark Evenson" - :version "0.4.1" + :version "0.5.0" :depends-on (jss) :components ((:module packages :pathname "" @@ -17,3 +17,24 @@ (:file "maven-embedder" :depends-on ("abcl-asdf" "asdf-jar"))) :depends-on (packages)))) + + +(eval-when (:compile-toplevel :load-toplevel) + (load "~/quicklisp/setup") + (apply (intern (symbol-name 'quickload) 'quicklisp) "rt")) + +(defsystem :abcl-asdf-test + :author "Mark Evenson" + :depends-on (abcl-asdf quicklisp rt) + :components + ((:module tests :components + (#+nil (:file "example") + (:file "maven"))))) + + +(defmethod perform ((o test-op) (c (eql (find-system 'abcl-asdf)))) + "Invoke tests with (asdf:test-system 'abcl-asdf)." + (asdf:load-system 'abcl-asdf-test) + + (funcall (intern (symbol-name 'run) 'abcl-asdf-test))) + Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jan 25 03:31:59 2012 (r13803) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jan 25 03:32:09 2012 (r13804) @@ -84,6 +84,10 @@ (add-directory-jars-to-class-path *mvn-libs-directory* nil) (setf *init* t)) +(defparameter *http-wagon-implementations* + `("org.apache.maven.wagon.providers.http.HttpWagon" ;; introduced as default with maven-3.0.3 + "org.apache.maven.wagon.providers.http.LightweightHttpWagon")) + (defun make-wagon-provider () (unless *init* (init)) (java:jinterface-implementation @@ -91,7 +95,7 @@ "lookup" (lambda (role-hint) (if (string-equal "http" role-hint) - (java:jnew "org.apache.maven.wagon.providers.http.LightweightHttpWagon") + (some (lambda (provider) (java:jnew provider)) *http-wagon-implementations*) java:+null+)) "release" (lambda (wagon) Modified: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 03:31:59 2012 (r13803) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 03:32:09 2012 (r13804) @@ -16,3 +16,6 @@ #:*added-to-classpath* #:*inhibit-add-to-classpath*)) +(defpackage #:abcl-asdf-test + (:use :cl :rt) + (:export #:run)) \ No newline at end of file Modified: trunk/abcl/contrib/abcl-asdf/tests/example.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/example.lisp Wed Jan 25 03:31:59 2012 (r13803) +++ trunk/abcl/contrib/abcl-asdf/tests/example.lisp Wed Jan 25 03:32:09 2012 (r13804) @@ -1,9 +1,10 @@ (in-package :abcl-asdf-test) (deftest LOG4J.2 - (asdf:load-system "log4j") - (let ((logger (#"getLogger" 'log4j.Logger (symbol-name (gensym))))) - (#"trace" logger "Kilroy wuz here.")) + (progn + (asdf:load-system "log4j") + (let ((logger (#"getLogger" 'log4j.Logger (symbol-name (gensym))))) + (#"trace" logger "Kilroy wuz here."))) t) Modified: trunk/abcl/contrib/abcl-asdf/tests/maven.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Wed Jan 25 03:31:59 2012 (r13803) +++ trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Wed Jan 25 03:32:09 2012 (r13804) @@ -5,4 +5,24 @@ |# -; TODO figure out what sort of test framework we can hook in. Probably ABCL-RT \ No newline at end of file +; TODO figure out what sort of test framework we can hook in. Probably ABCL-RT + +(in-package :abcl-asdf-test) + +(deftest LOG4J.1 + (let ((result (abcl-asdf:resolve-dependencies "log4j" "log4j"))) + (and result + (format *standard-output* "~&~A~%" result) + (type-p result 'cons))) + t) + + +(deftest ABCL.1 + (let ((result (abcl-asdf:resolve-dependencies "org.armedbear.lisp" "abcl"))) + (and result + (format *standard-output* "~&~A~%" result) + (type-p result 'cons))) + t) + + + From rschlatte at common-lisp.net Wed Jan 25 12:40:14 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Wed, 25 Jan 2012 04:40:14 -0800 Subject: [armedbear-cvs] r13805 - trunk/abcl/doc/manual Message-ID: Author: rschlatte Date: Wed Jan 25 04:40:13 2012 New Revision: 13805 Log: Update bibliography with information from dl.acm.org Modified: trunk/abcl/doc/manual/abcl.bib Modified: trunk/abcl/doc/manual/abcl.bib ============================================================================== --- trunk/abcl/doc/manual/abcl.bib Wed Jan 25 03:32:09 2012 (r13804) +++ trunk/abcl/doc/manual/abcl.bib Wed Jan 25 04:40:13 2012 (r13805) @@ -1,8 +1,8 @@ @Misc{maso2000, author = {Brian Maso}, - title = {A New Era for Java Protocol Handlers}, + title = {{A New Era for Java Protocol Handlers}}, howpublished = {\url{http://java.sun.com/developer/onlineTraining/protocolhandlers/}}, - month = 8, + month = aug, year = 2000, note = {Last accessed Jan 25, 2012}} @@ -10,40 +10,27 @@ author = {Zach Beane}, title = {Quicklisp}, howpublished = {\url{http://www.quicklisp.org/}}, - note = {Quicklisp makes it easy to get started with a rich set of - community-developed Common Lisp libraries. Last - accessed Jan 25, 2012}} + note = {Last accessed Jan 25, 2012}} - at InProceedings{Rhodes2007, - author = {Christophe Rhodes}, - title = {User-extensible sequences in {Common Lisp}}, - booktitle = {Proceedings of the 2007 International Lisp Conference}, - year = 2007, - publisher = {ACM}, - note = {Also available at - \url{http://doc.gold.ac.uk/~mas01cr/papers/ilc2007/sequences-20070301.pdf}}} - - - - at InProceedings{, - author = {}, - title = {}, - OPTcrossref = {}, - OPTkey = {}, - OPTbooktitle = {}, - OPTyear = {}, - OPTeditor = {}, - OPTvolume = {}, - OPTnumber = {}, - OPTseries = {}, - OPTpages = {}, - OPTmonth = {}, - OPTaddress = {}, - OPTorganization = {}, - OPTpublisher = {}, - OPTnote = {}, - OPTannote = {} -} + at inproceedings{Rhodes2007, + author = {Rhodes, Christophe}, + title = {User-extensible sequences in {Common Lisp}}, + booktitle = {Proceedings of the 2007 International Lisp Conference}, + year = {2009}, + isbn = {978-1-59593-618-9}, + location = {Cambridge, United Kingdom}, + pages = {13:1--13:14}, + articleno = {13}, + numpages = {14}, + url = {http://doi.acm.org/10.1145/1622123.1622138}, + doi = {http://doi.acm.org/10.1145/1622123.1622138}, + acmid = {1622138}, + publisher = {ACM}, + note = {Also available at + \url{http://doc.gold.ac.uk/~mas01cr/papers/ilc2007/sequences-20070301.pdf}} +} + @Comment series = {ILC '07}, + @Comment address = {New York, NY, USA}, @Book{AMOP, author = {Kiczales, Gregor and des Rivi?res, Jim and Bobrow, Daniel G.}, From mevenson at common-lisp.net Wed Jan 25 12:50:27 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 25 Jan 2012 04:50:27 -0800 Subject: [armedbear-cvs] r13806 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Wed Jan 25 04:50:26 2012 New Revision: 13806 Log: Fix ABCL-ASDF load time failure. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/packages.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 04:40:13 2012 (r13805) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 04:50:26 2012 (r13806) @@ -18,23 +18,16 @@ :depends-on ("abcl-asdf" "asdf-jar"))) :depends-on (packages)))) - -(eval-when (:compile-toplevel :load-toplevel) - (load "~/quicklisp/setup") - (apply (intern (symbol-name 'quickload) 'quicklisp) "rt")) - (defsystem :abcl-asdf-test :author "Mark Evenson" - :depends-on (abcl-asdf quicklisp rt) + :depends-on (abcl abcl-test-lisp) :components ((:module tests :components (#+nil (:file "example") (:file "maven"))))) - (defmethod perform ((o test-op) (c (eql (find-system 'abcl-asdf)))) "Invoke tests with (asdf:test-system 'abcl-asdf)." (asdf:load-system 'abcl-asdf-test) - (funcall (intern (symbol-name 'run) 'abcl-asdf-test))) Modified: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 04:40:13 2012 (r13805) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 04:50:26 2012 (r13806) @@ -17,5 +17,5 @@ #:*inhibit-add-to-classpath*)) (defpackage #:abcl-asdf-test - (:use :cl :rt) - (:export #:run)) \ No newline at end of file + (:use :cl :abcl-rt) + (:export #:run)) From mevenson at common-lisp.net Wed Jan 25 13:34:03 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 25 Jan 2012 05:34:03 -0800 Subject: [armedbear-cvs] r13807 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Wed Jan 25 05:34:03 2012 New Revision: 13807 Log: Further fix for ABCL-ASDF load time failure. Start separating out the public api by exporting and documenting symbols. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp trunk/abcl/contrib/abcl-asdf/packages.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 04:50:26 2012 (r13806) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 05:34:03 2012 (r13807) @@ -20,14 +20,17 @@ (defsystem :abcl-asdf-test :author "Mark Evenson" - :depends-on (abcl abcl-test-lisp) + :depends-on (abcl) :components ((:module tests :components (#+nil (:file "example") (:file "maven"))))) +#+nil FIXME (defmethod perform ((o test-op) (c (eql (find-system 'abcl-asdf)))) "Invoke tests with (asdf:test-system 'abcl-asdf)." + (asdf:load-system 'abcl) + (asdf:load-system 'abcl-test-lisp) (asdf:load-system 'abcl-asdf-test) (funcall (intern (symbol-name 'run) 'abcl-asdf-test))) Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jan 25 04:50:26 2012 (r13806) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Wed Jan 25 05:34:03 2012 (r13807) @@ -13,13 +13,14 @@ Test: (resolve-dependencies "org.slf4j" "slf4j-api" "1.6.1") -(resolve-dependencies "org.apache.maven" "maven-aether-provider" "3.0.3") +(resolve-dependencies "org.apache.maven" "maven-aether-provider" "3.0.4") |# (defvar *mavens* '("/opt/local/bin/mvn3" "mvn3" "mvn" "mvn.bat") "Locations to search for the Maven executable.") (defun find-mvn () + "Attempt to find a suitable Maven ('mvn') executable on the hosting operating system." (dolist (mvn-path *mavens*) (let ((mvn (handler-case @@ -75,20 +76,28 @@ (defparameter *init* nil) (defun init () + "Run the initialization strategy to bootstrap a Maven dependency node." (unless *mvn-libs-directory* (setf *mvn-libs-directory* (find-mvn-libs))) (unless (probe-file *mvn-libs-directory*) - (error "You must download maven-3.0.3 from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) + (error "You must download maven-3.0.3 or later from http://maven.apache.org/download.html, then set ABCL-ASDF:*MVN-DIRECTORY* appropiately.")) (unless (ensure-mvn-version) (error "We need maven-3.0.3 or later.")) (add-directory-jars-to-class-path *mvn-libs-directory* nil) (setf *init* t)) (defparameter *http-wagon-implementations* - `("org.apache.maven.wagon.providers.http.HttpWagon" ;; introduced as default with maven-3.0.3 - "org.apache.maven.wagon.providers.http.LightweightHttpWagon")) + `("org.apache.maven.wagon.providers.http.HttpWagon" ;; introduced as default with maven-3.0.4 + "org.apache.maven.wagon.providers.http.LightweightHttpWagon") + "A list of possible candidate implementations that provide access to http and https resources. + +Supposedly configurable with the java.net.protocols (c.f. reference maso2000 in the Manual.") (defun make-wagon-provider () + "Returns an implementation of the org.sonatype.aether.connector.wagon.WagonProvider contract. + +The implementation is specified as Lisp closures. Currently, it only +specializes the lookup() method if passed an 'http' role hint." (unless *init* (init)) (java:jinterface-implementation "org.sonatype.aether.connector.wagon.WagonProvider" @@ -137,7 +146,7 @@ (#"newLocalRepositoryManager" repository-system local-repository)))) (defun resolve-artifact (group-id artifact-id &optional (version "LATEST" versionp)) - "Dynamically resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID at VERSION. + "Directly resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID at VERSION, ignoring dependencies. Declared dependencies are not attempted to be located. Modified: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 04:50:26 2012 (r13806) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 05:34:03 2012 (r13807) @@ -4,7 +4,17 @@ ;;; Public API #:resolve-dependencies + #:find-mvn + + #:*mvn-directory* + + #:init + ;;; "Internal" API + +;;;; Maven + #:*mvn-libs-directory* + #:satisfy #:as-classpath @@ -17,5 +27,5 @@ #:*inhibit-add-to-classpath*)) (defpackage #:abcl-asdf-test - (:use :cl :abcl-rt) + (:use :cl #+nil :abcl-test-lisp) ;;; FIXME (:export #:run)) From mevenson at common-lisp.net Wed Jan 25 13:57:44 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 25 Jan 2012 05:57:44 -0800 Subject: [armedbear-cvs] r13808 - in trunk/abcl/contrib/abcl-asdf: . tests Message-ID: Author: mevenson Date: Wed Jan 25 05:57:43 2012 New Revision: 13808 Log: abcl-asdf: remove all the broken test framework references. The system defintion ABCL-ASDF-TEST now loads again. Use ABCL-ASDF-TEST:RUN as the executable symbol for manual tests. Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd trunk/abcl/contrib/abcl-asdf/packages.lisp trunk/abcl/contrib/abcl-asdf/tests/example.lisp trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Modified: trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd ============================================================================== --- trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 05:34:03 2012 (r13807) +++ trunk/abcl/contrib/abcl-asdf/abcl-asdf.asd Wed Jan 25 05:57:43 2012 (r13808) @@ -20,17 +20,26 @@ (defsystem :abcl-asdf-test :author "Mark Evenson" - :depends-on (abcl) + :depends-on (abcl-asdf) :components - ((:module tests :components - (#+nil (:file "example") - (:file "maven"))))) + ((:module tests :serial t :components + ((:file "example") + (:file "maven") + (:file "test"))))) -#+nil FIXME +#| +(defmethod perform ((o test-op) (c (eql (find-system 'abcl-asdf-test)))) + (funcall (intern (symbol-name 'run) 'abcl-asdf-test))) + +(defmethod perform ((o test-op) (c (eql (find-system 'abcl-asdf)))) + (asdf:load-system :abcl-asdf-test)) + (asdf:test-system :abcl-asdf-test)) + + ;;; FIXME (defmethod perform ((o test-op) (c (eql (find-system 'abcl-asdf)))) "Invoke tests with (asdf:test-system 'abcl-asdf)." (asdf:load-system 'abcl) (asdf:load-system 'abcl-test-lisp) (asdf:load-system 'abcl-asdf-test) (funcall (intern (symbol-name 'run) 'abcl-asdf-test))) - +|# Modified: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 05:34:03 2012 (r13807) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Wed Jan 25 05:57:43 2012 (r13808) @@ -27,5 +27,5 @@ #:*inhibit-add-to-classpath*)) (defpackage #:abcl-asdf-test - (:use :cl #+nil :abcl-test-lisp) ;;; FIXME + (:use :cl #+nil :abcl-test-lisp) ;;; FIXME include some sort of test framework (:export #:run)) Modified: trunk/abcl/contrib/abcl-asdf/tests/example.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/example.lisp Wed Jan 25 05:34:03 2012 (r13807) +++ trunk/abcl/contrib/abcl-asdf/tests/example.lisp Wed Jan 25 05:57:43 2012 (r13808) @@ -1,11 +1,12 @@ (in-package :abcl-asdf-test) -(deftest LOG4J.2 - (progn - (asdf:load-system "log4j") - (let ((logger (#"getLogger" 'log4j.Logger (symbol-name (gensym))))) - (#"trace" logger "Kilroy wuz here."))) - t) +;;;(deftest LOG4J.2 +;;; (progn +(defun test-LOG4J.2 () + (asdf:load-system "log4j") + (let ((logger (#"getLogger" 'log4j.Logger (symbol-name (gensym))))) + (#"trace" logger "Kilroy wuz here."))) +;;; t) Modified: trunk/abcl/contrib/abcl-asdf/tests/maven.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Wed Jan 25 05:34:03 2012 (r13807) +++ trunk/abcl/contrib/abcl-asdf/tests/maven.lisp Wed Jan 25 05:57:43 2012 (r13808) @@ -9,20 +9,22 @@ (in-package :abcl-asdf-test) -(deftest LOG4J.1 +;;;;(deftest LOG4J.1 +(defun test-LOG4J.1 () (let ((result (abcl-asdf:resolve-dependencies "log4j" "log4j"))) (and result (format *standard-output* "~&~A~%" result) - (type-p result 'cons))) - t) + (type-p result 'cons)))) +;;; t) -(deftest ABCL.1 +;;;;(deftest ABCL.1 +(defun test-ABCL.1 () (let ((result (abcl-asdf:resolve-dependencies "org.armedbear.lisp" "abcl"))) (and result (format *standard-output* "~&~A~%" result) - (type-p result 'cons))) - t) + (type-p result 'cons)))) +;;; t) From mevenson at common-lisp.net Wed Jan 25 14:57:52 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Wed, 25 Jan 2012 06:57:52 -0800 Subject: [armedbear-cvs] r13809 - in trunk/abcl: . contrib Message-ID: Author: mevenson Date: Wed Jan 25 06:57:49 2012 New Revision: 13809 Log: maven: identify builds from trunk as '1.1.0-dev'. Modified: trunk/abcl/contrib/pom.xml trunk/abcl/pom.xml Modified: trunk/abcl/contrib/pom.xml ============================================================================== --- trunk/abcl/contrib/pom.xml Wed Jan 25 05:57:43 2012 (r13808) +++ trunk/abcl/contrib/pom.xml Wed Jan 25 06:57:49 2012 (r13809) @@ -13,7 +13,7 @@ org.armedbear.lisp abcl-contrib - 1.0.1 + 1.1.0-dev jar Armed Bear Common Lisp (ABCL) Contribs Extra packages--contribs--for ABCL Modified: trunk/abcl/pom.xml ============================================================================== --- trunk/abcl/pom.xml Wed Jan 25 05:57:43 2012 (r13808) +++ trunk/abcl/pom.xml Wed Jan 25 06:57:49 2012 (r13809) @@ -13,7 +13,7 @@ org.armedbear.lisp abcl - 1.0.1 + 1.1.0-dev jar ABCL - Armed Bear Common Lisp Common Lisp implementation running on the JVM From ehuelsmann at common-lisp.net Wed Jan 25 21:24:07 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Wed, 25 Jan 2012 13:24:07 -0800 Subject: [armedbear-cvs] r13810 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Wed Jan 25 13:24:06 2012 New Revision: 13810 Log: Start factoring out p2-compiland as a jvm bytecode generator instead of a class file generator as a step toward different code generation strategies. 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 Wed Jan 25 06:57:49 2012 (r13809) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Wed Jan 25 13:24:06 2012 (r13810) @@ -4088,7 +4088,7 @@ (with-class-file class-file (let ((*current-compiland* compiland)) (with-saved-compiler-policy - (p2-compiland compiland) + (compile-to-jvm-class compiland) (finish-class (compiland-class-file compiland) f))))) (when stream (let ((bytes (sys::%get-output-stream-bytes stream))) @@ -6972,26 +6972,6 @@ -;; Returns a list with the types of the arguments -(defun analyze-args (compiland) - (let* ((args (cadr (compiland-p1-result compiland))) - (arg-count (length args))) - (dformat t "analyze-args args = ~S~%" args) - (aver (not (memq '&AUX args))) - - (when (or (memq '&KEY args) - (memq '&OPTIONAL args) - (memq '&REST args)) - (setf *using-arg-array* t - *hairy-arglist-p* t) - (return-from analyze-args (list +lisp-object-array+))) - - (cond ((<= arg-count call-registers-limit) - (lisp-object-arg-types arg-count)) - (t (setf *using-arg-array* t) - (setf (compiland-arity compiland) arg-count) - (list +lisp-object-array+))))) - (defmacro with-open-class-file ((var class-file) &body body) `(with-open-file (,var (abcl-class-file-pathname ,class-file) :direction :output @@ -7049,8 +7029,10 @@ (setf (local-function-field local-function) (symbol-name (gensym "LFUN")))) + + (defknown p2-compiland (t) t) -(defun p2-compiland (compiland) +(defun p2-compiland (compiland method) (let* ((p1-result (compiland-p1-result compiland)) (class-file (compiland-class-file compiland)) (*this-class* (abcl-class-file-class class-file)) @@ -7060,36 +7042,14 @@ (local-closure-vars (find compiland *closure-variables* :key #'variable-compiland)) (body (cddr p1-result)) - (*using-arg-array* nil) - (*hairy-arglist-p* nil) - ;; *hairy-arglist-p* != NIL --> *using-arglist-array* != NIL (*child-p* (not (null (compiland-parent compiland)))) - (arg-types (analyze-args compiland)) - (method (make-jvm-method "execute" +lisp-object+ arg-types - :flags '(:final :public))) (*visible-variables* *visible-variables*) (*thread* nil) (*initialize-thread-var* nil)) - (class-add-method class-file method) - - (setf (abcl-class-file-superclass class-file) - (if (or *hairy-arglist-p* - (and *child-p* *closure-variables*)) - +lisp-compiled-closure+ - +lisp-compiled-primitive+)) - - (let ((constructor - (make-constructor class-file (compiland-name compiland) args))) - (setf (abcl-class-file-constructor class-file) constructor) - (class-add-method class-file constructor)) - (let ((clinit (make-static-initializer class-file))) - (setf (abcl-class-file-static-initializer class-file) clinit) - (class-add-method class-file clinit)) - (with-code-to-method (class-file method) (setf *register* 1 ;; register 0: "this" pointer *registers-allocated* 1) @@ -7255,11 +7215,12 @@ (let ((code *code*)) (setf *code* ()) (let ((arity (compiland-arity compiland))) - (when arity + (when (and arity + *using-arg-array*) (generate-arg-count-check arity))) (when *hairy-arglist-p* - (aload 0) ; this + (aload 0) ; this (aver (not (null (compiland-argument-register compiland)))) (aload (compiland-argument-register compiland)) ; arg vector (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) @@ -7282,6 +7243,45 @@ )) t) +(defun compile-to-jvm-class (compiland) + "Returns ?what? ### a jvm class-file object?" + (let* ((class-file (compiland-class-file compiland)) + (args (cadr (compiland-p1-result compiland))) + (*hairy-arglist-p* (or (memq '&KEY args) + (memq '&OPTIONAL args) + (memq '&REST args))) + (*using-arg-array* (or *hairy-arglist-p* + (< call-registers-limit (length args))))) + (setf (abcl-class-file-superclass class-file) + (if (or *hairy-arglist-p* + (and (not (null (compiland-parent compiland))) + *closure-variables*)) + +lisp-compiled-closure+ + +lisp-compiled-primitive+)) + (unless *hairy-arglist-p* + (setf (compiland-arity compiland) + (length args))) + + ;; Static initializer + (let ((clinit (make-static-initializer class-file))) + (setf (abcl-class-file-static-initializer class-file) clinit) + (class-add-method class-file clinit)) + + ;; Constructor + (let ((constructor + (make-constructor class-file (compiland-name compiland) args))) + (setf (abcl-class-file-constructor class-file) constructor) + (class-add-method class-file constructor)) + + ;; Main method + (let* ((method-arg-types (if *using-arg-array* + (list +lisp-object-array+) + (lisp-object-arg-types (length args)))) + (method (make-jvm-method "execute" +lisp-object+ method-arg-types + :flags '(:final :public)))) + (class-add-method class-file method) + (p2-compiland compiland method)))) + (defun p2-with-inline-code (form target representation) ;;form = (with-inline-code (&optional target-var repr-var) ...body...) (destructuring-bind (&optional target-var repr-var) (cadr form) @@ -7325,7 +7325,7 @@ (with-class-file (compiland-class-file compiland) (with-saved-compiler-policy - (p2-compiland compiland) + (compile-to-jvm-class compiland) ;; (finalize-class-file (compiland-class-file compiland)) (finish-class (compiland-class-file compiland) stream))))) From ehuelsmann at common-lisp.net Thu Jan 26 23:48:19 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Thu, 26 Jan 2012 15:48:19 -0800 Subject: [armedbear-cvs] r13811 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Thu Jan 26 15:48:18 2012 New Revision: 13811 Log: Performance improvement: Don't allocate a new environment and don't snapshot the special bindings on each call to a function with keyword arguments [which includes compiled functions!]. 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 Wed Jan 25 13:24:06 2012 (r13810) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Thu Jan 26 15:48:18 2012 (r13811) @@ -656,32 +656,14 @@ } } - protected final LispObject[] processArgs(LispObject[] args, LispThread thread) + + private LispObject[] _processArgs(LispObject[] args, LispThread thread, + Environment ext) { + final LispObject[] array = new LispObject[variables.length]; + int index = 0; - { - if (optionalParameters.length == 0 && keywordParameters.length == 0) - return fastProcessArgs(args); - final int argsLength = args.length; - if (arity >= 0) - { - // Fixed arity. - if (argsLength != arity) - error(new WrongNumberOfArgumentsException(this, arity)); - return args; - } - // Not fixed arity. - if (argsLength < minArgs) - error(new WrongNumberOfArgumentsException(this, minArgs, -1)); - final LispObject[] array = new LispObject[variables.length]; - int index = 0; - // The bindings established here (if any) are lost when this function - // returns. They are used only in the evaluation of initforms for - // optional and keyword arguments. - final SpecialBindingsMark mark = thread.markSpecialBindings(); - Environment ext = new Environment(environment); - // Section 3.4.4: "...the &environment parameter is bound along with - // &whole before any other variables in the lambda list..." - try { + int argsLength = args.length; + if (bindInitForms) if (envVar != null) bindArg(specials, envVar, environment, ext, thread); @@ -909,11 +891,41 @@ error(new WrongNumberOfArgumentsException(this)); } } + return array; + } + + protected final LispObject[] processArgs(LispObject[] args, LispThread thread) + + { + if (optionalParameters.length == 0 && keywordParameters.length == 0) + return fastProcessArgs(args); + if (arity >= 0) + { + // Fixed arity. + if (args.length != arity) + error(new WrongNumberOfArgumentsException(this, arity)); + return args; + } + // Not fixed arity. + if (args.length < minArgs) + error(new WrongNumberOfArgumentsException(this, minArgs, -1)); + + if (!bindInitForms) + return _processArgs(args, thread, environment); + + // The bindings established here (if any) are lost when this function + // returns. They are used only in the evaluation of initforms for + // optional and keyword arguments. + final SpecialBindingsMark mark = thread.markSpecialBindings(); + Environment ext = new Environment(environment); + // Section 3.4.4: "...the &environment parameter is bound along with + // &whole before any other variables in the lambda list..." + try { + return _processArgs(args, thread, ext); } finally { thread.resetSpecialBindings(mark); } - return array; } // No optional or keyword parameters. From mevenson at common-lisp.net Fri Jan 27 10:10:23 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 27 Jan 2012 02:10:23 -0800 Subject: [armedbear-cvs] r13812 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Fri Jan 27 02:10:22 2012 New Revision: 13812 Log: Correct README to indicate that JSS 3 has a namespace. Modified: trunk/abcl/contrib/jss/README.markdown Modified: trunk/abcl/contrib/jss/README.markdown ============================================================================== --- trunk/abcl/contrib/jss/README.markdown Thu Jan 26 15:48:18 2012 (r13811) +++ trunk/abcl/contrib/jss/README.markdown Fri Jan 27 02:10:22 2012 (r13812) @@ -17,8 +17,11 @@ Java methods look like this: #"toString". Java classes are represented as symbols, which are resolved to the appropriate java class -name. When ambiguous, you need to be more specific. A simple example: +name. When ambiguous, you need to be more specific. A simple example +from CL-USER: + (require 'jss) + (jss:ensure-compatibility (let ((sw (new 'StringWriter))) (#"write" sw "Hello ") (#"write" sw "World") @@ -94,7 +97,6 @@ (jcmn class-name) lists the names of all methods for the class - Compatibility ------------- @@ -109,3 +111,24 @@ Since we are no longer using Beanshell, this is no longer present. For obtaining the current classloader use JAVA:*CLASSLOADER*. +# API + + 1.0 + Equivalent to Alan Ruttenberg's version included with the original + [lsw](). + +[lsw]: http://mumble.net:8080/svn/lsw/trunk/ +[lsw2]: let-me-google-that-for-you + + + 3.0 + In the JSS package loaded from [abcl-contrib]() + +abcl-contrib: http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/ + +# Colophon + +<> dc:created "2005" ; + dc:author "Mark "; + revised: "27-JAN-2012" . + From mevenson at common-lisp.net Fri Jan 27 10:15:40 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Fri, 27 Jan 2012 02:15:40 -0800 Subject: [armedbear-cvs] r13813 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Fri Jan 27 02:15:39 2012 New Revision: 13813 Log: jss readme: Balance parenthesis. Normalize symbols to keywords. Modified: trunk/abcl/contrib/jss/README.markdown Modified: trunk/abcl/contrib/jss/README.markdown ============================================================================== --- trunk/abcl/contrib/jss/README.markdown Fri Jan 27 02:10:22 2012 (r13812) +++ trunk/abcl/contrib/jss/README.markdown Fri Jan 27 02:15:39 2012 (r13813) @@ -20,8 +20,8 @@ name. When ambiguous, you need to be more specific. A simple example from CL-USER: - (require 'jss) - (jss:ensure-compatibility + (require :jss) + (in-package :jss) (let ((sw (new 'StringWriter))) (#"write" sw "Hello ") (#"write" sw "World") From rschlatte at common-lisp.net Fri Jan 27 13:06:04 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 27 Jan 2012 05:06:04 -0800 Subject: [armedbear-cvs] r13814 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Fri Jan 27 05:06:03 2012 New Revision: 13814 Log: implement classes standard-method, standard-reader-method in Lisp Deleted: trunk/abcl/src/org/armedbear/lisp/StandardMethod.java trunk/abcl/src/org/armedbear/lisp/StandardMethodClass.java trunk/abcl/src/org/armedbear/lisp/StandardReaderMethod.java trunk/abcl/src/org/armedbear/lisp/StandardReaderMethodClass.java Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java trunk/abcl/src/org/armedbear/lisp/Profiler.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java trunk/abcl/src/org/armedbear/lisp/Symbol.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp trunk/abcl/src/org/armedbear/lisp/print-object.lisp trunk/abcl/src/org/armedbear/lisp/profiler.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Fri Jan 27 05:06:03 2012 (r13814) @@ -535,8 +535,6 @@ autoload(PACKAGE_JAVA, "dump-classpath", "JavaClassLoader"); autoload(PACKAGE_MOP, "eql-specializer-object", "EqualSpecializerObject", true); autoload(PACKAGE_MOP, "funcallable-instance-function", "FuncallableStandardObject", false); - autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true); - autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true); autoload(PACKAGE_MOP, "set-funcallable-instance-function", "FuncallableStandardObject", true); autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true); autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true); @@ -559,10 +557,6 @@ autoload(PACKAGE_SYS, "%make-socket", "make_socket"); autoload(PACKAGE_SYS, "%make-string", "StringFunctions"); autoload(PACKAGE_SYS, "%make-string-output-stream", "StringOutputStream"); - autoload(PACKAGE_SYS, "%method-fast-function", "StandardMethod", true); - autoload(PACKAGE_SYS, "%method-function", "StandardMethod", true); - autoload(PACKAGE_SYS, "%method-generic-function", "StandardMethod", true); - autoload(PACKAGE_SYS, "%method-specializers", "StandardMethod", true); autoload(PACKAGE_SYS, "%nstring-capitalize", "StringFunctions"); autoload(PACKAGE_SYS, "%nstring-downcase", "StringFunctions"); autoload(PACKAGE_SYS, "%nstring-upcase", "StringFunctions"); @@ -574,11 +568,6 @@ autoload(PACKAGE_SYS, "%set-generic-function-lambda-list", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-generic-function-name", "StandardGenericFunction", true); autoload(PACKAGE_SYS, "%set-gf-required-args", "StandardGenericFunction", true); - autoload(PACKAGE_SYS, "%set-method-fast-function", "StandardMethod", true); - autoload(PACKAGE_SYS, "%set-method-function", "StandardMethod", true); - autoload(PACKAGE_SYS, "%set-function-keywords", "StandardMethod", true); - autoload(PACKAGE_SYS, "%set-method-generic-function", "StandardMethod", true); - autoload(PACKAGE_SYS, "%set-method-specializers", "StandardMethod", true); autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives"); autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector"); autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc1", "SimpleBitVector"); @@ -637,7 +626,6 @@ autoload(PACKAGE_SYS, "float-nan-p", "FloatFunctions", true); autoload(PACKAGE_SYS, "float-string", "FloatFunctions", true); autoload(PACKAGE_SYS, "function-info", "function_info"); - autoload(PACKAGE_SYS, "%function-keywords", "StandardMethod", true); autoload(PACKAGE_SYS, "%generic-function-argument-precedence-order","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true); autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true); @@ -666,8 +654,6 @@ autoload(PACKAGE_SYS, "make-slot-definition", "SlotDefinition", true); autoload(PACKAGE_SYS, "make-structure-class", "StructureClass"); autoload(PACKAGE_SYS, "make-symbol-macro", "Primitives"); - autoload(PACKAGE_SYS, "method-documentation", "StandardMethod", true); - autoload(PACKAGE_SYS, "method-lambda-list", "StandardMethod", true); autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions"); autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); autoload(PACKAGE_SYS, "puthash", "HashTableFunctions"); @@ -680,9 +666,6 @@ autoload(PACKAGE_SYS, "set-generic-function-method-class","StandardGenericFunction", true); autoload(PACKAGE_SYS, "set-generic-function-method-combination","StandardGenericFunction", true); autoload(PACKAGE_SYS, "set-generic-function-methods","StandardGenericFunction", true); - autoload(PACKAGE_SYS, "set-method-documentation", "StandardMethod", true); - autoload(PACKAGE_SYS, "set-method-lambda-list", "StandardMethod", true); - autoload(PACKAGE_SYS, "set-method-qualifiers", "StandardMethod", true); autoload(PACKAGE_SYS, "set-slot-definition-allocation", "SlotDefinition", true); autoload(PACKAGE_SYS, "set-slot-definition-allocation-class", "SlotDefinition", true); autoload(PACKAGE_SYS, "set-slot-definition-initargs", "SlotDefinition", true); Modified: trunk/abcl/src/org/armedbear/lisp/Profiler.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Profiler.java Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/Profiler.java Fri Jan 27 05:06:03 2012 (r13814) @@ -71,13 +71,21 @@ if (object != null) { object.setCallCount(0); object.setHotCount(0); + LispObject methods = null; if (object instanceof StandardGenericFunction) { - LispObject methods = - PACKAGE_MOP.intern("GENERIC-FUNCTION-METHODS").execute(object); - while (methods != NIL) { - StandardMethod method = (StandardMethod) methods.car(); - method.getFunction().setCallCount(0); - method.getFunction().setHotCount(0); + methods = + Symbol.GENERIC_FUNCTION_METHODS.execute(object); + } + // TODO: extract methods from non-standard + // generic functions here once they are + // implemented + while (methods != null && methods != NIL) { + LispObject maybeMethod = methods.car(); + if (maybeMethod instanceof StandardObject) { + StandardObject method = (StandardObject) maybeMethod; + LispObject function = method.getInstanceSlotValue(Symbol.FUNCTION); + function.setCallCount(0); + function.setHotCount(0); methods = methods.cdr(); } } Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Jan 27 05:06:03 2012 (r13814) @@ -561,18 +561,16 @@ addStandardClass(Symbol.METHOD, list(METAOBJECT)); public static final StandardClass STANDARD_METHOD = - new StandardMethodClass(); - static - { - addClass(Symbol.STANDARD_METHOD, STANDARD_METHOD); - } + addStandardClass(Symbol.STANDARD_METHOD, list(METHOD)); + + public static final StandardClass STANDARD_ACCESSOR_METHOD = + addStandardClass(Symbol.STANDARD_ACCESSOR_METHOD, list(STANDARD_METHOD)); public static final StandardClass STANDARD_READER_METHOD = - new StandardReaderMethodClass(); - static - { - addClass(Symbol.STANDARD_READER_METHOD, STANDARD_READER_METHOD); - } + addStandardClass(Symbol.STANDARD_READER_METHOD, list(STANDARD_ACCESSOR_METHOD)); + + public static final StandardClass STANDARD_WRITER_METHOD = + addStandardClass(Symbol.STANDARD_WRITER_METHOD, list(STANDARD_ACCESSOR_METHOD)); public static final StandardClass STANDARD_GENERIC_FUNCTION = new StandardGenericFunctionClass(); @@ -677,6 +675,31 @@ EQL_SPECIALIZER.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT"))))); METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); + STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + STANDARD_METHOD.setDirectSlotDefinitions( + list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL), + new SlotDefinition(Symbol.LAMBDA_LIST, NIL), + new SlotDefinition(Symbol.KEYWORDS, NIL), + new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL), + new SlotDefinition(Symbol.SPECIALIZERS, NIL), + new SlotDefinition(Symbol.QUALIFIERS, NIL), + new SlotDefinition(Symbol.FUNCTION, NIL), + new SlotDefinition(Symbol.FAST_FUNCTION, NIL), + new SlotDefinition(Symbol.DOCUMENTATION, NIL))); + STANDARD_ACCESSOR_METHOD.setCPL(STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, + METHOD, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + STANDARD_ACCESSOR_METHOD.setDirectSlotDefinitions( + list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL))); + STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, + STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, + METHOD, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); + STANDARD_WRITER_METHOD.setCPL(STANDARD_WRITER_METHOD, + STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, + METHOD, METAOBJECT, STANDARD_OBJECT, + BuiltInClass.CLASS_T); METHOD_COMBINATION.setCPL(METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); METHOD_COMBINATION.setDirectSlotDefinitions( @@ -811,6 +834,11 @@ FLOATING_POINT_UNDERFLOW.finalizeClass(); JAVA_EXCEPTION.finalizeClass(); METAOBJECT.finalizeClass(); + METHOD.finalizeClass(); + STANDARD_METHOD.finalizeClass(); + STANDARD_ACCESSOR_METHOD.finalizeClass(); + STANDARD_READER_METHOD.finalizeClass(); + STANDARD_WRITER_METHOD.finalizeClass(); SPECIALIZER.finalizeClass(); EQL_SPECIALIZER.finalizeClass(); METHOD_COMBINATION.finalizeClass(); @@ -862,23 +890,6 @@ BuiltInClass.CLASS_T); STANDARD_EFFECTIVE_SLOT_DEFINITION.finalizeClass(); - // STANDARD-METHOD - Debug.assertTrue(STANDARD_METHOD.isFinalized()); - STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - STANDARD_METHOD.setDirectSlotDefinitions(STANDARD_METHOD.getClassLayout().generateSlotDefinitions()); - // There are no inherited slots. - STANDARD_METHOD.setSlotDefinitions(STANDARD_METHOD.getDirectSlotDefinitions()); - - // STANDARD-READER-METHOD - Debug.assertTrue(STANDARD_READER_METHOD.isFinalized()); - STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, STANDARD_METHOD, - METHOD, METAOBJECT, STANDARD_OBJECT, - BuiltInClass.CLASS_T); - STANDARD_READER_METHOD.setSlotDefinitions(STANDARD_READER_METHOD.getClassLayout().generateSlotDefinitions()); - // All but the last slot are inherited. - STANDARD_READER_METHOD.setDirectSlotDefinitions(list(STANDARD_READER_METHOD.getSlotDefinitions().reverse().car())); - // STANDARD-GENERIC-FUNCTION Debug.assertTrue(STANDARD_GENERIC_FUNCTION.isFinalized()); STANDARD_GENERIC_FUNCTION.setCPL(STANDARD_GENERIC_FUNCTION, Modified: trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java Fri Jan 27 05:06:03 2012 (r13814) @@ -71,8 +71,21 @@ numberOfRequiredArgs = lambdaList.length(); slots[StandardGenericFunctionClass.SLOT_INDEX_INITIAL_METHODS] = NIL; - StandardMethod method = - new StandardMethod(this, function, lambdaList, specializers); + StandardObject method + = (StandardObject)StandardClass.STANDARD_METHOD.allocateInstance(); + method.setInstanceSlotValue(Symbol.GENERIC_FUNCTION, this); + method.setInstanceSlotValue(Symbol.LAMBDA_LIST, lambdaList); + method.setInstanceSlotValue(Symbol.KEYWORDS, NIL); + method.setInstanceSlotValue(Symbol.OTHER_KEYWORDS_P, NIL); + method.setInstanceSlotValue(Symbol.SPECIALIZERS, specializers); + method.setInstanceSlotValue(Symbol.QUALIFIERS, NIL); + // Setting the function slot to nil is a transcription of what the + // constructor for StandardMethod instances did (that Java class was + // removed for the implementation of subclassable standard-method). + // (rudi 2012-01-27) + method.setInstanceSlotValue(Symbol.FUNCTION, NIL); + method.setInstanceSlotValue(Symbol.FAST_FUNCTION, function); + method.setInstanceSlotValue(Symbol.DOCUMENTATION, NIL); slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = list(method); slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] = Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Jan 27 05:06:03 2012 (r13814) @@ -2975,6 +2975,8 @@ PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-OBJECT"); public static final Symbol FUNCALLABLE_STANDARD_CLASS = PACKAGE_MOP.addExternalSymbol("FUNCALLABLE-STANDARD-CLASS"); + public static final Symbol GENERIC_FUNCTION_METHODS = + PACKAGE_MOP.addExternalSymbol("GENERIC-FUNCTION-METHODS"); public static final Symbol SHORT_METHOD_COMBINATION = PACKAGE_MOP.addInternalSymbol("SHORT-METHOD-COMBINATION"); public static final Symbol LONG_METHOD_COMBINATION = @@ -2983,8 +2985,12 @@ PACKAGE_MOP.addExternalSymbol("METAOBJECT"); public static final Symbol SPECIALIZER = PACKAGE_MOP.addExternalSymbol("SPECIALIZER"); + public static final Symbol STANDARD_ACCESSOR_METHOD = + PACKAGE_MOP.addExternalSymbol("STANDARD-ACCESSOR-METHOD"); public static final Symbol STANDARD_READER_METHOD = PACKAGE_MOP.addExternalSymbol("STANDARD-READER-METHOD"); + public static final Symbol STANDARD_WRITER_METHOD = + PACKAGE_MOP.addExternalSymbol("STANDARD-WRITER-METHOD"); public static final Symbol DIRECT_SLOT_DEFINITION = PACKAGE_MOP.addExternalSymbol("DIRECT-SLOT-DEFINITION"); public static final Symbol EFFECTIVE_SLOT_DEFINITION = @@ -3149,34 +3155,41 @@ PACKAGE_SYS.addInternalSymbol("DEFTYPE-DEFINITION"); public static final Symbol EXPECTED_TYPE = PACKAGE_SYS.addInternalSymbol("EXPECTED-TYPE"); + public static final Symbol FAST_FUNCTION = + PACKAGE_SYS.addInternalSymbol("FAST-FUNCTION"); public static final Symbol FORMAT_ARGUMENTS = PACKAGE_SYS.addInternalSymbol("FORMAT-ARGUMENTS"); public static final Symbol FORMAT_CONTROL = PACKAGE_SYS.addInternalSymbol("FORMAT-CONTROL"); - public static final Symbol FSET = - PACKAGE_SYS.addInternalSymbol("FSET"); + public static final Symbol FSET = PACKAGE_SYS.addInternalSymbol("FSET"); public static final Symbol FUNCTION_PRELOAD = PACKAGE_SYS.addInternalSymbol("FUNCTION-PRELOAD"); public static final Symbol INSTANCE = PACKAGE_SYS.addInternalSymbol("INSTANCE"); + public static final Symbol KEYWORDS = + PACKAGE_SYS.addInternalSymbol("KEYWORDS"); public static final Symbol MACROEXPAND_MACRO = PACKAGE_SYS.addInternalSymbol("MACROEXPAND-MACRO"); public static final Symbol MAKE_FUNCTION_PRELOADING_CONTEXT = PACKAGE_SYS.addInternalSymbol("MAKE-FUNCTION-PRELOADING-CONTEXT"); - public static final Symbol NAME = - PACKAGE_SYS.addInternalSymbol("NAME"); - public static final Symbol OBJECT = - PACKAGE_SYS.addInternalSymbol("OBJECT"); + public static final Symbol NAME = PACKAGE_SYS.addInternalSymbol("NAME"); + public static final Symbol OBJECT = PACKAGE_SYS.addInternalSymbol("OBJECT"); public static final Symbol OPERANDS = PACKAGE_SYS.addInternalSymbol("OPERANDS"); public static final Symbol OPERATION = PACKAGE_SYS.addInternalSymbol("OPERATION"); + public static final Symbol OTHER_KEYWORDS_P = + PACKAGE_SYS.addInternalSymbol("OTHER-KEYWORDS-P"); public static final Symbol PROXY_PRELOADED_FUNCTION = PACKAGE_SYS.addInternalSymbol("PROXY-PRELOADED-FUNCTION"); + public static final Symbol QUALIFIERS = + PACKAGE_SYS.addInternalSymbol("QUALIFIERS"); public static final Symbol _SOURCE = PACKAGE_SYS.addInternalSymbol("%SOURCE"); public static final Symbol SOCKET_STREAM = PACKAGE_SYS.addInternalSymbol("SOCKET-STREAM"); + public static final Symbol SPECIALIZERS = + PACKAGE_SYS.addInternalSymbol("SPECIALIZERS"); public static final Symbol STRING_INPUT_STREAM = PACKAGE_SYS.addInternalSymbol("STRING-INPUT-STREAM"); public static final Symbol STRING_OUTPUT_STREAM = Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Fri Jan 27 05:06:03 2012 (r13814) @@ -65,9 +65,13 @@ ;; ;; Some functionality implemented in the temporary regular functions ;; needs to be available later as a method definition to be dispatched -;; to for the STANDARD-CLASS case. To prevent repeated code, the -;; functions are implemented in functions by the same name as the -;; API functions, but with the STD- prefix. +;; to for the standard case, e.g. with arguments of type STANDARD-CLASS +;; or STANDARD-GENERIC-FUNCTION. To prevent repeated code, the +;; functions are implemented in functions by the same name as the API +;; functions, but with the STD- prefix. These functions are sometimes +;; used in regular code as well, either in a "fast path" or to break a +;; circularity (e.g., within compute-discriminating-function when the +;; user adds a method to compute-discriminating-function). ;; ;; When hacking this file, note that some important parts are implemented ;; in the Java world. These Java bits can be found in the files @@ -82,7 +86,7 @@ ;; * Layout.java ;; ;; In case of function names, those defined on the Java side can be -;; recognized by their prefixed percent sign. +;; recognized by their prefixed percent (%) sign. ;; ;; The API functions need to be declaimed NOTINLINE explicitly, because ;; that prevents inlining in the current FASL (which is allowed by the @@ -107,6 +111,8 @@ (find-class 'forward-referenced-class)) (defconstant +the-standard-reader-method-class+ (find-class 'standard-reader-method)) +(defconstant +the-standard-writer-method-class+ + (find-class 'standard-writer-method)) (defconstant +the-standard-generic-function-class+ (find-class 'standard-generic-function)) (defconstant +the-T-class+ (find-class 'T)) @@ -164,7 +170,7 @@ args)) (defun function-keywords (method) - (%function-keywords method)) + (std-function-keywords method)) @@ -739,7 +745,7 @@ (setf (class-direct-slots class) slots) (dolist (direct-slot slots) (dolist (reader (slot-definition-readers direct-slot)) - (add-reader-method class reader (slot-definition-name direct-slot))) + (add-reader-method class reader direct-slot)) (dolist (writer (slot-definition-writers direct-slot)) (add-writer-method class writer (slot-definition-name direct-slot))))) (setf (class-direct-default-initargs class) direct-default-initargs) @@ -1004,7 +1010,7 @@ ,(wrap-with-call-method-macro ,gf ',args-var (second method))))) - (t (%method-function method))) + (t (method-function method))) ,',args-var ,(unless (null next-method-list) ;; by not generating an emf when there are no next methods, @@ -1181,6 +1187,49 @@ (check-type eql-specializer eql-specializer) (std-slot-value eql-specializer 'sys::object)) +;;; Initial versions of some method metaobject readers. Defined on +;;; AMOP pg. 218ff, will be redefined when generic functions are set up. + +(defun std-method-function (method) + (std-slot-value method 'cl:function)) + +(defun std-method-generic-function (method) + (std-slot-value method 'cl:generic-function)) + +(defun std-method-specializers (method) + (std-slot-value method 'sys::specializers)) + +(defun std-method-qualifiers (method) + (std-slot-value method 'sys::qualifiers)) + +(defun std-accessor-method-slot-definition (accessor-method) + (std-slot-value accessor-method 'sys:slot-definition)) + +;;; Additional method readers +(defun std-method-fast-function (method) + (std-slot-value method 'sys::fast-function)) + +(defun std-function-keywords (method) + (values (std-slot-value method 'sys::keywords) + (std-slot-value method 'sys::other-keywords-p))) + +;;; Preliminary accessor definitions, will be redefined as generic +;;; functions later in this file + +(declaim (notinline method-generic-function)) +(defun method-generic-function (method) + (std-method-generic-function method)) + +(declaim (notinline method-specializers)) +(defun method-specializers (method) + (std-method-specializers method)) + +(declaim (notinline method-qualifiers)) +(defun method-qualifiers (method) + (std-method-qualifiers method)) + + + ;; MOP (p. 216) specifies the following reader generic functions: ;; generic-function-argument-precedence-order ;; generic-function-declarations @@ -1231,13 +1280,16 @@ (set-generic-function-classes-to-emf-table gf new-value)) (defun (setf method-lambda-list) (new-value method) - (set-method-lambda-list method new-value)) + (setf (std-slot-value method 'sys::lambda-list) new-value)) (defun (setf method-qualifiers) (new-value method) - (set-method-qualifiers method new-value)) + (setf (std-slot-value method 'sys::qualifiers) new-value)) + +(defun method-documentation (method) + (std-slot-value method 'documentation)) (defun (setf method-documentation) (new-value method) - (set-method-documentation method new-value)) + (setf (std-slot-value method 'documentation) new-value)) ;;; defgeneric @@ -1403,7 +1455,7 @@ (defun collect-eql-specializer-objects (generic-function) (let ((result nil)) (dolist (method (generic-function-methods generic-function)) - (dolist (specializer (%method-specializers method)) + (dolist (specializer (method-specializers method)) (when (typep specializer 'eql-specializer) (pushnew (eql-specializer-object specializer) result @@ -1710,33 +1762,33 @@ fast-function) (declare (ignore gf)) (let ((method (std-allocate-instance +the-standard-method-class+)) - (analyzed-args (analyze-lambda-list lambda-list)) - ) + (analyzed-args (analyze-lambda-list lambda-list))) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) - (%set-method-specializers method (canonicalize-specializers specializers)) + (setf (std-slot-value method 'sys::specializers) + (canonicalize-specializers specializers)) (setf (method-documentation method) documentation) - (%set-method-generic-function method nil) - (%set-method-function method function) - (%set-method-fast-function method fast-function) - (%set-function-keywords method - (getf analyzed-args :keywords) - (getf analyzed-args :allow-other-keys)) + (setf (std-slot-value method 'generic-function) nil) ; set by add-method + (setf (std-slot-value method 'function) function) + (setf (std-slot-value method 'sys::fast-function) fast-function) + (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords)) + (setf (std-slot-value method 'sys::other-keywords-p) + (getf analyzed-args :allow-other-keys)) method)) (defun std-add-method (gf method) - (when (%method-generic-function method) + (when (method-generic-function method) (error 'simple-error - :format-control "ADD-METHOD: ~S is a method of ~S." - :format-arguments (list method (%method-generic-function method)))) + :format-control "ADD-METHOD: ~S is already a method of ~S." + :format-arguments (list method (method-generic-function method)))) ;; Remove existing method with same qualifiers and specializers (if any). - (let ((old-method (%find-method gf (method-qualifiers method) - (%method-specializers method) nil))) + (let ((old-method (%find-method gf (std-method-qualifiers method) + (method-specializers method) nil))) (when old-method (std-remove-method gf old-method))) - (%set-method-generic-function method gf) + (setf (std-slot-value method 'generic-function) gf) (push method (generic-function-methods gf)) - (dolist (specializer (%method-specializers method)) + (dolist (specializer (method-specializers method)) (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? (pushnew method (class-direct-methods specializer)))) (finalize-standard-generic-function gf) @@ -1745,8 +1797,8 @@ (defun std-remove-method (gf method) (setf (generic-function-methods gf) (remove method (generic-function-methods gf))) - (%set-method-generic-function method nil) - (dolist (specializer (%method-specializers method)) + (setf (std-slot-value method 'generic-function) gf) + (dolist (specializer (method-specializers method)) (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? (setf (class-direct-methods specializer) (remove method (class-direct-methods specializer))))) @@ -1768,7 +1820,7 @@ (and (equal qualifiers (method-qualifiers method)) (equal canonical-specializers - (%method-specializers method)))) + (method-specializers method)))) (generic-function-methods gf)))) (if (and (null method) errorp) (error "No such method for ~S." (%generic-function-name gf)) @@ -1791,12 +1843,14 @@ ;; In this function, we know that gf is of class ;; standard-generic-function, so we call various ;; sys:%generic-function-foo readers to break circularities. + ;; (rudi 2012-01-27): maybe we need to discriminate between + ;; standard-methods and methods as well. (cond ((and (= (length (sys:%generic-function-methods gf)) 1) (typep (car (sys:%generic-function-methods gf)) 'standard-reader-method)) (let* ((method (%car (sys:%generic-function-methods gf))) - (class (car (%method-specializers method))) - (slot-name (reader-method-slot-name method))) + (class (car (std-method-specializers method))) + (slot-name (slot-definition-name (accessor-method-slot-definition method)))) #'(lambda (arg) (declare (optimize speed)) (let* ((layout (std-instance-layout arg)) @@ -1827,9 +1881,9 @@ ((and (eq (sys:%generic-function-method-combination gf) 'standard) (= (length (sys:%generic-function-methods gf)) 1)) (let* ((method (%car (sys:%generic-function-methods gf))) - (specializer (car (%method-specializers method))) - (function (or (%method-fast-function method) - (%method-function method)))) + (specializer (car (std-method-specializers method))) + (function (or (std-method-fast-function method) + (std-method-function method)))) (if (typep specializer 'eql-specializer) (let ((specializer-object (eql-specializer-object specializer))) #'(lambda (arg) @@ -1885,8 +1939,8 @@ (if emfun (funcall emfun args) (slow-method-lookup gf args)))))) -;; (let ((non-key-args (+ number-required -;; (length (gf-optional-args gf)))))) + ;; (let ((non-key-args (+ number-required + ;; (length (gf-optional-args gf)))))) #'(lambda (&rest args) (declare (optimize speed)) (let ((len (length args))) @@ -1911,7 +1965,7 @@ (method-more-specific-p gf m1 m2 required-classes)))))) (defun method-applicable-p (method args) - (do* ((specializers (%method-specializers method) (cdr specializers)) + (do* ((specializers (method-specializers method) (cdr specializers)) (args args (cdr args))) ((null specializers) t) (let ((specializer (car specializers))) @@ -1939,7 +1993,7 @@ ;;; the classes of its arguments only. ;;; (defun method-applicable-using-classes-p (method classes) - (do* ((specializers (%method-specializers method) (cdr specializers)) + (do* ((specializers (method-specializers method) (cdr specializers)) (classes classes (cdr classes)) (knownp t)) ((null specializers) @@ -2039,8 +2093,8 @@ (defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order) (if argument-precedence-order - (let ((specializers-1 (%method-specializers method1)) - (specializers-2 (%method-specializers method2))) + (let ((specializers-1 (std-method-specializers method1)) + (specializers-2 (std-method-specializers method2))) (dolist (index argument-precedence-order) (let ((spec1 (nth index specializers-1)) (spec2 (nth index specializers-2))) @@ -2052,8 +2106,8 @@ (t (return (sub-specializer-p spec1 spec2 (nth index required-classes))))))))) - (do ((specializers-1 (%method-specializers method1) (cdr specializers-1)) - (specializers-2 (%method-specializers method2) (cdr specializers-2)) + (do ((specializers-1 (std-method-specializers method1) (cdr specializers-1)) + (specializers-2 (std-method-specializers method2) (cdr specializers-2)) (classes required-classes (cdr classes))) ((null specializers-1) nil) (let ((spec1 (car specializers-1)) @@ -2136,7 +2190,7 @@ #'compute-effective-method-function) gf (remove around methods)))) (setf emf-form - (generate-emf-lambda (%method-function around) next-emfun)))) + (generate-emf-lambda (std-method-function around) next-emfun)))) ((eq mc-name 'standard) (let* ((next-emfun (compute-primary-emfun (cdr primaries))) (befores (remove-if-not #'before-method-p methods)) @@ -2145,7 +2199,7 @@ (setf emf-form (cond ((and (null befores) (null reverse-afters)) - (let ((fast-function (%method-fast-function (car primaries)))) + (let ((fast-function (std-method-fast-function (car primaries)))) (if fast-function (ecase (length (gf-required-args gf)) (1 @@ -2156,18 +2210,18 @@ #'(lambda (args) (declare (optimize speed)) (funcall fast-function (car args) (cadr args))))) - (generate-emf-lambda (%method-function (car primaries)) + (generate-emf-lambda (std-method-function (car primaries)) next-emfun)))) (t - (let ((method-function (%method-function (car primaries)))) + (let ((method-function (std-method-function (car primaries)))) #'(lambda (args) (declare (optimize speed)) (dolist (before befores) - (funcall (%method-function before) args nil)) + (funcall (std-method-function before) args nil)) (multiple-value-prog1 (funcall method-function args next-emfun) (dolist (after reverse-afters) - (funcall (%method-function after) args nil)))))))))) + (funcall (std-method-function after) args nil)))))))))) (long-method-combination-p (let* ((mc-obj (get mc-name 'method-combination-object)) (function (long-method-combination-function mc-obj)) @@ -2188,11 +2242,11 @@ (setf emf-form (if (and (null (cdr primaries)) (not (null ioa))) - (generate-emf-lambda (%method-function (car primaries)) nil) + (generate-emf-lambda (std-method-function (car primaries)) nil) `(lambda (args) (,operator ,@(mapcar (lambda (primary) - `(funcall ,(%method-function primary) args nil)) + `(funcall ,(std-method-function primary) args nil)) primaries))))))))) (assert (not (null emf-form))) (or #+nil (ignore-errors (autocompile emf-form)) @@ -2210,7 +2264,7 @@ nil (let ((next-emfun (compute-primary-emfun (cdr methods)))) #'(lambda (args) - (funcall (%method-function (car methods)) args next-emfun))))) + (funcall (std-method-function (car methods)) args next-emfun))))) (defvar *call-next-method-p*) (defvar *next-method-p-p*) @@ -2381,48 +2435,72 @@ documentation function fast-function - slot-name) + slot-definition) (declare (ignore gf)) (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)) + (setf (std-slot-value method 'sys::specializers) + (canonicalize-specializers specializers)) (setf (method-documentation method) documentation) - (%set-method-generic-function method nil) - (%set-method-function method function) - (%set-method-fast-function method fast-function) - (set-reader-method-slot-name method slot-name) - (%set-function-keywords method nil nil) + (setf (std-slot-value method 'generic-function) nil) + (setf (std-slot-value method 'function) function) + (setf (std-slot-value method 'sys::fast-function) fast-function) + (setf (std-slot-value method 'sys:slot-definition) slot-definition) + (setf (std-slot-value method 'sys::keywords) nil) + (setf (std-slot-value method 'sys::other-keywords-p) nil) method)) -(defun add-reader-method (class function-name slot-name) - (let* ((lambda-expression +(defun add-reader-method (class function-name slot-definition) + (let* ((method-class (if (eq (class-of class) +the-standard-class+) + +the-standard-reader-method-class+ + (reader-method-class class))) + (slot-name (slot-definition-name slot-definition)) + (lambda-expression (if (eq (class-of class) +the-standard-class+) `(lambda (object) (std-slot-value object ',slot-name)) `(lambda (object) (slot-value object ',slot-name)))) (method-function (compute-method-function lambda-expression)) - (fast-function (compute-method-fast-function lambda-expression))) - (let ((method-lambda-list '(object)) - (gf (find-generic-function function-name nil))) - (if gf - (check-method-lambda-list function-name - method-lambda-list - (generic-function-lambda-list gf)) - (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list))) - (let ((method - (make-instance-standard-reader-method gf - :lambda-list '(object) - :qualifiers () - :specializers (list class) - :function (if (autoloadp 'compile) - method-function - (autocompile method-function)) - :fast-function (if (autoloadp 'compile) - fast-function - (autocompile fast-function)) - :slot-name slot-name))) - (std-add-method gf method) - method)))) + (fast-function (compute-method-fast-function lambda-expression)) + (method-lambda-list '(object)) + (gf (find-generic-function function-name nil))) + ;; required by AMOP pg. 225 + (assert (subtypep method-class +the-standard-reader-method-class+)) + (if gf + (check-method-lambda-list function-name + method-lambda-list + (generic-function-lambda-list gf)) + (setf gf (ensure-generic-function function-name + :lambda-list method-lambda-list))) + (let ((method + (if (eq method-class +the-standard-reader-method-class+) + (make-instance-standard-reader-method + gf + :lambda-list method-lambda-list + :qualifiers () + :specializers (list class) + :function (if (autoloadp 'compile) + method-function + (autocompile method-function)) + :fast-function (if (autoloadp 'compile) + fast-function + (autocompile fast-function)) + :slot-definition slot-definition) + (make-instance method-class + :lambda-list method-lambda-list + :qualifiers () + :specializers (list class) + :function (if (autoloadp 'compile) + method-function + (autocompile method-function)) + :fast-function (if (autoloadp 'compile) + fast-function + (autocompile fast-function)) + :slot-definition slot-definition)))) + (if (eq (class-of gf) +the-standard-generic-function-class+) + (std-add-method gf method) + (add-method gf method)) + method))) (defun add-writer-method (class function-name slot-name) (let* ((lambda-expression @@ -2649,19 +2727,35 @@ ,@(canonicalize-defclass-options options))) - +;;; AMOP pg. 180 (defgeneric direct-slot-definition-class (class &rest initargs)) (defmethod direct-slot-definition-class ((class class) &rest initargs) (declare (ignore initargs)) +the-standard-direct-slot-definition-class+) +;;; AMOP pg. 181 (defgeneric effective-slot-definition-class (class &rest initargs)) (defmethod effective-slot-definition-class ((class class) &rest initargs) (declare (ignore initargs)) +the-standard-effective-slot-definition-class+) +;;; AMOP pg. 224 +(defgeneric reader-method-class (class direct-slot &rest initargs)) + +(defmethod reader-method-class ((class standard-class) + (direct-slot standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + +the-standard-reader-method-class+) + +(defmethod reader-method-class ((class funcallable-standard-class) + (direct-slot standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + +the-standard-reader-method-class+) + (atomic-defgeneric documentation (x doc-type) (:method ((x symbol) doc-type) (%documentation x doc-type)) @@ -3502,7 +3596,7 @@ (atomic-defgeneric function-keywords (method) (:method ((method standard-method)) - (%function-keywords method))) + (std-function-keywords method))) (setf *gf-initialize-instance* (symbol-function 'initialize-instance)) (setf *gf-allocate-instance* (symbol-function 'allocate-instance)) @@ -3556,6 +3650,34 @@ (:method ((generic-function standard-generic-function)) (sys:%generic-function-name generic-function))) +;;; Readers for Method Metaobjects +;;; AMOP pg. 218ff. + +(atomic-defgeneric method-function (method) + (:method ((method standard-method)) + (std-method-function method))) + +(atomic-defgeneric method-generic-function (method) + (:method ((method standard-method)) + (std-method-generic-function method))) + +(atomic-defgeneric method-lambda-list (method) + (:method ((method standard-method)) + (std-slot-value method 'sys::lambda-list))) + +(atomic-defgeneric method-specializers (method) + (:method ((method standard-method)) + (std-method-specializers method))) + +(atomic-defgeneric method-qualifiers (method) + (:method ((method standard-method)) + (std-method-qualifiers method))) + +(atomic-defgeneric accessor-method-slot-definition (method) + (:method ((method standard-accessor-method)) + (std-accessor-method-slot-definition method))) + + (eval-when (:compile-toplevel :load-toplevel :execute) (require "MOP")) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Fri Jan 27 05:06:03 2012 (r13814) @@ -57,6 +57,9 @@ standard-method method-function + method-specializers + method-generic-function + standard-accessor-method standard-reader-method standard-writer-method Modified: trunk/abcl/src/org/armedbear/lisp/print-object.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/print-object.lisp Fri Jan 27 05:06:03 2012 (r13814) @@ -55,25 +55,25 @@ (class-name class))) class) -(defmethod print-object ((gf standard-generic-function) stream) +(defmethod print-object ((gf generic-function) stream) (print-unreadable-object (gf stream :identity t) (format stream "~S ~S" (class-name (class-of gf)) - (%generic-function-name gf))) + (mop:generic-function-name gf))) gf) -(defmethod print-object ((method standard-method) stream) +(defmethod print-object ((method method) stream) (print-unreadable-object (method stream :identity t) (format stream "~S ~S~{ ~S~} ~S" (class-name (class-of method)) - (%generic-function-name - (%method-generic-function method)) + (mop:generic-function-name + (mop:method-generic-function method)) (method-qualifiers method) (mapcar #'(lambda (c) - (if (typep c 'mop::eql-specializer) - `(eql ,(mop::eql-specializer-object c)) + (if (typep c 'mop:eql-specializer) + `(eql ,(mop:eql-specializer-object c)) (class-name c))) - (%method-specializers method)))) + (mop:method-specializers method)))) method) (defmethod print-object ((restart restart) stream) Modified: trunk/abcl/src/org/armedbear/lisp/profiler.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/profiler.lisp Fri Jan 27 02:15:39 2012 (r13813) +++ trunk/abcl/src/org/armedbear/lisp/profiler.lisp Fri Jan 27 05:06:03 2012 (r13814) @@ -67,7 +67,7 @@ full-count hot-count) result) (dolist (method (mop::generic-function-methods definition)) - (let ((function (sys:%method-function method))) + (let ((function (mop:method-function method))) (setf full-count (sys:call-count function)) (setf hot-count (sys:hot-count function))) (unless (zerop full-count) @@ -82,17 +82,17 @@ (cond ((symbolp object) object) ((typep object 'generic-function) - (sys:%generic-function-name object)) + (mop:generic-function-name object)) ((typep object 'method) (list 'METHOD - (sys:%generic-function-name (sys:%method-generic-function object)) - (sys:%method-specializers object))))) + (mop:generic-function-name (mop:method-generic-function object)) + (mop:method-specializers object))))) (defun object-compiled-function-p (object) (cond ((symbolp object) (compiled-function-p (fdefinition object))) ((typep object 'method) - (compiled-function-p (sys:%method-function object))) + (compiled-function-p (mop:method-function object))) (t (compiled-function-p object)))) From rschlatte at common-lisp.net Fri Jan 27 14:53:24 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Fri, 27 Jan 2012 06:53:24 -0800 Subject: [armedbear-cvs] r13815 - trunk/abcl/doc/manual Message-ID: Author: rschlatte Date: Fri Jan 27 06:53:23 2012 New Revision: 13815 Log: Minor manual prettification. Modified: trunk/abcl/doc/manual/abcl.sty trunk/abcl/doc/manual/abcl.tex Modified: trunk/abcl/doc/manual/abcl.sty ============================================================================== --- trunk/abcl/doc/manual/abcl.sty Fri Jan 27 05:06:03 2012 (r13814) +++ trunk/abcl/doc/manual/abcl.sty Fri Jan 27 06:53:23 2012 (r13815) @@ -20,16 +20,16 @@ \lstnewenvironment{listing-java} - {\lstset{language=Java}} + {\lstset{basicstyle=\ttfamily,language=Java}} {} \lstnewenvironment{listing-lisp} - {\lstset{language=Lisp}} + {\lstset{basicstyle=\ttfamily,language=Lisp}} {} \lstnewenvironment{listing-shell} - {\lstset{language=sh}} + {\lstset{basicstyle=\ttfamily,language=sh}} {} \usepackage{verbatim} Modified: trunk/abcl/doc/manual/abcl.tex ============================================================================== --- trunk/abcl/doc/manual/abcl.tex Fri Jan 27 05:06:03 2012 (r13814) +++ trunk/abcl/doc/manual/abcl.tex Fri Jan 27 06:53:23 2012 (r13815) @@ -218,7 +218,7 @@ We define a higher level Java API in the topic:Higher level Java JSS package developed by Alan Ruttenberg which is available in the \code{contrib/} directory, see the . This package is -described later in this document, see \ref{section:jss} on page +described later in this document, see Section~\ref{section:jss} on page \pageref{section:jss}. This section covers the lower level API directly available after evaluating \code{(require 'JAVA)}. @@ -1004,12 +1004,11 @@ abstraction for handling logging systems: \begin{listing-lisp} - ;;;; -*- Mode: LISP -*- - (in-package :asdf) +;;;; -*- Mode: LISP -*- +(in-package :asdf) - (defsystem :log4j - :components ((:mvn "log4j/log4j" - :version "1.4.9"))) +(defsystem :log4j + :components ((:mvn "log4j/log4j" :version "1.4.9"))) \end{listing-lisp} \subsection{API} @@ -1036,16 +1035,23 @@ artifacts to be downloaded \begin{listing-lisp} -CL-USER> (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user") +CL-USER> (abcl-asdf:resolve-dependencies "com.google.gwt" + "gwt-user") WARNING: Using LATEST for unspecified version. -"/Users/evenson/.m2/repository/com/google/gwt/gwt-user/2.4.0-rc1/gwt-user-2.4.0-rc1.jar:/Users/evenson/.m2/repository/javax/validation/validation-api/1.0.0.GA/validation-api-1.0.0.GA.jar:/Users/evenson/.m2/repository/javax/validation/validation-api/1.0.0.GA/validation-api-1.0.0.GA-sources.jar" +"/Users/evenson/.m2/repository/com/google/gwt/gwt-user/2.4.0-rc1 +/gwt-user-2.4.0-rc1.jar:/Users/evenson/.m2/repository/javax/vali +dation/validation-api/1.0.0.GA/validation-api-1.0.0.GA.jar:/User +s/evenson/.m2/repository/javax/validation/validation-api/1.0.0.G +A/validation-api-1.0.0.GA-sources.jar" \end{listing-lisp} To actually load the dependency, use the \code{JAVA:ADD-TO-CLASSPATH} generic function: \begin{listing-lisp} -CL-USER> (java:add-to-classpath (abcl-asdf:resolve-dependencies "com.google.gwt" "gwt-user")) +CL-USER> (java:add-to-classpath + (abcl-asdf:resolve-dependencies "com.google.gwt" + "gwt-user")) \end{listing-lisp} Notice that all recursive dependencies have been located and installed @@ -1058,7 +1064,8 @@ systems the code in this package will recursively package all the required source and fasls in a jar archive. -See \url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown}. +The documentation for this contrib can be found at +\url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/asdf-jar/README.markdown}. \section{jss} @@ -1076,15 +1083,17 @@ Example: \begin{listing-lisp} - +CL-USER> (require 'abcl-contrib) +==> ("ABCL-CONTRIB") CL-USER> (require 'jss) - +==> ("JSS") CL-USER) (#"getProperties" 'java.lang.System) - +==> # CL-USER) (#"propertyNames" (#"getProperties" 'java.lang.System)) +==> # +\end{listing-lisp} %$ <-- un-confuse Emacs font-lock -\end{listing-lisp} - +Some more information on jss can be found in its documentation at \url{http://svn.common-lisp.net/armedbear/trunk/abcl/contrib/jss/README.markdown} \section{asdf-install} From rschlatte at common-lisp.net Sat Jan 28 09:54:59 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 28 Jan 2012 01:54:59 -0800 Subject: [armedbear-cvs] r13816 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 28 01:54:58 2012 New Revision: 13816 Log: Re-add some old-style readers for SLIME's benefit. 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 Fri Jan 27 06:53:23 2012 (r13815) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 28 01:54:58 2012 (r13816) @@ -3677,6 +3677,13 @@ (:method ((method standard-accessor-method)) (std-accessor-method-slot-definition method))) +;;; SLIME compatibility functions. + +(defun %method-generic-function (method) + (method-generic-function method)) + +(defun %method-function (method) + (method-function method)) (eval-when (:compile-toplevel :load-toplevel :execute) (require "MOP")) From rschlatte at common-lisp.net Sat Jan 28 14:23:52 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 28 Jan 2012 06:23:52 -0800 Subject: [armedbear-cvs] r13817 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 28 06:23:51 2012 New Revision: 13817 Log: Implement writer-method-class. ... Bonus content: make non-standard reader method classes actually work. Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 28 01:54:58 2012 (r13816) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 28 06:23:51 2012 (r13817) @@ -747,7 +747,7 @@ (dolist (reader (slot-definition-readers direct-slot)) (add-reader-method class reader direct-slot)) (dolist (writer (slot-definition-writers direct-slot)) - (add-writer-method class writer (slot-definition-name direct-slot))))) + (add-writer-method class writer direct-slot)))) (setf (class-direct-default-initargs class) direct-default-initargs) (maybe-finalize-class-subtree class) (values)) @@ -2427,17 +2427,16 @@ ;;; Reader and writer methods -(defun make-instance-standard-reader-method (gf - &key - lambda-list - qualifiers - specializers - documentation - function - fast-function - slot-definition) - (declare (ignore gf)) - (let ((method (std-allocate-instance +the-standard-reader-method-class+))) +(defun make-instance-standard-accessor-method (method-class + &key + lambda-list + qualifiers + specializers + documentation + function + fast-function + slot-definition) + (let ((method (std-allocate-instance method-class))) (setf (method-lambda-list method) lambda-list) (setf (method-qualifiers method) qualifiers) (setf (std-slot-value method 'sys::specializers) @@ -2452,10 +2451,7 @@ method)) (defun add-reader-method (class function-name slot-definition) - (let* ((method-class (if (eq (class-of class) +the-standard-class+) - +the-standard-reader-method-class+ - (reader-method-class class))) - (slot-name (slot-definition-name slot-definition)) + (let* ((slot-name (slot-definition-name slot-definition)) (lambda-expression (if (eq (class-of class) +the-standard-class+) `(lambda (object) (std-slot-value object ',slot-name)) @@ -2463,7 +2459,21 @@ (method-function (compute-method-function lambda-expression)) (fast-function (compute-method-fast-function lambda-expression)) (method-lambda-list '(object)) - (gf (find-generic-function function-name nil))) + (gf (find-generic-function function-name nil)) + (initargs `(:lambda-list ,method-lambda-list + :qualifiers () + :specializers (,class) + :function ,(if (autoloadp 'compile) + method-function + (autocompile method-function)) + :fast-function ,(if (autoloadp 'compile) + fast-function + (autocompile fast-function)) + :slot-definition ,slot-definition)) + (method-class (if (eq class +the-standard-class+) + +the-standard-reader-method-class+ + (apply #'reader-method-class class slot-definition + initargs)))) ;; required by AMOP pg. 225 (assert (subtypep method-class +the-standard-reader-method-class+)) (if gf @@ -2474,36 +2484,19 @@ :lambda-list method-lambda-list))) (let ((method (if (eq method-class +the-standard-reader-method-class+) - (make-instance-standard-reader-method - gf - :lambda-list method-lambda-list - :qualifiers () - :specializers (list class) - :function (if (autoloadp 'compile) - method-function - (autocompile method-function)) - :fast-function (if (autoloadp 'compile) - fast-function - (autocompile fast-function)) - :slot-definition slot-definition) - (make-instance method-class - :lambda-list method-lambda-list - :qualifiers () - :specializers (list class) - :function (if (autoloadp 'compile) - method-function - (autocompile method-function)) - :fast-function (if (autoloadp 'compile) - fast-function - (autocompile fast-function)) - :slot-definition slot-definition)))) + (apply #'make-instance-standard-accessor-method method-class + initargs) + (apply #'make-instance method-class + :generic-function nil ; handled by add-method + initargs)))) (if (eq (class-of gf) +the-standard-generic-function-class+) (std-add-method gf method) (add-method gf method)) method))) -(defun add-writer-method (class function-name slot-name) - (let* ((lambda-expression +(defun add-writer-method (class function-name slot-definition) + (let* ((slot-name (slot-definition-name slot-definition)) + (lambda-expression (if (eq (class-of class) +the-standard-class+) `(lambda (new-value object) (setf (std-slot-value object ',slot-name) new-value)) @@ -2511,19 +2504,40 @@ (setf (slot-value object ',slot-name) new-value)))) (method-function (compute-method-function lambda-expression)) (fast-function (compute-method-fast-function lambda-expression)) - ) - (ensure-method function-name - :lambda-list '(new-value object) - :qualifiers () - :specializers (list +the-T-class+ class) -;; :function `(function ,method-function) - :function (if (autoloadp 'compile) - method-function - (autocompile method-function)) - :fast-function (if (autoloadp 'compile) - fast-function - (autocompile fast-function)) - ))) + (method-lambda-list '(new-value object)) + (gf (find-generic-function function-name nil)) + (initargs `(:lambda-list ,method-lambda-list + :qualifiers () + :specializers (,+the-T-class+ ,class) + :function ,(if (autoloadp 'compile) + method-function + (autocompile method-function)) + :fast-function ,(if (autoloadp 'compile) + fast-function + (autocompile fast-function)))) + (method-class (if (eq class +the-standard-class+) + +the-standard-writer-method-class+ + (apply #'writer-method-class class slot-definition + initargs)))) + ;; required by AMOP pg. 242 + (assert (subtypep method-class +the-standard-writer-method-class+)) + (if gf + (check-method-lambda-list function-name + method-lambda-list + (generic-function-lambda-list gf)) + (setf gf (ensure-generic-function function-name + :lambda-list method-lambda-list))) + (let ((method + (if (eq method-class +the-standard-writer-method-class+) + (apply #'make-instance-standard-accessor-method method-class + initargs) + (apply #'make-instance method-class + :generic-function nil ; handled by add-method + initargs)))) + (if (eq (class-of gf) +the-standard-generic-function-class+) + (std-add-method gf method) + (add-method gf method)) + method))) (defmacro atomic-defgeneric (function-name &rest rest) "Macro to define a generic function and 'swap it into place' after @@ -2756,6 +2770,21 @@ (declare (ignore initargs)) +the-standard-reader-method-class+) +;;; AMOP pg. 242 +(defgeneric writer-method-class (class direct-slot &rest initargs)) + +(defmethod writer-method-class ((class standard-class) + (direct-slot standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + +the-standard-writer-method-class+) + +(defmethod writer-method-class ((class funcallable-standard-class) + (direct-slot standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + +the-standard-writer-method-class+) + (atomic-defgeneric documentation (x doc-type) (:method ((x symbol) doc-type) (%documentation x doc-type)) @@ -3563,7 +3592,8 @@ args))) - +;;; FIXME (rudi 2012-01-28): this can be a function, it only needs to +;;; use standard accessor functions (defgeneric find-method (generic-function qualifiers specializers @@ -3573,6 +3603,11 @@ qualifiers specializers &optional (errorp t)) (%find-method generic-function qualifiers specializers errorp)) +(defgeneric find-method ((generic-function symbol) + qualifiers specializers &optional (errorp t)) + (find-method (find-generic-function generic-function errorp) + qualifiers specializers errorp)) + (defgeneric add-method (generic-function method)) (defmethod add-method ((generic-function standard-generic-function) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jan 28 01:54:58 2012 (r13816) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Sat Jan 28 06:23:51 2012 (r13817) @@ -28,12 +28,17 @@ (and (eql (class-name class) 'funcallable-standard-class) (eql (class-name superclass) 'standard-class))))) -(export '(funcallable-standard-object +(export '(;; classes + funcallable-standard-object funcallable-standard-class forward-referenced-class - validate-superclass direct-slot-definition-class effective-slot-definition-class + standard-method + standard-accessor-method + standard-reader-method + standard-writer-method + compute-effective-slot-definition compute-class-precedence-list compute-effective-slot-definition @@ -41,6 +46,7 @@ finalize-inheritance slot-boundp-using-class slot-makunbound-using-class + validate-superclass ensure-class ensure-class-using-class @@ -55,14 +61,13 @@ generic-function-lambda-list - standard-method method-function method-specializers method-generic-function - - standard-accessor-method standard-reader-method standard-writer-method + reader-method-class + writer-method-class slot-definition slot-definition-readers From rschlatte at common-lisp.net Sat Jan 28 16:34:47 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 28 Jan 2012 08:34:47 -0800 Subject: [armedbear-cvs] r13818 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 28 08:34:47 2012 New Revision: 13818 Log: Better error message for (allocate-instance (find-class 'symbol)) 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 Sat Jan 28 06:23:51 2012 (r13817) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sat Jan 28 08:34:47 2012 (r13818) @@ -2994,6 +2994,8 @@ ;;; Instance creation and initialization +;;; AMOP pg. 168ff. Checking whether the class is finalized is done +;;; inside std-allocate-instance and allocate-funcallable-instance. (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) (defmethod allocate-instance ((class standard-class) &rest initargs) @@ -3010,6 +3012,10 @@ (make-list (length (class-slots class)) :initial-element +slot-unbound+))) +(defmethod allocate-instance ((class built-in-class) &rest initargs) + (declare (ignore initargs)) + (error "Cannot allocate instances of a built-in class: ~S" class)) + ;; "The set of valid initialization arguments for a class is the set of valid ;; initialization arguments that either fill slots or supply arguments to ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." From rschlatte at common-lisp.net Sat Jan 28 17:43:39 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sat, 28 Jan 2012 09:43:39 -0800 Subject: [armedbear-cvs] r13819 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sat Jan 28 09:43:39 2012 New Revision: 13819 Log: make functionp recognize instances of funcallable-standard-object. Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Jan 28 08:34:47 2012 (r13818) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Sat Jan 28 09:43:39 2012 (r13819) @@ -544,7 +544,7 @@ @Override public LispObject execute(LispObject arg) { - return (arg instanceof Function || arg instanceof StandardGenericFunction) ? T : NIL; + return (arg instanceof Function || arg instanceof FuncallableStandardObject) ? T : NIL; } }; From mevenson at common-lisp.net Sun Jan 29 03:10:26 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Sat, 28 Jan 2012 19:10:26 -0800 Subject: [armedbear-cvs] r13820 - trunk/abcl/contrib/jss Message-ID: Author: mevenson Date: Sat Jan 28 19:10:25 2012 New Revision: 13820 Log: jss doc: note availabilty of interactive restart to resolve class ambiguity. Modified: trunk/abcl/contrib/jss/README.markdown Modified: trunk/abcl/contrib/jss/README.markdown ============================================================================== --- trunk/abcl/contrib/jss/README.markdown Sat Jan 28 09:43:39 2012 (r13819) +++ trunk/abcl/contrib/jss/README.markdown Sat Jan 28 19:10:25 2012 (r13820) @@ -50,6 +50,8 @@ the arguments sw and "Hello ". JSS figures out the right java method to call, and calls it. +An interactive restart is available to resolve class ambiguity. + Static calls are possible as well with the #" macro, but the first argument MUST BE A SYMBOL to distinguish @@ -82,6 +84,7 @@ (time (dotimes (i 10000) (#"toString" "foo"))) +So, something like (with-constant-signature ((tostring "toString" t)) ...) @@ -130,5 +133,5 @@ <> dc:created "2005" ; dc:author "Mark "; - revised: "27-JAN-2012" . + revised: "29-JAN-2012" . From ehuelsmann at common-lisp.net Sun Jan 29 20:56:10 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 12:56:10 -0800 Subject: [armedbear-cvs] r13821 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 12:56:08 2012 New Revision: 13821 Log: (Re)factor function call argument matching out of Closure.java. Note: the original is still there, to be refactored to use this code soon. Added: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java (contents, props changed) Added: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Sun Jan 29 12:56:08 2012 (r13821) @@ -0,0 +1,1007 @@ +/* + * ArgumentListProcessor.java + * + * Copyright (C) 2012 Erik Huelsmann + * Copyright (C) 2002-2008 Peter Graves + * Copyright (C) 2008 Ville Voutilainen + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package org.armedbear.lisp; + +import java.util.Collection; +import java.util.List; +import java.util.ArrayList; +import static org.armedbear.lisp.Lisp.*; + +/** A class to parse a lambda list and match function call arguments with it + */ +public class ArgumentListProcessor { + + // States. + private static final int STATE_REQUIRED = 0; + private static final int STATE_OPTIONAL = 1; + private static final int STATE_KEYWORD = 2; + private static final int STATE_REST = 3; + private static final int STATE_AUX = 4; + + private Param[] requiredParameters = new Param[0]; + private Param[] optionalParameters = requiredParameters; + private KeywordParam[] keywordParameters = new KeywordParam[0]; + private Param[] auxVars = requiredParameters; + private Param[] positionalParameters = requiredParameters; + + private Symbol restVar; + private Param restParam; + private Symbol envVar; + private Param envParam; + private int arity; + + private int minArgs; + private int maxArgs; + + /** The variables in the lambda list, including &aux and 'supplied-p' */ + private Symbol[] variables = new Symbol[0]; + + /** Array of booleans of value 'true' if the associated variable in the + * variables array is a special variable */ + private boolean[] specials = new boolean[0]; + + private boolean andKey; + private boolean allowOtherKeys; + + /** The parser to be used to match function call arguments with the lambda list */ + final private ArgumentMatcher matcher; + + /** Holds the value 'true' if the matcher needs an evaluation environment to + * evaluate the initforms of variales in the &optional, &key or &aux categories */ + private boolean matcherNeedsEnv; + + /** Used when generating errors during function call argument matching */ + private Operator function; + + /** Constructor to be used from compiled code + * + * The compiler hands in pre-parsed lambda lists. The process of matching + * function call arguments with lambda lists which are constructed this + * way don't support non-constant initforms for &optional, &key and &aux + * parameters. As a result, there's no need to create an evaluation + * environment which in turn eliminates the need to know which variables + * are special. + * + * @param fun The function to report function call argument matching errors on + * @param required The list of required arguments + * @param optional The list of optional arguments + * @param keyword The list of keyword parameters + * @param key Indicates whether &key was specified (optionally without naming keys) + * @param moreKeys Indicates whether &allow-other-keys was specified + * @param rest Specifies the &rest variable name, if one was specified, or 'null' if none + */ + public ArgumentListProcessor(Operator fun, Collection required, + Collection optional, Collection keyword, + boolean key, boolean moreKeys, Symbol rest) { + + function = fun; + + requiredParameters = new RequiredParam[required.size()]; + requiredParameters = required.toArray(requiredParameters); + + optionalParameters = new OptionalParam[optional.size()]; + optionalParameters = optional.toArray(optionalParameters); + + keywordParameters = new KeywordParam[keyword.size()]; + keywordParameters = keyword.toArray(keywordParameters); + + restVar = rest; + if (restVar != null) + restParam = new RestParam(rest, false); + + andKey = key; + allowOtherKeys = moreKeys; + + List positionalParam = new ArrayList(); + positionalParam.addAll(required); + positionalParam.addAll(optional); + if (restVar != null) + positionalParam.add(restParam); + + + positionalParameters = new Param[positionalParam.size()]; + positionalParameters = positionalParam.toArray(positionalParameters); + + auxVars = new Param[0]; + + variables = extractVariables(); + specials = new boolean[variables.length]; // default values 'false' -- leave that way + + minArgs = requiredParameters.length; + maxArgs = (rest == null && ! allowOtherKeys) + ? minArgs + optionalParameters.length + 2*keywordParameters.length : -1; + arity = (rest == null && ! allowOtherKeys && ! andKey && optionalParameters.length == 0) + ? maxArgs : -1; + + if (optional.isEmpty() && keyword.isEmpty()) + matcher = new FastMatcher(); + else + matcher = new SlowMatcher(); + } + + + /** Instantiates an ArgumentListProcessor by parsing the lambda list specified + * in 'lambdaList'. + * + * This constructor sets up the object to support evaluation of non-constant + * initforms. + * + * @param fun Function to use when reporting errors + * @param lambdaList Lambda list to parse and use for function call + * @param specials A list of symbols specifying which variables to + * bind as specials during initform evaluation + */ + public ArgumentListProcessor(Operator fun, LispObject lambdaList, LispObject specials) { + function = fun; + + boolean _andKey = false; + boolean _allowOtherKeys = false; + if (lambdaList instanceof Cons) + { + final int length = lambdaList.length(); + ArrayList required = null; + ArrayList optional = null; + ArrayList keywords = null; + ArrayList aux = null; + int state = STATE_REQUIRED; + LispObject remaining = lambdaList; + while (remaining != NIL) + { + LispObject obj = remaining.car(); + if (obj instanceof Symbol) + { + if (state == STATE_AUX) + { + if (aux == null) + aux = new ArrayList(); + aux.add(new AuxParam((Symbol)obj, + isSpecial((Symbol)obj, specials), NIL)); + } + else if (obj == Symbol.AND_OPTIONAL) + { + state = STATE_OPTIONAL; + arity = -1; + } + 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; + remaining = remaining.cdr(); + if (remaining == NIL) + { + error(new ProgramError( + "&REST/&BODY must be followed by a variable.")); + } + if (restVar != null) + { + error(new ProgramError( + "&REST/&BODY may occur only once.")); + } + final LispObject remainingcar = remaining.car(); + if (remainingcar instanceof Symbol) + { + restVar = (Symbol) remainingcar; + restParam = new RestParam(restVar, isSpecial(restVar, specials)); + } + else + { + error(new ProgramError( + "&REST/&BODY must be followed by a variable.")); + } + } + else if (obj == Symbol.AND_ENVIRONMENT) + { + remaining = remaining.cdr(); + envVar = (Symbol) remaining.car(); + envParam = new EnvironmentParam(envVar, isSpecial(envVar, specials)); + arity = -1; // FIXME + } + else if (obj == Symbol.AND_KEY) + { + state = STATE_KEYWORD; + _andKey = true; + arity = -1; + } + else if (obj == Symbol.AND_ALLOW_OTHER_KEYS) + { + _allowOtherKeys = true; + maxArgs = -1; + } + else if (obj == Symbol.AND_AUX) + { + // All remaining specifiers are aux variable specifiers. + state = STATE_AUX; + arity = -1; // FIXME + } + else + { + if (state == STATE_OPTIONAL) + { + if (optional == null) + optional = new ArrayList(); + optional.add(new OptionalParam((Symbol)obj, + isSpecial((Symbol)obj, specials), null, false, NIL)); + if (maxArgs >= 0) + ++maxArgs; + } + else if (state == STATE_KEYWORD) + { + if (keywords == null) + keywords = new ArrayList(); + keywords.add(new KeywordParam((Symbol)obj, + isSpecial((Symbol)obj, specials), null, false, NIL, null)); + if (maxArgs >= 0) + maxArgs += 2; + } + else + { + if (state != STATE_REQUIRED) + { + error(new ProgramError( + "required parameters cannot appear after &REST/&BODY.")); + } + if (required == null) + required = new ArrayList(); + required.add(new RequiredParam((Symbol)obj, + isSpecial((Symbol)obj, specials))); + if (maxArgs >= 0) + ++maxArgs; + } + } + } + else if (obj instanceof Cons) + { + if (state == STATE_AUX) + { + Symbol sym = checkSymbol(obj.car()); + LispObject initForm = obj.cadr(); + Debug.assertTrue(initForm != null); + if (aux == null) + aux = new ArrayList(); + aux.add(new AuxParam(sym, isSpecial(sym, specials), initForm)); + } + else if (state == STATE_OPTIONAL) + { + Symbol sym = checkSymbol(obj.car()); + LispObject initForm = obj.cadr(); + Symbol svar = checkSymbol(obj.cdr().cdr().car()); + if (optional == null) + optional = new ArrayList(); + optional.add(new OptionalParam(sym, isSpecial(sym, specials), + svar == NIL ? null : svar, isSpecial(svar, specials), initForm)); + if (maxArgs >= 0) + ++maxArgs; + } + else if (state == STATE_KEYWORD) + { + Symbol keyword; + Symbol var; + LispObject initForm = NIL; + Symbol svar = NIL; + LispObject first = obj.car(); + if (first instanceof Cons) + { + keyword = checkSymbol(first.car()); + var = checkSymbol(first.cadr()); + } + else + { + var = checkSymbol(first); + keyword = + PACKAGE_KEYWORD.intern(var.name); + } + obj = obj.cdr(); + if (obj != NIL) + { + initForm = obj.car(); + obj = obj.cdr(); + if (obj != NIL) + svar = checkSymbol(obj.car()); + } + if (keywords == null) + keywords = new ArrayList(); + keywords.add(new KeywordParam(var, isSpecial(var, specials), + svar == NIL ? null : svar, isSpecial(svar, specials), + initForm, keyword)); + if (maxArgs >= 0) + maxArgs += 2; + } + else + invalidParameter(obj); + } + else + invalidParameter(obj); + remaining = remaining.cdr(); + } + if (arity == 0) + arity = length; + ArrayList positional = new ArrayList(); + + if (envParam != null) + positional.add(envParam); + if (required != null) + { + requiredParameters = new Param[required.size()]; + required.toArray(requiredParameters); + positional.addAll(required); + } + if (optional != null) + { + optionalParameters = new Param[optional.size()]; + optional.toArray(optionalParameters); + positional.addAll(optional); + } + if (restParam != null) + positional.add(restParam); + if (keywords != null) + { + keywordParameters = new KeywordParam[keywords.size()]; + keywords.toArray(keywordParameters); + } + if (aux != null) + { + auxVars = new Param[aux.size()]; + auxVars = aux.toArray(auxVars); + } + + positionalParameters = positional.toArray(positionalParameters); + } + else + { + // Lambda list is empty. + Debug.assertTrue(lambdaList == NIL); + arity = 0; + maxArgs = 0; + } + + this.andKey = _andKey; + this.allowOtherKeys = _allowOtherKeys; + minArgs = requiredParameters.length; + if (arity >= 0) + Debug.assertTrue(arity == minArgs); + variables = extractVariables(); + this.specials = new boolean[variables.length]; + for (int i = 0; i < variables.length; i++) + this.specials[i] = isSpecial(variables[i], specials); + + + for (Param p : positionalParameters) + if (p.needsEnvironment()) { + matcherNeedsEnv = true; + break; + } + if (! matcherNeedsEnv) + for (Param p : keywordParameters) + if (p.needsEnvironment()) { + matcherNeedsEnv = true; + break; + } + if (! matcherNeedsEnv) + for (Param p : auxVars) + if (p.needsEnvironment()) { + matcherNeedsEnv = true; + break; + } + + + if (keywordParameters.length == 0) { + matcher = new FastMatcher(); + } else { + matcher = new SlowMatcher(); + } + + + + } + + /** Matches the function call arguments 'args' with the lambda list, + * returning an array with variable values to be used. The array is sorted + * the same way as the variables returned by the 'extractVariables' function. + * + * @param args Funcion call arguments to be matched + * @param _environment Environment to be used for the &environment variable + * @param env Environment to evaluate initforms in + * @param thread Thread to be used for binding special variables + * -- must be LispThread.currentThread() + * @return An array of LispObjects corresponding to the values to be bound + * to the variables in the lambda list + */ + public LispObject[] match(LispObject[] args, Environment _environment, + Environment env, LispThread thread) { + if (matcherNeedsEnv) { + if (thread == null) + thread = LispThread.currentThread(); + + env = new Environment((env == null) ? _environment : env); + } + LispObject[] rv = matcher.match(args, _environment, env, thread); + for (int i = 0; i < rv.length; i++) + Debug.assertTrue(rv[i] != null); + return rv; + } + + /** Binds the variable values returned from 'match' to their corresponding + * variables in the environment 'env', with specials bound in thread 'thread'. + * + * @param values Values to be bound + * @param env + * @param thread + */ + public void bindVars(LispObject[] values, Environment env, LispThread thread) { + for (int i = 0; i < variables.length; i++) { + bindArg(specials[i], variables[i], values[i], env, thread); + } + } + + public int getArity() { + return arity; + } + + public int getMinArgs() { + return minArgs; + } + + public int getMaxArgs() { + return maxArgs; + } + + private static void invalidParameter(LispObject obj) { + error(new ProgramError(obj.princToString() + + " may not be used as a variable in a lambda list.")); + } + + private Symbol[] extractVariables() + { + ArrayList vars = new ArrayList(); + for (Param parameter : positionalParameters) + parameter.addVars(vars); + for (Param parameter : keywordParameters) + parameter.addVars(vars); + for (Param parameter : auxVars) + parameter.addVars(vars); + Symbol[] array = new Symbol[vars.size()]; + vars.toArray(array); + return array; + } + + /** Internal class implementing the argument list to lambda list matcher. + * Because we have two implementations - a fast one and a slower one - we + * need this abstract super class */ + private static abstract class ArgumentMatcher { + abstract LispObject[] match(LispObject[] args, Environment _environment, + Environment env, LispThread thread); + } + + /** ArgumentMatcher class which implements full-blown argument matching, + * including validation of the keywords passed. */ + private class SlowMatcher extends ArgumentMatcher { + @Override + LispObject[] match(LispObject[] args, Environment _environment, + Environment env, LispThread thread) { + + if (arity >= 0) + { + // Fixed arity. + if (args.length != arity) + error(new WrongNumberOfArgumentsException(function, arity)); + return args; + } + // Not fixed arity. + if (args.length < minArgs) + error(new WrongNumberOfArgumentsException(function, minArgs, -1)); + + + final SpecialBindingsMark mark = thread.markSpecialBindings(); + final LispObject[] array = new LispObject[variables.length]; + int index = 0; + ArgList argslist = new ArgList(_environment, args); + + try { + for (Param p : positionalParameters) + index = p.assign(index, array, argslist, env, thread); + + if (andKey) { + argslist.assertRemainderKeywords(); + + for (Param p : keywordParameters) + index = p.assign(index, array, argslist, env, thread); + } + for (Param p : auxVars) + index = p.assign(index, array, argslist, env, thread); + + if (andKey) { + if (allowOtherKeys) + return array; + + if (!argslist.consumed()) // verify keywords + { + LispObject allowOtherKeysValue = + argslist.findKeywordArg(Keyword.ALLOW_OTHER_KEYS, NIL); + + if (allowOtherKeysValue != NIL) + return array; + + // verify keywords + next_key: + while (! argslist.consumed()) { + LispObject key = argslist.consume(); + argslist.consume(); // consume value + + if (key == Keyword.ALLOW_OTHER_KEYS) + continue next_key; + + for (KeywordParam k : keywordParameters) + if (k.keyword == key) + continue next_key; + + error(new ProgramError("Unrecognized keyword argument " + + key.printObject())); + } + } + } + + if (restVar == null && !argslist.consumed()) + error(new WrongNumberOfArgumentsException(function)); + + return array; + } + finally { + thread.resetSpecialBindings(mark); + } + } + } + + /** Slimmed down ArgumentMatcher which doesn't implement keyword verification. */ + private class FastMatcher extends ArgumentMatcher { + @Override + LispObject[] match(LispObject[] args, Environment _environment, + Environment env, LispThread thread) { + final int argsLength = args.length; + if (arity >= 0) + { + // Fixed arity. + if (argsLength != arity) + error(new WrongNumberOfArgumentsException(function, arity)); + return args; + } + // Not fixed arity. + if (argsLength < minArgs) + error(new WrongNumberOfArgumentsException(function, minArgs, -1)); + + final ArgList arglist = new ArgList(_environment, args); + final LispObject[] array = new LispObject[variables.length]; + int index = 0; + + // Required parameters. + for (Param p : positionalParameters) + index = p.assign(index, array, arglist, env, thread); + for (Param p : auxVars) + index = p.assign(index, array, arglist, env, thread); + + if (andKey && !arglist.consumed()) + { + // remaining arguments must be keyword/value pairs + arglist.assertRemainderKeywords(); + + if (allowOtherKeys) + return array; + + LispObject allowOtherKeysValue = + arglist.findKeywordArg(Keyword.ALLOW_OTHER_KEYS, null); + + if (allowOtherKeysValue == NIL) { + // the argument is there. + LispObject key = arglist.consume(); + arglist.consume(); + + if (key != Keyword.ALLOW_OTHER_KEYS) + error(new ProgramError("Invalid keyword argument " + key.printObject())); + + allowOtherKeysValue = null; + } + + if (allowOtherKeysValue != null) + return array; + + } + if (!arglist.consumed()) + { + if (restVar == null) + error(new WrongNumberOfArgumentsException(function)); + } + return array; + } + } + + /** Function which creates initform instances. + * + * @param form + * @return Either a ConstantInitform or NonConstantInitForm instance + */ + private static InitForm createInitForm(LispObject form) { + if (form.constantp()) + { + if (form instanceof Symbol) + return new ConstantInitForm(form.getSymbolValue()); + if (form instanceof Cons) + { + Debug.assertTrue(form.car() == Symbol.QUOTE); + return new ConstantInitForm(form.cadr()); + } + return new ConstantInitForm(form); + } + return new NonConstantInitForm(form); + } + + /** Class to be passed around, allowing arguments to be 'consumed' from it. */ + final private static class ArgList { + final LispObject[] args; + int argsConsumed = 0; + final int len; + final Environment env; + + ArgList(Environment environment, LispObject[] args) { + this.args = args; + len = args.length; + env = environment; + } + + /** Asserts the number of remaining arguments is even. */ + void assertRemainderKeywords() { + if (((len - argsConsumed) & 1) == 1) + error(new ProgramError("Odd number of keyword arguments.")); + } + + /** Returns the next unconsumed value from the argument set, or 'null' + * if all arguments have been consumed. */ + LispObject consume() { + return (argsConsumed < len) ? args[argsConsumed++] : null; + } + + /** Returns 'true' if all arguments have been consumed, false otherwise. */ + boolean consumed() { + return (len == argsConsumed); + } + + /** Returns the value associated with 'keyword', or 'def' if the keyword + * isn't in the remaining arguments. Assumes the remainder is a valid property list. */ + LispObject findKeywordArg(Symbol keyword, LispObject def) { + int i = argsConsumed; + while (i < len) + { + if (args[i] == keyword) + return args[i+1]; + i += 2; + } + return def; + } + + Environment getEnvironment() { + // ### here to satisfy the need of the EnvironmentParam, but this + // is a slight abuse of the abstraction. Don't want to solve more complex, + // but don't really like it this way... + return env; + } + + /** Returns a list of all values not consumed so far. */ + LispObject rest() { + LispObject rest = NIL; + for (int j = len; j-- > argsConsumed;) + rest = new Cons(args[j], rest); + + return rest; + } + } + + /** Abstract parent of the classes used to represent the different argument types: + * + * - EnvironmentParam + * - RequiredParam + * - OptionalParam + * - RestParam + * - KeywordParam + * - AuxParam + * */ + public static abstract class Param { + + /** Assigns values to be bound to the correcsponding variables to the + * array, using 'index' as the next free slot, consuming any required + * values from 'args'. Uses 'ext' both as the evaluation environment + * for initforms. + * + * The environment 'ext' is prepared for evaluating any initforms of + * further arguments by binding the variables to their values in it. + * + * The environment 'ext' may be null, indicating none of the arguments + * need an evaluation environment. No attempt should be made to bind + * any variables in this case. + * + * Returns the index of the next-unused slot in the 'array'. + */ + abstract int assign(int index, LispObject[] array, ArgList args, + Environment ext, LispThread thread); + + /** Returns 'true' if the parameter requires an evaluation environment + * in order to be able to determine the value of its initform. */ + boolean needsEnvironment() { return false; } + + /** Adds the variables to be bound to 'vars' in the same order as they + * will be assigned to the output array by the 'assign' method. */ + abstract void addVars(List vars); + } + + + /** Abstract super class representing initforms. */ + private static abstract class InitForm { + abstract LispObject getValue(Environment ext, LispThread thread); + boolean needsEnvironment() { return false; } + } + + /** Constant init forms will be represented using this class. */ + private static class ConstantInitForm extends InitForm { + LispObject value; + + ConstantInitForm(LispObject value) { + this.value = value; + } + + LispObject getValue(Environment ext, LispThread thread) { + return value; + } + } + + + /** Non-constant initforms will be represented using this class. + * Callers need to know these need an evaluation environment. */ + private static class NonConstantInitForm extends InitForm { + LispObject form; + + NonConstantInitForm(LispObject form) { + this.form = form; + } + + LispObject getValue(Environment ext, LispThread thread) { + return eval(form, ext, thread); + } + + @Override + boolean needsEnvironment() { return true; } + } + + /** Class used to match &environment arguments */ + private static class EnvironmentParam extends Param { + Symbol var; + boolean special; + + EnvironmentParam(Symbol var, boolean special) { + this.var = var; + this.special = special; + } + + @Override + void addVars(List vars) { + vars.add(var); + } + + @Override + int assign(int index, LispObject[] array, ArgList args, Environment ext, LispThread thread) { + array[index++] = args.getEnvironment(); + if (ext != null) + bindArg(special, var, args.getEnvironment(), ext, thread); + + return index; + } + } + + + /** Class used to match required parameters */ + public static class RequiredParam extends Param { + Symbol var; + boolean special; + + public RequiredParam(Symbol var, boolean special) { + this.var = var; + this.special = special; + } + + @Override + int assign(int index, LispObject[] array, ArgList args, + Environment ext, LispThread thread) { + LispObject value = args.consume(); + if (ext != null) + bindArg(special, var, value, ext, thread); + array[index++] = value; + return index; + } + + void addVars(List vars) { + vars.add(var); + } + } + + /** Class used to match optional parameters, or, if not provided, + * evaluate the initform. Also assigns the 'supplied-p' parameter if requested. */ + public static class OptionalParam extends Param { + Symbol var; + boolean special; + Symbol suppliedVar; + boolean suppliedSpecial; + InitForm initForm; + + + public OptionalParam(Symbol var, boolean special, + Symbol suppliedVar, boolean suppliedSpecial, + LispObject form) { + this.var = var; + this.special = special; + + this.suppliedVar = suppliedVar; + this.suppliedSpecial = suppliedSpecial; + + initForm = createInitForm(form); + } + + @Override + int assign(int index, LispObject[] array, ArgList args, + Environment ext, LispThread thread) { + LispObject value = args.consume(); + + return assign(index, array, value, ext, thread); + } + + int assign(int index, LispObject[] array, LispObject value, + Environment ext, LispThread thread) { + if (value == null) { + value = array[index++] = initForm.getValue(ext, thread); + if (suppliedVar != null) + array[index++] = NIL; + } else { + array[index++] = value; + if (suppliedVar != null) + array[index++] = T; + } + + if (ext != null) { + bindArg(special, var, value, ext, thread); + if (suppliedVar != null) + bindArg(suppliedSpecial, suppliedVar, array[index-1], ext, thread); + } + + return index; + } + + + @Override + boolean needsEnvironment() { + return initForm.needsEnvironment(); + } + + void addVars(List vars) { + vars.add(var); + if (suppliedVar != null) + vars.add(suppliedVar); + } + } + + + /** Class used to model the &rest parameter */ + private static class RestParam extends Param { + Symbol var; + boolean special; + + RestParam(Symbol var, boolean special) { + this.var = var; + this.special = special; + } + + @Override + int assign(int index, LispObject[] array, ArgList args, + Environment ext, LispThread thread) { + array[index++] = args.rest(); + + if (ext != null) + bindArg(special, var, array[index-1], ext, thread); + + return index; + } + + @Override + void addVars(List vars) { + vars.add(var); + } + } + + /** Class used to represent optional parameters and their initforms */ + public static class KeywordParam extends OptionalParam { + public Symbol keyword; + + public KeywordParam(Symbol var, boolean special, + Symbol suppliedVar, boolean suppliedSpecial, + LispObject form, Symbol keyword) { + super(var, special, suppliedVar, suppliedSpecial, form); + + this.keyword = (keyword == null) + ? PACKAGE_KEYWORD.intern(var.getName()) : keyword; + } + + @Override + int assign(int index, LispObject[] array, ArgList args, + Environment ext, LispThread thread) { + return super.assign(index, array, args.findKeywordArg(keyword, null), + ext, thread); + } + } + + + /** Class used to represent &aux parameters and their initforms */ + private static class AuxParam extends Param { + Symbol var; + boolean special; + InitForm initform; + + AuxParam(Symbol var, boolean special, LispObject form) { + this.var = var; + this.special = special; + initform = createInitForm(form); + } + + @Override + void addVars(List vars) { + vars.add(var); + } + + @Override + int assign(int index, LispObject[] array, ArgList args, Environment ext, LispThread thread) { + array[index++] = initform.getValue(ext, thread); + + if (ext != null) + bindArg(special, var, array[index-1], ext, thread); + + return index; + } + + @Override + boolean needsEnvironment() { + return initform.needsEnvironment(); + } + + } +} From ehuelsmann at common-lisp.net Sun Jan 29 21:14:43 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 13:14:43 -0800 Subject: [armedbear-cvs] r13822 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 13:14:42 2012 New Revision: 13822 Log: Fix trunk build after the previous commit. (Lesson: don't try to limit the scope of your commits -- just let the change flow) Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Jan 29 12:56:08 2012 (r13821) +++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Sun Jan 29 13:14:42 2012 (r13822) @@ -91,7 +91,7 @@ @DocString(name="nil") - public static final LispObject NIL = Nil.NIL; + public static final Symbol NIL = Nil.NIL; // We need NIL before we can call usePackage(). static @@ -843,9 +843,7 @@ } // Environment wrappers. - private static final boolean isSpecial(Symbol sym, LispObject ownSpecials, - Environment env) - + static final boolean isSpecial(Symbol sym, LispObject ownSpecials) { if (ownSpecials != null) { @@ -865,7 +863,7 @@ Environment env, LispThread thread) { - if (isSpecial(sym, ownSpecials, env)) { + if (isSpecial(sym, ownSpecials)) { env.declareSpecial(sym); thread.bindSpecial(sym, value); } @@ -873,6 +871,17 @@ env.bind(sym, value); } + public static void bindArg(boolean special, Symbol sym, LispObject value, + Environment env, LispThread thread) + { + if (special) { + env.declareSpecial(sym); + thread.bindSpecial(sym, value); + } + else + env.bind(sym, value); + } + public static final Cons list(LispObject obj1, LispObject... remaining) { Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Jan 29 12:56:08 2012 (r13821) +++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Jan 29 13:14:42 2012 (r13822) @@ -95,7 +95,7 @@ (defknown emit-push-nil () t) (declaim (inline emit-push-nil)) (defun emit-push-nil () - (emit-getstatic +lisp+ "NIL" +lisp-object+)) + (emit-getstatic +lisp+ "NIL" +lisp-symbol+)) (defknown emit-push-nil-symbol () t) (declaim (inline emit-push-nil-symbol)) From ehuelsmann at common-lisp.net Sun Jan 29 21:15:49 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 13:15:49 -0800 Subject: [armedbear-cvs] r13823 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 13:15:48 2012 New Revision: 13823 Log: Add an ArgumentListProcessor to Closure. It'll take over argument list processing soon. 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 Sun Jan 29 13:14:42 2012 (r13822) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 13:15:48 2012 (r13823) @@ -76,6 +76,8 @@ private boolean bindInitForms; + private ArgumentListProcessor arglist; + /** Construct a closure object with a lambda-list described * by these parameters. * @@ -115,6 +117,26 @@ body = null; executionBody = null; environment = null; + + ArrayList reqParams = + new ArrayList(); + for (Parameter req : requiredParameters) + reqParams.add(new ArgumentListProcessor.RequiredParam(req.var, false)); + + ArrayList optParams = + new ArrayList(); + for (Parameter opt : optionalParameters) + optParams.add(new ArgumentListProcessor.OptionalParam(opt.var, false, + (opt.svar == NIL) ? null : (Symbol)opt.svar, false, + opt.initForm)); + + ArrayList keyParams = + new ArrayList(); + for (Parameter key : keywordParameters) + keyParams.add(new ArgumentListProcessor.KeywordParam(key.var, false, + (key.svar == NIL) ? null : (Symbol)key.svar, false, key.initForm, + key.keyword)); + arglist = new ArgumentListProcessor(this, reqParams, optParams, keyParams, andKey, allowOtherKeys, restVar); } @@ -351,6 +373,8 @@ if (arity >= 0) Debug.assertTrue(arity == minArgs); variables = processVariables(); + + arglist = new ArgumentListProcessor(this, lambdaList, specials); } private final void processParameters(ArrayList vars, From ehuelsmann at common-lisp.net Sun Jan 29 21:41:47 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 13:41:47 -0800 Subject: [armedbear-cvs] r13824 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 13:41:47 2012 New Revision: 13824 Log: Use the arglist parser in some places. 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 Sun Jan 29 13:15:48 2012 (r13823) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 13:41:47 2012 (r13824) @@ -459,16 +459,10 @@ { final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); + Environment ext = new Environment(environment); - bindRequiredParameters(ext, thread, objects); - if (arity != minArgs) - { - bindParameterDefaults(optionalParameters, ext, thread); - if (restVar != null) - bindArg(specials, restVar, NIL, ext, thread); - bindParameterDefaults(keywordParameters, ext, thread); - } - bindAuxVars(ext, thread); + LispObject[] args = arglist.match(objects, environment, ext, thread); + arglist.bindVars(args, ext, thread); declareFreeSpecials(ext); try { @@ -480,20 +474,6 @@ } } - private final void bindRequiredParameters(Environment ext, - LispThread thread, - LispObject[] objects) - - { - // &whole and &environment before anything - if (envVar != null) - bindArg(specials, envVar, environment, ext, thread); - for (int i = 0; i < objects.length; ++i) - { - bindArg(specials, requiredParameters[i].var, objects[i], ext, thread); - } - } - public final LispObject invokeArrayExecute(LispObject... objects) { @@ -654,21 +634,8 @@ final LispThread thread = LispThread.currentThread(); final SpecialBindingsMark mark = thread.markSpecialBindings(); Environment ext = new Environment(environment); - if (optionalParameters.length == 0 && keywordParameters.length == 0) - args = fastProcessArgs(args); - else - args = processArgs(args, thread); - Debug.assertTrue(args.length == variables.length); - if (envVar != null) - { - bindArg(specials, envVar, environment, ext, thread); - } - for (int i = 0; i < variables.length; i++) - { - Symbol sym = variables[i]; - bindArg(specials, sym, args[i], ext, thread); - } - bindAuxVars(ext, thread); + args = arglist.match(args, environment, ext, thread); + arglist.bindVars(args, ext, thread); declareFreeSpecials(ext); try { @@ -1029,42 +996,6 @@ return array; } - private final void bindParameterDefaults(Parameter[] parameters, - Environment env, - LispThread thread) - - { - for (Parameter parameter : parameters) - { - LispObject value; - if (parameter.initVal != null) - value = parameter.initVal; - else - value = eval(parameter.initForm, env, thread); - bindArg(specials, parameter.var, value, env, thread); - if (parameter.svar != NIL) - bindArg(specials, (Symbol)parameter.svar, NIL, env, thread); - } - } - - private final void bindAuxVars(Environment env, LispThread thread) - - { - // Aux variable processing is analogous to LET* processing. - for (Parameter parameter : auxVars) - { - Symbol sym = parameter.var; - LispObject value; - - if (parameter.initVal != null) - value = parameter.initVal; - else - value = eval(parameter.initForm, env, thread); - - bindArg(specials, sym, value, env, thread); - } - } - public static class Parameter { final Symbol var; From ehuelsmann at common-lisp.net Sun Jan 29 21:55:34 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 13:55:34 -0800 Subject: [armedbear-cvs] r13825 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 13:55:34 2012 New Revision: 13825 Log: Implement fastProcessArgs() using the ArgumentListProcessor. 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 Sun Jan 29 13:41:47 2012 (r13824) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 13:55:34 2012 (r13825) @@ -921,79 +921,8 @@ // No optional or keyword parameters. protected final LispObject[] fastProcessArgs(LispObject[] args) - { - final int argsLength = args.length; - if (arity >= 0) - { - // Fixed arity. - if (argsLength != arity) - error(new WrongNumberOfArgumentsException(this, arity)); - return args; - } - // Not fixed arity. - if (argsLength < minArgs) - error(new WrongNumberOfArgumentsException(this, minArgs, -1)); - final LispObject[] array = new LispObject[variables.length]; - int index = 0; - // Required parameters. - for (int i = 0; i < minArgs; i++) - { - array[index++] = args[i]; - } - int argsUsed = minArgs; - // &rest parameter. - if (restVar != null) - { - LispObject rest = NIL; - for (int j = argsLength; j-- > argsUsed;) - rest = new Cons(args[j], rest); - array[index++] = rest; - } - else if (argsUsed < argsLength) - { - // No keyword parameters. - if (argsUsed + 2 <= argsLength) - { - // Check for :ALLOW-OTHER-KEYS. - LispObject allowOtherKeysValue = NIL; - int n = argsUsed; - while (n < argsLength) - { - LispObject keyword = args[n]; - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - allowOtherKeysValue = args[n+1]; - break; - } - n += 2; - } - if (allowOtherKeys || allowOtherKeysValue != NIL) - { - // Skip keyword/value pairs. - while (argsUsed + 2 <= argsLength) - argsUsed += 2; - } - else if (andKey) - { - LispObject keyword = args[argsUsed]; - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - // Section 3.4.1.4: "Note that if &key is present, a - // keyword argument of :allow-other-keys is always - // permitted---regardless of whether the associated - // value is true or false." - argsUsed += 2; - } - } - } - if (argsUsed < argsLength) - { - if (restVar == null) - error(new WrongNumberOfArgumentsException(this)); - } - } - return array; + return arglist.match(args, environment, null, null); } public static class Parameter From ehuelsmann at common-lisp.net Sun Jan 29 22:09:01 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 14:09:01 -0800 Subject: [armedbear-cvs] r13826 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 14:09:01 2012 New Revision: 13826 Log: Implement processArgs() using the ArgumentListProcessor. 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 Sun Jan 29 13:55:34 2012 (r13825) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 14:09:01 2012 (r13826) @@ -647,276 +647,9 @@ } } - - private LispObject[] _processArgs(LispObject[] args, LispThread thread, - Environment ext) { - final LispObject[] array = new LispObject[variables.length]; - int index = 0; - - int argsLength = args.length; - - if (bindInitForms) - if (envVar != null) - bindArg(specials, envVar, environment, ext, thread); - // Required parameters. - for (int i = 0; i < minArgs; i++) - { - if (bindInitForms) - bindArg(specials, requiredParameters[i].var, args[i], ext, thread); - array[index++] = args[i]; - } - int i = minArgs; - int argsUsed = minArgs; - // Optional parameters. - for (Parameter parameter : optionalParameters) - { - if (i < argsLength) - { - if (bindInitForms) - bindArg(specials, parameter.var, args[i], ext, thread); - array[index++] = args[i]; - ++argsUsed; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, T, ext, thread); - array[index++] = T; - } - } - else - { - // We've run out of arguments. - LispObject value; - if (parameter.initVal != null) - value = parameter.initVal; - else - value = eval(parameter.initForm, ext, thread); - if (bindInitForms) - bindArg(specials, parameter.var, value, ext, thread); - array[index++] = value; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); - array[index++] = NIL; - } - } - ++i; - } - // &rest parameter. - if (restVar != null) - { - LispObject rest = NIL; - for (int j = argsLength; j-- > argsUsed;) - rest = new Cons(args[j], rest); - if (bindInitForms) - bindArg(specials, restVar, rest, ext, thread); - array[index++] = rest; - } - // Keyword parameters. - if (keywordParameters.length > 0) - { - int argsLeft = argsLength - argsUsed; - if (argsLeft == 0) - { - // No keyword arguments were supplied. - // Bind all keyword parameters to their defaults. - for (int k = 0; k < keywordParameters.length; k++) - { - Parameter parameter = keywordParameters[k]; - LispObject value; - if (parameter.initVal != null) - value = parameter.initVal; - else - value = eval(parameter.initForm, ext, thread); - if (bindInitForms) - bindArg(specials, parameter.var, value, ext, thread); - array[index++] = value; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); - array[index++] = NIL; - } - } - } - else - { - if ((argsLeft % 2) != 0) - error(new ProgramError("Odd number of keyword arguments.")); - LispObject allowOtherKeysValue = null; - for (Parameter parameter : keywordParameters) - { - Symbol keyword = parameter.keyword; - LispObject value = null; - boolean unbound = true; - for (int j = argsUsed; j < argsLength; j += 2) - { - if (args[j] == keyword) - { - if (bindInitForms) - bindArg(specials, parameter.var, args[j+1], ext, thread); - value = array[index++] = args[j+1]; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials,(Symbol)parameter.svar, T, ext, thread); - array[index++] = T; - } - args[j] = null; - args[j+1] = null; - unbound = false; - break; - } - } - if (unbound) - { - if (parameter.initVal != null) - value = parameter.initVal; - else - value = eval(parameter.initForm, ext, thread); - if (bindInitForms) - bindArg(specials, parameter.var, value, ext, thread); - array[index++] = value; - if (parameter.svar != NIL) - { - if (bindInitForms) - bindArg(specials, (Symbol)parameter.svar, NIL, ext, thread); - array[index++] = NIL; - } - } - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - if (allowOtherKeysValue == null) - allowOtherKeysValue = value; - } - } - if (!allowOtherKeys) - { - if (allowOtherKeysValue == null || allowOtherKeysValue == NIL) - { - LispObject unrecognizedKeyword = null; - for (int j = argsUsed; j < argsLength; j += 2) - { - LispObject keyword = args[j]; - if (keyword == null) - continue; - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - if (allowOtherKeysValue == null) - { - allowOtherKeysValue = args[j+1]; - if (allowOtherKeysValue != NIL) - break; - } - continue; - } - // Unused keyword argument. - boolean ok = false; - for (Parameter parameter : keywordParameters) - { - if (parameter.keyword == keyword) - { - // Found it! - ok = true; - break; - } - } - if (ok) - continue; - // Unrecognized keyword argument. - if (unrecognizedKeyword == null) - unrecognizedKeyword = keyword; - } - if (unrecognizedKeyword != null) - { - if (!allowOtherKeys && - (allowOtherKeysValue == null || allowOtherKeysValue == NIL)) - error(new ProgramError("Unrecognized keyword argument " + - unrecognizedKeyword.printObject())); - } - } - } - } - } - else if (argsUsed < argsLength) - { - // No keyword parameters. - if (argsUsed + 2 <= argsLength) - { - // Check for :ALLOW-OTHER-KEYS. - LispObject allowOtherKeysValue = NIL; - int n = argsUsed; - while (n < argsLength) - { - LispObject keyword = args[n]; - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - allowOtherKeysValue = args[n+1]; - break; - } - n += 2; - } - if (allowOtherKeys || allowOtherKeysValue != NIL) - { - // Skip keyword/value pairs. - while (argsUsed + 2 <= argsLength) - argsUsed += 2; - } - else if (andKey) - { - LispObject keyword = args[argsUsed]; - if (keyword == Keyword.ALLOW_OTHER_KEYS) - { - // Section 3.4.1.4: "Note that if &KEY is present, a - // keyword argument of :ALLOW-OTHER-KEYS is always - // permitted---regardless of whether the associated - // value is true or false." - argsUsed += 2; - } - } - } - if (argsUsed < argsLength) - { - if (restVar == null) - error(new WrongNumberOfArgumentsException(this)); - } - } - return array; - } - protected final LispObject[] processArgs(LispObject[] args, LispThread thread) - { - if (optionalParameters.length == 0 && keywordParameters.length == 0) - return fastProcessArgs(args); - if (arity >= 0) - { - // Fixed arity. - if (args.length != arity) - error(new WrongNumberOfArgumentsException(this, arity)); - return args; - } - // Not fixed arity. - if (args.length < minArgs) - error(new WrongNumberOfArgumentsException(this, minArgs, -1)); - - if (!bindInitForms) - return _processArgs(args, thread, environment); - - // The bindings established here (if any) are lost when this function - // returns. They are used only in the evaluation of initforms for - // optional and keyword arguments. - final SpecialBindingsMark mark = thread.markSpecialBindings(); - Environment ext = new Environment(environment); - // Section 3.4.4: "...the &environment parameter is bound along with - // &whole before any other variables in the lambda list..." - try { - return _processArgs(args, thread, ext); - } - finally { - thread.resetSpecialBindings(mark); - } + return arglist.match(args, environment, environment, thread); } // No optional or keyword parameters. From rschlatte at common-lisp.net Sun Jan 29 22:47:10 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 29 Jan 2012 14:47:10 -0800 Subject: [armedbear-cvs] r13827 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jan 29 14:47:09 2012 New Revision: 13827 Log: Fix ansi tests class-0309, class-0310.1 ... ensure-class now redefines a class found by (FIND-CLASS NAME) only if NAME is eql to (CLASS-NAME CLASS) as well. 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 Sun Jan 29 14:09:01 2012 (r13826) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 29 14:47:09 2012 (r13827) @@ -2656,7 +2656,13 @@ ;;; AMOP pg. 182 (defun ensure-class (name &rest all-keys &key &allow-other-keys) - (apply #'ensure-class-using-class (find-class name nil) name all-keys)) + (let ((class (find-class name nil))) + ;; CLHS DEFCLASS: "If a class with the same proper name already + ;; exists [...] the existing class is redefined." Ansi-tests + ;; CLASS-0309 and CLASS-0310.1 demand this behavior. + (if (and class (eql (class-name class) name)) + (apply #'ensure-class-using-class class name all-keys) + (apply #'ensure-class-using-class nil name all-keys)))) ;;; AMOP pg. 183ff. (defgeneric ensure-class-using-class (class name &key direct-default-initargs From ehuelsmann at common-lisp.net Sun Jan 29 23:13:38 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 15:13:38 -0800 Subject: [armedbear-cvs] r13828 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 15:13:37 2012 New Revision: 13828 Log: Remove variables 'variables' and 'bindInitForms'. Simplify free specials binding. Modified: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java trunk/abcl/src/org/armedbear/lisp/Closure.java Modified: trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Sun Jan 29 14:47:09 2012 (r13827) +++ trunk/abcl/src/org/armedbear/lisp/ArgumentListProcessor.java Sun Jan 29 15:13:37 2012 (r13828) @@ -471,6 +471,25 @@ } } + public Symbol[] freeSpecials(LispObject specials) { + ArrayList list = new ArrayList(); + + next_special: + while (specials != NIL) { + Symbol special = (Symbol)specials.car(); + specials = specials.cdr(); + + for (Symbol v : variables) + if (v == special) + continue next_special; + + list.add(special); + } + + Symbol[] rv = new Symbol[list.size()]; + return list.toArray(rv); + } + public int getArity() { return arity; } @@ -483,6 +502,10 @@ return maxArgs; } + public Symbol[] getVariables() { + return variables; + } + private static void invalidParameter(LispObject obj) { error(new ProgramError(obj.princToString() + " may not be used as a variable in a lambda list.")); Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 14:47:09 2012 (r13827) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 15:13:37 2012 (r13828) @@ -70,11 +70,8 @@ private int minArgs; private int maxArgs; - private Symbol[] variables = new Symbol[0]; private LispObject specials = NIL; - - private boolean bindInitForms; - + private Symbol[] freeSpecials = new Symbol[0]; private ArgumentListProcessor arglist; @@ -110,8 +107,6 @@ andKey = keys != NIL; allowOtherKeys = moreKeys != NIL; - variables = processVariables(); - bindInitForms = false; // stuff we don't need: we're a compiled function body = null; @@ -372,9 +367,9 @@ minArgs = requiredParameters.length; if (arity >= 0) Debug.assertTrue(arity == minArgs); - variables = processVariables(); arglist = new ArgumentListProcessor(this, lambdaList, specials); + freeSpecials = arglist.freeSpecials(specials); } private final void processParameters(ArrayList vars, @@ -385,27 +380,7 @@ vars.add(parameter.var); if (parameter.svar != NIL) vars.add((Symbol)parameter.svar); - if (!bindInitForms) - if (!parameter.initForm.constantp()) - bindInitForms = true; - } - } - - // Also sets bindInitForms. - private final Symbol[] processVariables() - { - ArrayList vars = new ArrayList(); - for (Parameter parameter : requiredParameters) - vars.add(parameter.var); - processParameters(vars, optionalParameters); - if (restVar != null) - { - vars.add(restVar); } - processParameters(vars, keywordParameters); - Symbol[] array = new Symbol[vars.size()]; - vars.toArray(array); - return array; } private static final void invalidParameter(LispObject obj) @@ -425,6 +400,7 @@ public final LispObject getVariableList() { + Symbol[] variables = arglist.getVariables(); LispObject result = NIL; for (int i = variables.length; i-- > 0;) result = new Cons(variables[i], result); @@ -610,22 +586,10 @@ } } - private final void declareFreeSpecials(Environment ext) - + private void declareFreeSpecials(Environment ext) { - LispObject s = specials; - special: - while (s != NIL) { - Symbol special = (Symbol)s.car(); - s = s.cdr(); - for (Symbol var : variables) - if (special == var) - continue special; - for (Parameter parameter : auxVars) - if (special == parameter.var) - continue special; - ext.declareSpecial(special); - } + for (Symbol special : freeSpecials) + ext.declareSpecial(special); } @Override From ehuelsmann at common-lisp.net Sun Jan 29 23:19:27 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 15:19:27 -0800 Subject: [armedbear-cvs] r13829 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 15:19:26 2012 New Revision: 13829 Log: Remove unused variable 'specials' and unused function 'processParameters'. 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 Sun Jan 29 15:13:37 2012 (r13828) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 15:19:26 2012 (r13829) @@ -70,7 +70,6 @@ private int minArgs; private int maxArgs; - private LispObject specials = NIL; private Symbol[] freeSpecials = new Symbol[0]; private ArgumentListProcessor arglist; @@ -359,7 +358,7 @@ this.body = lambdaExpression.cddr(); LispObject bodyAndDecls = parseBody(this.body, false); this.executionBody = bodyAndDecls.car(); - this.specials = parseSpecials(bodyAndDecls.NTH(1)); + LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); this.environment = env; this.andKey = _andKey; @@ -372,17 +371,6 @@ freeSpecials = arglist.freeSpecials(specials); } - private final void processParameters(ArrayList vars, - final Parameter[] parameters) - { - for (Parameter parameter : parameters) - { - vars.add(parameter.var); - if (parameter.svar != NIL) - vars.add((Symbol)parameter.svar); - } - } - private static final void invalidParameter(LispObject obj) { From rschlatte at common-lisp.net Sun Jan 29 23:40:51 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Sun, 29 Jan 2012 15:40:51 -0800 Subject: [armedbear-cvs] r13830 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Sun Jan 29 15:40:50 2012 New Revision: 13830 Log: Clear generic-function slot of method object in remove-method. ... Fixes ansi tests ADD-METHOD.1, ADD-METHOD.2. 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 Sun Jan 29 15:19:26 2012 (r13829) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 29 15:40:50 2012 (r13830) @@ -1777,10 +1777,11 @@ method)) (defun std-add-method (gf method) - (when (method-generic-function method) + (when (and (method-generic-function method) + (not (eql gf (method-generic-function method)))) (error 'simple-error - :format-control "ADD-METHOD: ~S is already a method of ~S." - :format-arguments (list method (method-generic-function method)))) + :format-control "~S is already a method of ~S, cannot add to ~S." + :format-arguments (list method (method-generic-function method) gf))) ;; Remove existing method with same qualifiers and specializers (if any). (let ((old-method (%find-method gf (std-method-qualifiers method) (method-specializers method) nil))) @@ -1789,7 +1790,8 @@ (setf (std-slot-value method 'generic-function) gf) (push method (generic-function-methods gf)) (dolist (specializer (method-specializers method)) - (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? + ;; FIXME use add-direct-method here (AMOP pg. 165)) + (when (typep specializer 'class) (pushnew method (class-direct-methods specializer)))) (finalize-standard-generic-function gf) gf) @@ -1797,9 +1799,10 @@ (defun std-remove-method (gf method) (setf (generic-function-methods gf) (remove method (generic-function-methods gf))) - (setf (std-slot-value method 'generic-function) gf) + (setf (std-slot-value method 'generic-function) nil) (dolist (specializer (method-specializers method)) - (when (typep specializer 'class) ;; FIXME What about EQL specializer objects? + ;; FIXME use remove-direct-method here (AMOP pg. 227) + (when (typep specializer 'class) (setf (class-direct-methods specializer) (remove method (class-direct-methods specializer))))) (finalize-standard-generic-function gf) From ehuelsmann at common-lisp.net Sun Jan 29 23:57:05 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Sun, 29 Jan 2012 15:57:05 -0800 Subject: [armedbear-cvs] r13831 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Sun Jan 29 15:57:04 2012 New Revision: 13831 Log: Remove lambda list parsing from Closure: it's now fully handled by ArgumentListProcessor. 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 Sun Jan 29 15:40:50 2012 (r13830) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 29 15:57:04 2012 (r13831) @@ -47,24 +47,9 @@ public static final int REST = 3; public static final int AUX = 4; - // States. - private static final int STATE_REQUIRED = 0; - private static final int STATE_OPTIONAL = 1; - private static final int STATE_KEYWORD = 2; - private static final int STATE_REST = 3; - private static final int STATE_AUX = 4; - - private Parameter[] requiredParameters = new Parameter[0]; - private Parameter[] optionalParameters = requiredParameters; - private Parameter[] keywordParameters = requiredParameters; - private Parameter[] auxVars = requiredParameters; private final LispObject body; private final LispObject executionBody; private final Environment environment; - private final boolean andKey; - private final boolean allowOtherKeys; - private Symbol restVar; - private Symbol envVar; private int arity; private int minArgs; @@ -97,16 +82,9 @@ && optional.length == 0) ? maxArgs : -1; - requiredParameters = required; - optionalParameters = optional; - keywordParameters = keyword; - if (rest != NIL) restVar = rest; - andKey = keys != NIL; - allowOtherKeys = moreKeys != NIL; - // stuff we don't need: we're a compiled function body = null; executionBody = null; @@ -114,23 +92,25 @@ ArrayList reqParams = new ArrayList(); - for (Parameter req : requiredParameters) + for (Parameter req : required) reqParams.add(new ArgumentListProcessor.RequiredParam(req.var, false)); ArrayList optParams = new ArrayList(); - for (Parameter opt : optionalParameters) + for (Parameter opt : optional) optParams.add(new ArgumentListProcessor.OptionalParam(opt.var, false, (opt.svar == NIL) ? null : (Symbol)opt.svar, false, opt.initForm)); ArrayList keyParams = new ArrayList(); - for (Parameter key : keywordParameters) + for (Parameter key : keyword) keyParams.add(new ArgumentListProcessor.KeywordParam(key.var, false, (key.svar == NIL) ? null : (Symbol)key.svar, false, key.initForm, key.keyword)); - arglist = new ArgumentListProcessor(this, reqParams, optParams, keyParams, andKey, allowOtherKeys, restVar); + arglist = new ArgumentListProcessor(this, reqParams, optParams, + keyParams, keys != NIL, + moreKeys != NIL, restVar); } @@ -149,233 +129,17 @@ if (!(lambdaList == NIL || lambdaList instanceof Cons)) error(new ProgramError("The lambda list " + lambdaList.princToString() + " is invalid.")); - boolean _andKey = false; - boolean _allowOtherKeys = false; - if (lambdaList instanceof Cons) - { - final int length = lambdaList.length(); - ArrayList required = null; - ArrayList optional = null; - ArrayList keywords = null; - ArrayList aux = null; - int state = STATE_REQUIRED; - LispObject remaining = lambdaList; - while (remaining != NIL) - { - LispObject obj = remaining.car(); - if (obj instanceof Symbol) - { - if (state == STATE_AUX) - { - if (aux == null) - aux = new ArrayList(); - aux.add(new Parameter((Symbol)obj, NIL, AUX)); - } - else if (obj == Symbol.AND_OPTIONAL) - { - state = STATE_OPTIONAL; - arity = -1; - } - else if (obj == Symbol.AND_REST || obj == Symbol.AND_BODY) - { - if (_andKey) - { - error(new ProgramError( - "&REST/&BODY must precede &KEY.")); - } - state = STATE_REST; - arity = -1; - maxArgs = -1; - remaining = remaining.cdr(); - if (remaining == NIL) - { - error(new ProgramError( - "&REST/&BODY must be followed by a variable.")); - } - if (restVar != null) - { - error(new ProgramError( - "&REST/&BODY may occur only once.")); - } - final LispObject remainingcar = remaining.car(); - if (remainingcar instanceof Symbol) - { - restVar = (Symbol) remainingcar; - } - else - { - error(new ProgramError( - "&REST/&BODY must be followed by a variable.")); - } - } - else if (obj == Symbol.AND_ENVIRONMENT) - { - remaining = remaining.cdr(); - envVar = (Symbol) remaining.car(); - arity = -1; // FIXME - } - else if (obj == Symbol.AND_KEY) - { - state = STATE_KEYWORD; - _andKey = true; - arity = -1; - } - else if (obj == Symbol.AND_ALLOW_OTHER_KEYS) - { - _allowOtherKeys = true; - maxArgs = -1; - } - else if (obj == Symbol.AND_AUX) - { - // All remaining specifiers are aux variable specifiers. - state = STATE_AUX; - arity = -1; // FIXME - } - else - { - if (state == STATE_OPTIONAL) - { - if (optional == null) - optional = new ArrayList(); - optional.add(new Parameter((Symbol)obj, NIL, OPTIONAL)); - if (maxArgs >= 0) - ++maxArgs; - } - else if (state == STATE_KEYWORD) - { - if (keywords == null) - keywords = new ArrayList(); - keywords.add(new Parameter((Symbol)obj, NIL, KEYWORD)); - if (maxArgs >= 0) - maxArgs += 2; - } - else - { - if (state != STATE_REQUIRED) - { - error(new ProgramError( - "required parameters cannot appear after &REST/&BODY.")); - } - if (required == null) - required = new ArrayList(); - required.add(new Parameter((Symbol)obj)); - if (maxArgs >= 0) - ++maxArgs; - } - } - } - else if (obj instanceof Cons) - { - if (state == STATE_AUX) - { - Symbol sym = checkSymbol(obj.car()); - LispObject initForm = obj.cadr(); - Debug.assertTrue(initForm != null); - if (aux == null) - aux = new ArrayList(); - aux.add(new Parameter(sym, initForm, AUX)); - } - else if (state == STATE_OPTIONAL) - { - Symbol sym = checkSymbol(obj.car()); - LispObject initForm = obj.cadr(); - LispObject svar = obj.cdr().cdr().car(); - if (optional == null) - optional = new ArrayList(); - optional.add(new Parameter(sym, initForm, svar, OPTIONAL)); - if (maxArgs >= 0) - ++maxArgs; - } - else if (state == STATE_KEYWORD) - { - Symbol keyword; - Symbol var; - LispObject initForm = NIL; - LispObject svar = NIL; - LispObject first = obj.car(); - if (first instanceof Cons) - { - keyword = checkSymbol(first.car()); - var = checkSymbol(first.cadr()); - } - else - { - var = checkSymbol(first); - keyword = - PACKAGE_KEYWORD.intern(var.name); - } - obj = obj.cdr(); - if (obj != NIL) - { - initForm = obj.car(); - obj = obj.cdr(); - if (obj != NIL) - svar = obj.car(); - } - if (keywords == null) - keywords = new ArrayList(); - keywords.add(new Parameter(keyword, var, initForm, svar)); - if (maxArgs >= 0) - maxArgs += 2; - } - else - invalidParameter(obj); - } - else - invalidParameter(obj); - remaining = remaining.cdr(); - } - if (arity == 0) - arity = length; - if (required != null) - { - requiredParameters = new Parameter[required.size()]; - required.toArray(requiredParameters); - } - if (optional != null) - { - optionalParameters = new Parameter[optional.size()]; - optional.toArray(optionalParameters); - } - if (keywords != null) - { - keywordParameters = new Parameter[keywords.size()]; - keywords.toArray(keywordParameters); - } - if (aux != null) - { - auxVars = new Parameter[aux.size()]; - aux.toArray(auxVars); - } - } - else - { - // Lambda list is empty. - Debug.assertTrue(lambdaList == NIL); - arity = 0; - maxArgs = 0; - } this.body = lambdaExpression.cddr(); LispObject bodyAndDecls = parseBody(this.body, false); this.executionBody = bodyAndDecls.car(); LispObject specials = parseSpecials(bodyAndDecls.NTH(1)); this.environment = env; - this.andKey = _andKey; - this.allowOtherKeys = _allowOtherKeys; - minArgs = requiredParameters.length; - if (arity >= 0) - Debug.assertTrue(arity == minArgs); arglist = new ArgumentListProcessor(this, lambdaList, specials); freeSpecials = arglist.freeSpecials(specials); - } - - private static final void invalidParameter(LispObject obj) - - { - error(new ProgramError(obj.princToString() + - " may not be used as a variable in a lambda list.")); + minArgs = arglist.getMinArgs(); + arity = arglist.getArity(); } @Override From ehuelsmann at common-lisp.net Mon Jan 30 10:10:01 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 30 Jan 2012 02:10:01 -0800 Subject: [armedbear-cvs] r13832 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 30 02:09:59 2012 New Revision: 13832 Log: Clean up references to non-existing variable. 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 Sun Jan 29 15:57:04 2012 (r13831) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Jan 30 02:09:59 2012 (r13832) @@ -82,9 +82,6 @@ && optional.length == 0) ? maxArgs : -1; - if (rest != NIL) - restVar = rest; - // stuff we don't need: we're a compiled function body = null; executionBody = null; @@ -110,7 +107,7 @@ key.keyword)); arglist = new ArgumentListProcessor(this, reqParams, optParams, keyParams, keys != NIL, - moreKeys != NIL, restVar); + moreKeys != NIL, rest); } From ehuelsmann at common-lisp.net Mon Jan 30 19:42:38 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 30 Jan 2012 11:42:38 -0800 Subject: [armedbear-cvs] r13833 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 30 11:42:37 2012 New Revision: 13833 Log: When there's no &rest parameter, pass 'null' as the value for its name. 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 Mon Jan 30 02:09:59 2012 (r13832) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Jan 30 11:42:37 2012 (r13833) @@ -107,7 +107,8 @@ key.keyword)); arglist = new ArgumentListProcessor(this, reqParams, optParams, keyParams, keys != NIL, - moreKeys != NIL, rest); + moreKeys != NIL, + (rest == NIL) ? null : rest); } From ehuelsmann at common-lisp.net Mon Jan 30 20:13:16 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 30 Jan 2012 12:13:16 -0800 Subject: [armedbear-cvs] r13834 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 30 12:13:16 2012 New Revision: 13834 Log: Further reduce footprint and complexity by eliminating helper functions. 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 Mon Jan 30 11:42:37 2012 (r13833) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Jan 30 12:13:16 2012 (r13834) @@ -171,131 +171,50 @@ @Override public LispObject execute() { - if (arity == 0) - { - return progn(executionBody, environment, - LispThread.currentThread()); - } - else return execute(new LispObject[0]); } - private final LispObject bindParametersAndExecute(LispObject... objects) - - { - final LispThread thread = LispThread.currentThread(); - final SpecialBindingsMark mark = thread.markSpecialBindings(); - - Environment ext = new Environment(environment); - LispObject[] args = arglist.match(objects, environment, ext, thread); - arglist.bindVars(args, ext, thread); - declareFreeSpecials(ext); - try - { - return progn(executionBody, ext, thread); - } - finally - { - thread.resetSpecialBindings(mark); - } - } - - public final LispObject invokeArrayExecute(LispObject... objects) - - { - return execute(objects); - } - @Override public LispObject execute(LispObject arg) { - if (minArgs == 1) - { - return bindParametersAndExecute(arg); - } - else - { - return invokeArrayExecute(arg); - } + return execute(new LispObject[] {arg}); } @Override public LispObject execute(LispObject first, LispObject second) - { - if (minArgs == 2) - { - return bindParametersAndExecute(first, second); - } - else - { - return invokeArrayExecute(first, second); - } + return execute(new LispObject[] {first, second}); } @Override public LispObject execute(LispObject first, LispObject second, LispObject third) - { - if (minArgs == 3) - { - return bindParametersAndExecute(first, second, third); - } - else - { - return invokeArrayExecute(first, second, third); - } + return execute(new LispObject[] {first, second, third}); } @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth) - { - if (minArgs == 4) - { - return bindParametersAndExecute(first, second, third, fourth); - } - else - { - return invokeArrayExecute(first, second, third, fourth); - } + return execute(new LispObject[] {first, second, third, fourth}); } @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth) - { - if (minArgs == 5) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth); - } + return execute(new LispObject[] {first, second, third, fourth, fifth}); } @Override public LispObject execute(LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth) - { - if (minArgs == 6) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth, sixth); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth, - sixth); - } + return execute(new LispObject[] {first, second, third, fourth, fifth, + sixth}); } @Override @@ -303,18 +222,9 @@ LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh) - { - if (minArgs == 7) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth, sixth, seventh); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth, - sixth, seventh); - } + return execute(new LispObject[] {first, second, third, fourth, fifth, + sixth, seventh}); } @Override @@ -322,24 +232,9 @@ LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, LispObject eighth) - - { - if (minArgs == 8) - { - return bindParametersAndExecute(first, second, third, fourth, - fifth, sixth, seventh, eighth); - } - else - { - return invokeArrayExecute(first, second, third, fourth, fifth, - sixth, seventh, eighth); - } - } - - private void declareFreeSpecials(Environment ext) { - for (Symbol special : freeSpecials) - ext.declareSpecial(special); + return execute(new LispObject[] {first, second, third, fourth, fifth, + sixth, seventh, eighth}); } @Override @@ -350,7 +245,8 @@ Environment ext = new Environment(environment); args = arglist.match(args, environment, ext, thread); arglist.bindVars(args, ext, thread); - declareFreeSpecials(ext); + for (Symbol special : freeSpecials) + ext.declareSpecial(special); try { return progn(executionBody, ext, thread); From ehuelsmann at common-lisp.net Mon Jan 30 20:24:27 2012 From: ehuelsmann at common-lisp.net (ehuelsmann at common-lisp.net) Date: Mon, 30 Jan 2012 12:24:27 -0800 Subject: [armedbear-cvs] r13835 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: ehuelsmann Date: Mon Jan 30 12:24:27 2012 New Revision: 13835 Log: Further cleanup of Closure.java. 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 Mon Jan 30 12:13:16 2012 (r13834) +++ trunk/abcl/src/org/armedbear/lisp/Closure.java Mon Jan 30 12:24:27 2012 (r13835) @@ -50,14 +50,9 @@ private final LispObject body; private final LispObject executionBody; private final Environment environment; - private int arity; - private int minArgs; - private int maxArgs; - - private Symbol[] freeSpecials = new Symbol[0]; - - private ArgumentListProcessor arglist; + private final Symbol[] freeSpecials; + private final ArgumentListProcessor arglist; /** Construct a closure object with a lambda-list described * by these parameters. @@ -74,14 +69,6 @@ Parameter[] optional, Parameter[] keyword, Symbol keys, Symbol rest, Symbol moreKeys) { - minArgs = required.length; - maxArgs = (rest == NIL && moreKeys == NIL) - ? minArgs + optional.length + 2*keyword.length : -1; - - arity = (rest == NIL && moreKeys == NIL && keys == NIL - && optional.length == 0) - ? maxArgs : -1; - // stuff we don't need: we're a compiled function body = null; executionBody = null; @@ -109,6 +96,7 @@ keyParams, keys != NIL, moreKeys != NIL, (rest == NIL) ? null : rest); + freeSpecials = new Symbol[0]; } @@ -136,8 +124,6 @@ arglist = new ArgumentListProcessor(this, lambdaList, specials); freeSpecials = arglist.freeSpecials(specials); - minArgs = arglist.getMinArgs(); - arity = arglist.getArity(); } @Override From mevenson at common-lisp.net Tue Jan 31 17:24:53 2012 From: mevenson at common-lisp.net (mevenson at common-lisp.net) Date: Tue, 31 Jan 2012 09:24:53 -0800 Subject: [armedbear-cvs] r13836 - trunk/abcl/contrib/abcl-asdf Message-ID: Author: mevenson Date: Tue Jan 31 09:24:52 2012 New Revision: 13836 Log: abcl-asdf: Enable the specification of an http(s) proxy in ABCL-ASDF:*maven-http-proxy*. ABCL-ASDF:*MAVEN-VERBOSE* now controls the stream to which the Maven Aether repository system reports progress in resolving dependencies. The logging messages could be presented in a perhaps slightly less verbose method. Refactor the setting of various subsystem in special variables with associated ENSURE-* methods. Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp trunk/abcl/contrib/abcl-asdf/packages.lisp Modified: trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Mon Jan 30 12:24:27 2012 (r13835) +++ trunk/abcl/contrib/abcl-asdf/maven-embedder.lisp Tue Jan 31 09:24:52 2012 (r13836) @@ -34,7 +34,7 @@ (let ((mvn (find-mvn))) (unless mvn (warn "Failed to find Maven3 libraries.") - (return-from find-mvn-libs)) + (return-from find-mvn-libs nil)) (truename (make-pathname :defaults (merge-pathnames "../lib/" mvn) :name nil :type nil)))) @@ -145,6 +145,54 @@ session (#"newLocalRepositoryManager" repository-system local-repository)))) +(defparameter *session* nil + "Reference to the Maven RepositorySystemSession") + +(defparameter *maven-http-proxy* nil + "A string containing the URI of an http proxy for Maven to use.") + +(defparameter *repository-system* nil) + +(defun ensure-repository-system () + (unless *repository-system* + (setf *repository-system* (repository-system))) + *repository-system*) + +(defun make-proxy () + "Return an org.sonatype.aether.repository.Proxy instance initialized form *MAVEN-HTTP-PROXY*." + (unless *maven-http-proxy* + (warn "No proxy specified in *MAVEN-HTTP-PROXY*") + (return-from make-proxy nil)) + (let* ((p (pathname *maven-http-proxy*)) + (scheme (sys::url-pathname-scheme p)) + (authority (sys::url-pathname-authority p)) + (host (if (search ":" authority) + (subseq authority 0 (search ":" authority)) + authority)) + (port (when (search ":" authority) + (parse-integer (subseq authority (1+ (search ":" authority)))))) + ;; TODO allow specification of authentication + (authentication java:+null+)) + (jss:new 'org.sonatype.aether.repository.Proxy + scheme host port authentication))) + +(defun ensure-session () + "Ensure that the RepositorySystemSession has been created. + +If *MAVEN-HTTP-PROXY* is non-nil, parse its value as the http proxy." + (unless *session* + (ensure-repository-system) + (setf *session* (new-session *repository-system*)) + (#"setRepositoryListener" *session* (make-repository-listener)) + (when *maven-http-proxy* + (let ((proxy (make-proxy))) + (#"add" (#"getProxySelector" *session*) + proxy + ;; A string specifying non proxy hosts, or null + java:+null+)))) + *session*) + + (defun resolve-artifact (group-id artifact-id &optional (version "LATEST" versionp)) "Directly resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID at VERSION, ignoring dependencies. @@ -174,6 +222,8 @@ (#"addRepository" artifact-request repository) (#"resolveArtifact" system session artifact-request))) +(defparameter *aether-remote-repository* nil) ;;; TODO + (defun resolve-dependencies (group-id artifact-id &optional (version "LATEST" versionp)) "Dynamically resolve Maven dependencies for item with GROUP-ID and ARTIFACT-ID at VERSION. @@ -186,11 +236,11 @@ (unless *init* (init)) (unless versionp (warn "Using LATEST for unspecified version.")) - (let* ((system - (repository-system)) - (session - (new-session system)) - (artifact + (let* ;;((system + ;; (repository-system)) + ;; (session + ;; (new-session system)) + ((artifact (java:jnew (jss:find-java-class "aether.util.artifact.DefaultArtifact") (format nil "~A:~A:~A" group-id artifact-id version))) @@ -202,20 +252,46 @@ "central" "default" "http://repo1.maven.org/maven2/")) (collect-request (java:jnew (jss:find-java-class "CollectRequest")))) (#"setRoot" collect-request dependency) + (when *maven-http-proxy* + (#"setProxy" central (make-proxy))) (#"addRepository" collect-request central) (let* ((node - (#"getRoot" (#"collectDependencies" system session collect-request))) + (#"getRoot" (#"collectDependencies" (ensure-repository-system) (ensure-session) collect-request))) (dependency-request (java:jnew (jss:find-java-class "DependencyRequest") node java:+null+)) (nlg (java:jnew (jss:find-java-class "PreorderNodeListGenerator")))) - (#"resolveDependencies" system session dependency-request) + (#"resolveDependencies" (ensure-repository-system) (ensure-session) dependency-request) (#"accept" node nlg) (#"getClassPath" nlg)))) +(defparameter *maven-verbose* t + "Stream to send output from the Maven Aether subsystem to, or NIL to muffle output") - +(defun make-repository-listener () + ;;; XXX why does the (flet ((log (e) ...)) (java:jinterface-implementation ...) version not work? + (java:jinterface-implementation + "org.sonatype.aether.RepositoryListener" + "artifactDeployed" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactDeploying" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactDescriptorInvalid" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactDescriptorMissing" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactDownloaded" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactDownloading" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactInstalled" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactInstalling" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactResolved" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "artifactResolving" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataDeployed" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataDeploying" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataDownloaded" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataDownloading" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataInstalled" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataInstalling" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataInvalid" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataResolved" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))) + "metadataResolving" (lambda (e) (format *maven-verbose* "~&transfer-listener: ~A~%" (#"toString" e))))) Modified: trunk/abcl/contrib/abcl-asdf/packages.lisp ============================================================================== --- trunk/abcl/contrib/abcl-asdf/packages.lisp Mon Jan 30 12:24:27 2012 (r13835) +++ trunk/abcl/contrib/abcl-asdf/packages.lisp Tue Jan 31 09:24:52 2012 (r13836) @@ -14,6 +14,8 @@ ;;;; Maven #:*mvn-libs-directory* + #:*maven-http-proxy* + #:*maven-verbose* #:satisfy #:as-classpath From rschlatte at common-lisp.net Tue Jan 31 23:01:46 2012 From: rschlatte at common-lisp.net (rschlatte at common-lisp.net) Date: Tue, 31 Jan 2012 15:01:46 -0800 Subject: [armedbear-cvs] r13837 - trunk/abcl/src/org/armedbear/lisp Message-ID: Author: rschlatte Date: Tue Jan 31 15:01:45 2012 New Revision: 13837 Log: Implement specializer-method--related protocol. Add add-direct-method, remove-direct-method, specializer-direct-methods, specializer-direct-generic-functions Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java trunk/abcl/src/org/armedbear/lisp/StandardClass.java trunk/abcl/src/org/armedbear/lisp/clos.lisp trunk/abcl/src/org/armedbear/lisp/mop.lisp Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Jan 31 09:24:52 2012 (r13836) +++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Jan 31 15:01:45 2012 (r13837) @@ -5561,7 +5561,7 @@ if (arg instanceof LispClass) return ((LispClass)arg).getDocumentation(); else - return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDocumentation); + return ((StandardObject)arg).getInstanceSlotValue(Symbol.DOCUMENTATION); } }; @@ -5579,7 +5579,7 @@ if (first instanceof LispClass) ((LispClass)first).setDocumentation(second); else - ((StandardObject)first).setInstanceSlotValue(StandardClass.symDocumentation, second); + ((StandardObject)first).setInstanceSlotValue(Symbol.DOCUMENTATION, second); return second; } }; Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Jan 31 09:24:52 2012 (r13836) +++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Tue Jan 31 15:01:45 2012 (r13837) @@ -48,8 +48,6 @@ = PACKAGE_MOP.intern("PRECEDENCE-LIST"); public static Symbol symDirectMethods = PACKAGE_MOP.intern("DIRECT-METHODS"); - public static Symbol symDocumentation - = PACKAGE_MOP.intern("DOCUMENTATION"); public static Symbol symDirectSlots = PACKAGE_MOP.intern("DIRECT-SLOTS"); public static Symbol symSlots @@ -61,6 +59,17 @@ public static Symbol symFinalizedP = PACKAGE_MOP.intern("FINALIZED-P"); + // used as init-function for slots in this file. + static Function constantlyNil = new Function() { + @Override + public LispObject execute() + { + return NIL; + } + }; + + + static Layout layoutStandardClass = new Layout(null, list(symName, @@ -74,7 +83,7 @@ symDirectDefaultInitargs, symDefaultInitargs, symFinalizedP, - symDocumentation), + Symbol.DOCUMENTATION), NIL) { @Override @@ -226,13 +235,13 @@ @Override public LispObject getDocumentation() { - return getInstanceSlotValue(symDocumentation); + return getInstanceSlotValue(Symbol.DOCUMENTATION); } @Override public void setDocumentation(LispObject doc) { - setInstanceSlotValue(symDocumentation, doc); + setInstanceSlotValue(Symbol.DOCUMENTATION, doc); } @Override @@ -334,28 +343,18 @@ private static final LispObject standardClassSlotDefinitions() { - // (CONSTANTLY NIL) - Function initFunction = new Function() { - @Override - public LispObject execute() - { - return NIL; - } - }; - return - list(helperMakeSlotDefinition("NAME", initFunction), - helperMakeSlotDefinition("LAYOUT", initFunction), - helperMakeSlotDefinition("DIRECT-SUPERCLASSES", initFunction), - helperMakeSlotDefinition("DIRECT-SUBCLASSES", initFunction), - helperMakeSlotDefinition("PRECEDENCE-LIST", initFunction), - helperMakeSlotDefinition("DIRECT-METHODS", initFunction), - helperMakeSlotDefinition("DIRECT-SLOTS", initFunction), - helperMakeSlotDefinition("SLOTS", initFunction), - helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", initFunction), - helperMakeSlotDefinition("DEFAULT-INITARGS", initFunction), - helperMakeSlotDefinition("FINALIZED-P", initFunction), - helperMakeSlotDefinition("DOCUMENTATION", initFunction)); + list(helperMakeSlotDefinition("NAME", constantlyNil), + helperMakeSlotDefinition("LAYOUT", constantlyNil), + helperMakeSlotDefinition("DIRECT-SUPERCLASSES", constantlyNil), + helperMakeSlotDefinition("DIRECT-SUBCLASSES", constantlyNil), + helperMakeSlotDefinition("PRECEDENCE-LIST", constantlyNil), + helperMakeSlotDefinition("DIRECT-SLOTS", constantlyNil), + helperMakeSlotDefinition("SLOTS", constantlyNil), + helperMakeSlotDefinition("DIRECT-DEFAULT-INITARGS", constantlyNil), + helperMakeSlotDefinition("DEFAULT-INITARGS", constantlyNil), + helperMakeSlotDefinition("FINALIZED-P", constantlyNil), + helperMakeSlotDefinition("DOCUMENTATION", constantlyNil)); } @@ -673,25 +672,26 @@ EQL_SPECIALIZER.setCPL(EQL_SPECIALIZER, SPECIALIZER, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); EQL_SPECIALIZER.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.OBJECT, list(PACKAGE_MOP.intern("EQL-SPECIALIZER-OBJECT"))))); + list(new SlotDefinition(Symbol.OBJECT, NIL, constantlyNil), + new SlotDefinition(symDirectMethods, NIL, constantlyNil))); METHOD.setCPL(METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_METHOD.setCPL(STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_METHOD.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL), - new SlotDefinition(Symbol.LAMBDA_LIST, NIL), - new SlotDefinition(Symbol.KEYWORDS, NIL), - new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL), - new SlotDefinition(Symbol.SPECIALIZERS, NIL), - new SlotDefinition(Symbol.QUALIFIERS, NIL), - new SlotDefinition(Symbol.FUNCTION, NIL), - new SlotDefinition(Symbol.FAST_FUNCTION, NIL), - new SlotDefinition(Symbol.DOCUMENTATION, NIL))); + list(new SlotDefinition(Symbol.GENERIC_FUNCTION, NIL, constantlyNil), + new SlotDefinition(Symbol.LAMBDA_LIST, NIL, constantlyNil), + new SlotDefinition(Symbol.KEYWORDS, NIL, constantlyNil), + new SlotDefinition(Symbol.OTHER_KEYWORDS_P, NIL, constantlyNil), + new SlotDefinition(Symbol.SPECIALIZERS, NIL, constantlyNil), + new SlotDefinition(Symbol.QUALIFIERS, NIL, constantlyNil), + new SlotDefinition(Symbol.FUNCTION, NIL, constantlyNil), + new SlotDefinition(Symbol.FAST_FUNCTION, NIL, constantlyNil), + new SlotDefinition(Symbol.DOCUMENTATION, NIL, constantlyNil))); STANDARD_ACCESSOR_METHOD.setCPL(STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); STANDARD_ACCESSOR_METHOD.setDirectSlotDefinitions( - list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL))); + list(new SlotDefinition(Symbol.SLOT_DEFINITION, NIL))); STANDARD_READER_METHOD.setCPL(STANDARD_READER_METHOD, STANDARD_ACCESSOR_METHOD, STANDARD_METHOD, METHOD, METAOBJECT, STANDARD_OBJECT, @@ -704,9 +704,11 @@ BuiltInClass.CLASS_T); METHOD_COMBINATION.setDirectSlotDefinitions( list(new SlotDefinition(Symbol.NAME, - list(Symbol.METHOD_COMBINATION_NAME)), + list(Symbol.METHOD_COMBINATION_NAME), + constantlyNil), new SlotDefinition(Symbol.DOCUMENTATION, - list(Symbol.METHOD_COMBINATION_DOCUMENTATION)))); + list(Symbol.METHOD_COMBINATION_DOCUMENTATION), + constantlyNil))); SHORT_METHOD_COMBINATION.setCPL(SHORT_METHOD_COMBINATION, METHOD_COMBINATION, METAOBJECT, STANDARD_OBJECT, BuiltInClass.CLASS_T); @@ -813,7 +815,6 @@ STANDARD_CLASS.finalizeClass(); STANDARD_OBJECT.finalizeClass(); FUNCALLABLE_STANDARD_OBJECT.finalizeClass(); - CLASS.finalizeClass(); FUNCALLABLE_STANDARD_CLASS.finalizeClass(); FORWARD_REFERENCED_CLASS.finalizeClass(); GENERIC_FUNCTION.finalizeClass(); @@ -840,6 +841,8 @@ STANDARD_READER_METHOD.finalizeClass(); STANDARD_WRITER_METHOD.finalizeClass(); SPECIALIZER.finalizeClass(); + CLASS.finalizeClass(); + BUILT_IN_CLASS.finalizeClass(); EQL_SPECIALIZER.finalizeClass(); METHOD_COMBINATION.finalizeClass(); SHORT_METHOD_COMBINATION.finalizeClass(); Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 31 09:24:52 2012 (r13836) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Tue Jan 31 15:01:45 2012 (r13837) @@ -1181,6 +1181,7 @@ ;; setup, so have to rely on plain functions here. (let ((instance (std-allocate-instance (find-class 'eql-specializer)))) (setf (std-slot-value instance 'sys::object) object) + (setf (std-slot-value instance 'direct-methods) nil) instance)))) (defun eql-specializer-object (eql-specializer) @@ -1776,6 +1777,21 @@ (getf analyzed-args :allow-other-keys)) method)) +;;; To be redefined as generic functions later +(declaim (notinline add-direct-method)) +(defun add-direct-method (specializer method) + (if (typep specializer 'eql-specializer) + (pushnew method (std-slot-value specializer 'direct-methods)) + (pushnew method (class-direct-methods specializer)))) + +(declaim (notinline remove-direct-method)) +(defun remove-direct-method (specializer method) + (if (typep specializer 'eql-specializer) + (setf (std-slot-value specializer 'direct-methods) + (remove method (std-slot-value specializer 'direct-methods))) + (setf (class-direct-methods specializer) + (remove method (class-direct-methods specializer))))) + (defun std-add-method (gf method) (when (and (method-generic-function method) (not (eql gf (method-generic-function method)))) @@ -1790,9 +1806,7 @@ (setf (std-slot-value method 'generic-function) gf) (push method (generic-function-methods gf)) (dolist (specializer (method-specializers method)) - ;; FIXME use add-direct-method here (AMOP pg. 165)) - (when (typep specializer 'class) - (pushnew method (class-direct-methods specializer)))) + (add-direct-method specializer method)) (finalize-standard-generic-function gf) gf) @@ -1801,10 +1815,7 @@ (remove method (generic-function-methods gf))) (setf (std-slot-value method 'generic-function) nil) (dolist (specializer (method-specializers method)) - ;; FIXME use remove-direct-method here (AMOP pg. 227) - (when (typep specializer 'class) - (setf (class-direct-methods specializer) - (remove method (class-direct-methods specializer))))) + (remove-direct-method specializer method)) (finalize-standard-generic-function gf) gf) @@ -3727,6 +3738,45 @@ (:method ((method standard-accessor-method)) (std-accessor-method-slot-definition method))) +;;; specializer-direct-method and friends. + +;;; AMOP pg. 237 +(defgeneric specializer-direct-generic-functions (specializer)) + +(defmethod specializer-direct-generic-functions ((specializer class)) + (delete-duplicates (mapcar #'method-generic-function + (class-direct-methods specializer)))) + +(defmethod specializer-direct-generic-functions ((specializer eql-specializer)) + (delete-duplicates (mapcar #'method-generic-function + (slot-value specializer 'direct-methods)))) + +;;; AMOP pg. 238 +(defgeneric specializer-direct-methods (specializer)) + +(defmethod specializer-direct-methods ((specializer class)) + (class-direct-methods specializer)) + +(defmethod specializer-direct-methods ((specializer eql-specializer)) + (slot-value specializer 'direct-methods)) + +;;; AMOP pg. 165 +(atomic-defgeneric add-direct-method (specializer method) + (:method ((specializer class) (method method)) + (pushnew method (class-direct-methods specializer))) + (:method ((specializer eql-specializer) (method method)) + (pushnew method (slot-value specializer 'direct-methods)))) + + +;;; AMOP pg. 227 +(atomic-defgeneric remove-direct-method (specializer method) + (:method ((specializer class) (method method)) + (setf (class-direct-methods specializer) + (remove method (class-direct-methods specializer)))) + (:method ((specializer eql-specializer) (method method)) + (setf (slot-value specializer 'direct-methods) + (remove method (slot-value specializer 'direct-methods))))) + ;;; SLIME compatibility functions. (defun %method-generic-function (method) Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp ============================================================================== --- trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jan 31 09:24:52 2012 (r13836) +++ trunk/abcl/src/org/armedbear/lisp/mop.lisp Tue Jan 31 15:01:45 2012 (r13837) @@ -73,11 +73,16 @@ slot-definition-readers slot-definition-writers + intern-eql-specializer eql-specializer-object + specializer-direct-methods + specializer-direct-generic-functions + add-direct-method + remove-direct-method + extract-lambda-list extract-specializer-names - - intern-eql-specializer)) + )) (provide 'mop)