Changeset 13782

Timestamp:

01/15/12 21:55:45 (11 years ago)

Author:

rschlatte

Message:

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)

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• Autoload.java (modified) (2 diffs)
• StandardGenericFunction.java (modified) (4 diffs)
• clos.lisp (modified) (5 diffs)

trunk/abcl/src/org/armedbear/lisp/Autoload.java

@@ -536 +536 @@
         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);
@@ -640 +639 @@
         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);

trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

@@ -319 +319 @@
   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
@@ -352 +352 @@
   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
@@ -385 +385 @@
   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
@@ -419 +419 @@
   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

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -1269 +1269 @@
 ;;   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))
@@ -1279 +1282 @@
   (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))
@@ -1845 +1856 @@
 
 (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)))
@@ -1880 +1892 @@
              ((= 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)
@@ -3370 +3382 @@
   (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"))