[armedbear-cvs] r13990 - trunk/abcl/src/org/armedbear/lisp

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Mon Jul  2 09:33:36 2012
New Revision: 13990

Log:
Implement make-method-lambda

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/src/org/armedbear/lisp/mop.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Jun 30 12:11:12 2012	(r13989)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Mon Jul  2 09:33:36 2012	(r13990)
@@ -800,15 +800,9 @@
   (eq (slot-definition-allocation slot) :instance))
 
 (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
      instance
@@ -817,6 +811,11 @@
          (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
                                      &rest initargs
                                      &key name direct-superclasses direct-slots
@@ -1388,6 +1387,10 @@
 (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))
 (defun method-specializers (method)
   (std-method-specializers method))
@@ -2602,6 +2605,12 @@
           (t
            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
 ;; list, the specific set of keyword arguments accepted by the generic function
@@ -2618,13 +2627,17 @@
         `(,@(subseq lambda-list 0 key-end) &allow-other-keys , at aux-part))
       lambda-list))
 
-(defmacro defmethod (&rest args)
+(defmacro defmethod (&rest args &environment env)
   (multiple-value-bind
       (function-name qualifiers lambda-list specializers documentation declarations body)
       (parse-defmethod args)
     (let* ((specializers-form '())
            (lambda-expression `(lambda ,lambda-list , at 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))
            )
       (dolist (specializer specializers)
@@ -3338,8 +3351,7 @@
 
 ;;; 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))
 
 (defmethod allocate-instance ((class standard-class) &rest initargs)
@@ -3360,6 +3372,11 @@
   (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
 ;; initialization arguments that either fill slots or supply arguments to
 ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
@@ -3782,6 +3799,15 @@
 (defmethod compute-applicable-methods ((gf standard-generic-function) args)
   (%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
 
 (defmacro slot-definition-dispatch (slot-definition std-form generic-form)
@@ -4083,20 +4109,20 @@
 (setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance))
 (setf *clos-booting* nil)
 
-(defgeneric class-prototype (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 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))
 
 (defmethod shared-initialize :before ((instance generic-function)
                                       slot-names

Modified: trunk/abcl/src/org/armedbear/lisp/mop.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/mop.lisp	Sat Jun 30 12:11:12 2012	(r13989)
+++ trunk/abcl/src/org/armedbear/lisp/mop.lisp	Mon Jul  2 09:33:36 2012	(r13990)
@@ -60,6 +60,7 @@
           compute-applicable-methods
           compute-applicable-methods-using-classes
           compute-effective-method
+          make-method-lambda
           compute-slots
           finalize-inheritance
           validate-superclass