Changeset 13990

Timestamp:

07/02/12 16:33:36 (8 years ago)

Author:

rschlatte

Message:

Implement make-method-lambda

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• clos.lisp (modified) (10 diffs)
• mop.lisp (modified) (1 diff)

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

@@ -801 +801 @@
 
 (defun std-allocate-instance (class)
-  ;; AMOP says ALLOCATE-INSTANCE checks if the class is finalized
-  ;; and if not, tries to finalize it.
-  (unless (class-finalized-p class)
-    (std-finalize-inheritance class))
   (sys::%std-allocate-instance class))
 
 (defun allocate-funcallable-instance (class)
-  (unless (class-finalized-p class)
-    (std-finalize-inheritance class))
   (let ((instance (sys::%allocate-funcallable-instance class)))
     (set-funcallable-instance-function
@@ -817 +811 @@
          (error 'program-error "Called a funcallable-instance with unset function.")))
     instance))
+
+(declaim (notinline class-prototype))
+(defun class-prototype (class)
+  (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class)))
+  (std-allocate-instance class))
 
 (defun make-instance-standard-class (metaclass
@@ -1388 +1387 @@
 (defun method-generic-function (method)
   (std-method-generic-function method))
+
+(declaim (notinline method-function))
+(defun method-function (method)
+  (std-method-function method))
 
 (declaim (notinline method-specializers))
@@ -2603 +2606 @@
            nil))))))
 
+(declaim (notinline make-method-lambda))
+(defun make-method-lambda (generic-function method lambda-expression env)
+  (declare (ignore generic-function method env))
+  (values (compute-method-function lambda-expression) nil))
+
+
 ;; From CLHS section 7.6.5:
 ;; "When a generic function or any of its methods mentions &key in a lambda
@@ -2619 +2628 @@
       lambda-list))
 
-(defmacro defmethod (&rest args)
+(defmacro defmethod (&rest args &environment env)
   (multiple-value-bind
       (function-name qualifiers lambda-list specializers documentation declarations body)
@@ -2625 +2634 @@
     (let* ((specializers-form '())
            (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
-           (method-function (compute-method-function lambda-expression))
+           (gf (or (find-generic-function function-name nil)
+                   (ensure-generic-function function-name :lambda-list lambda-list)))
+           (method-function
+             (make-method-lambda gf (class-prototype (generic-function-method-class gf))
+                                 lambda-expression env))
            (fast-function (compute-method-fast-function lambda-expression))
            )
@@ -3339 +3352 @@
 ;;; Instance creation and initialization
 
-;;; AMOP pg. 168ff.  Checking whether the class is finalized is done
-;;; inside std-allocate-instance and allocate-funcallable-instance.
+;;; AMOP pg. 168ff.
 (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
 
@@ -3360 +3372 @@
   (declare (ignore initargs))
   (error "Cannot allocate instances of a built-in class: ~S" class))
+
+(defmethod allocate-instance :before ((class class) &rest initargs)
+  (declare (ignore initargs))
+  (unless (class-finalized-p class)
+    (finalize-inheritance class)))
 
 ;; "The set of valid initialization arguments for a class is the set of valid
@@ -3783 +3800 @@
   (%compute-applicable-methods gf args))
 
+;;; AMOP pg. 207
+(atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment)
+  (:method ((generic-function standard-generic-function)
+            (method standard-method)
+            lambda-expression environment)
+    (declare (ignore environment))
+    (values (compute-method-function lambda-expression) nil)))
+
+
 ;;; Slot definition accessors
 
@@ -4084 +4110 @@
 (setf *clos-booting* nil)
 
-(defgeneric class-prototype (class))
-
-(defmethod class-prototype :before (class)
-  (unless (class-finalized-p class)
-    (error "~@<~S is not finalized.~:@>" class)))
-
-(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))
+(atomic-defgeneric class-prototype (class)
+  (:method ((class standard-class))
+    (allocate-instance class))
+  (:method ((class funcallable-standard-class))
+    (allocate-instance class))
+  (:method ((class structure-class))
+    (allocate-instance class))
+  (:method :before (class)
+    (unless (class-finalized-p class)
+      (error "~@<~S is not finalized.~:@>" class))))
+
+
+
+
 
 (defmethod shared-initialize :before ((instance generic-function)

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

@@ -61 +61 @@
           compute-applicable-methods-using-classes
           compute-effective-method
+          make-method-lambda
           compute-slots
           finalize-inheritance