[armedbear-cvs] r13715 - trunk/abcl/src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Wed Jan 4 20:34:40 UTC 2012
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 <rudi at constantly.at>
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))))))))))
More information about the armedbear-cvs
mailing list