Changeset 13775 for trunk/abcl/src/org/armedbear/lisp/clos.lisp

Timestamp:

01/14/12 20:07:00 (11 years ago)

Author:

rschlatte

Message:

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.

File:

• trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (14 diffs)

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

@@ -686 +686 @@
     (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
@@ -2651 +2656 @@
 (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))
@@ -2664 +2671 @@
 
 (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
@@ -2675 +2688 @@
 
 (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))
 
@@ -2686 +2701 @@
 (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."
@@ -2693 +2710 @@
 (defgeneric slot-makunbound-using-class (class instance slot-name))
 (defmethod slot-makunbound-using-class ((class standard-class)
+                                        instance
+                                        slot-name)
+  (std-slot-makunbound instance slot-name))
+(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
                                         instance
                                         slot-name)
@@ -2720 +2741 @@
   (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)
@@ -2812 +2837 @@
 (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."))
@@ -2828 +2853 @@
         (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)
@@ -2956 +2981 @@
 (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))
@@ -2988 +3014 @@
   (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*)
@@ -3013 +3043 @@
 (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
@@ -3026 +3058 @@
   ((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.
 
@@ -3314 +3348 @@
   (allocate-instance class))
 
+(defmethod class-prototype ((class funcallable-standard-class))
+  (allocate-instance class))
+
 (defmethod class-prototype ((class structure-class))
   (allocate-instance class))