[armedbear-cvs] r13782 - trunk/abcl/src/org/armedbear/lisp
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Sun Jan 15 21:55:47 UTC 2012
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"))
More information about the armedbear-cvs
mailing list