New class METHOD-COMBINATION used in combin.lsp

src/CHANGELOG

@@ -77,6 +77,9 @@ ECL 12.2.2:
  - The method combination slot of a generic function is now precomputed by
    using FIND-METHOD-COMBINATION in SHARED-INITIALIZE.
 
+ - METHOD-COMBINATION is now a class with slots and it is used by ECL for
+   computing effective methods.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/c/instance.d

@@ -257,7 +257,6 @@ enum ecl_built_in_classes {
 	ECL_BUILTIN_SYMBOL,
 	ECL_BUILTIN_NULL,
 	ECL_BUILTIN_KEYWORD,
-	ECL_BUILTIN_METHOD_COMBINATION,
 	ECL_BUILTIN_PACKAGE,
 	ECL_BUILTIN_FUNCTION,
 	ECL_BUILTIN_PATHNAME,

src/clos/boot.lsp

@@ -66,6 +66,7 @@
         (make-empty-standard-class 'FUNCALLABLE-STANDARD-CLASS
                                    standard-class))
        (metaobject (make-empty-standard-class 'METAOBJECT standard-class))
+       (method-combination (make-empty-standard-class 'METHOD-COMBINATION standard-class))
        (specializer (make-empty-standard-class 'SPECIALIZER standard-class))
        (eql-specializer (make-empty-standard-class 'EQL-SPECIALIZER standard-class))
        (the-class (make-empty-standard-class 'CLASS standard-class))
@@ -79,6 +80,7 @@
   (add-slots std-class #1='#.(remove-accessors +standard-class-slots+))
   (add-slots standard-class #1#)
   (add-slots funcallable-standard-class #1#)
+  (add-slots method-combination '#.(remove-accessors +method-combination-slots+))
   (add-slots specializer '#.(remove-accessors +specializer-slots+))
   (add-slots eql-specializer '#.(remove-accessors +eql-specializer-slots+))
 
@@ -116,19 +118,22 @@
 	(class-direct-superclasses standard-object) (list the-t)
 	(class-direct-subclasses standard-object) (list metaobject)
 	(class-direct-superclasses metaobject) (list standard-object)
-	(class-direct-subclasses metaobject) (list specializer)
+	(class-direct-subclasses metaobject) (list specializer method-combination)
+	(class-direct-superclasses method-combination) (list metaobject)
 	(class-direct-superclasses specializer) (list metaobject)
 	(class-direct-subclasses specializer) (list the-class eql-specializer)
 	(class-direct-superclasses eql-specializer) (list specializer)
 	(class-direct-superclasses the-class) (list specializer)
 	(class-direct-subclasses the-class) (list std-class)
 	(class-direct-superclasses std-class) (list the-class)
+	(class-direct-subclasses std-class) (list standard-class funcallable-standard-class)
 	(class-direct-superclasses standard-class) (list std-class)
 	(class-direct-superclasses funcallable-standard-class) (list std-class))
 
   (si::instance-sig-set the-t)
   (si::instance-sig-set standard-object)
   (si::instance-sig-set metaobject)
+  (si::instance-sig-set method-combination)
   (si::instance-sig-set specializer)
   (si::instance-sig-set eql-specializer)
   (si::instance-sig-set the-class)
@@ -144,6 +149,8 @@
 	  (setf cpl (list* standard-object cpl))
 	  (class-precedence-list metaobject)
 	  (setf cpl (list* metaobject cpl))
+	  (class-precedence-list method-combination)
+	  (list* method-combination cpl)
 	  (class-precedence-list specializer)
 	  (setf cpl (list* specializer cpl))
 	  (class-precedence-list eql-specializer)

src/clos/builtin.lsp

@@ -33,7 +33,8 @@
 		     :direct-superclasses (list (find-class 'class))
 		     :direct-slots nil))
 
-(si:instance-class-set (find-class 't) (find-class 'built-in-class))
+(si:instance-class-set +the-t-class+ (find-class 'built-in-class))
+(si::instance-sig-set +the-t-class+)
 
 (defmethod make-instance ((class built-in-class) &rest initargs)
   (declare (ignore initargs))
@@ -76,7 +77,6 @@
 	    (symbol)
 	      (null symbol list)
 	      (keyword symbol)
-	    (method-combination)
 	    (package)
 	    (function)
 	    (pathname)

src/clos/combin.lsp

@@ -198,17 +198,19 @@
     (setf (gethash name *method-combinations*) function))
   name)
 
-(defun method-combination-object-p (o)
-  (and (listp o)
-       (= (length o) 3)
-       (eq (first o)
-	   (mp:with-lock (*method-combinations-lock*)
-	     (gethash (third o) *method-combinations*)))))
+(defun make-method-combination (name compiler options)
+  (let ((o (si:allocate-raw-instance nil (find-class 'method-combination)
+				     #.(length +method-combination-slots+))))
+    (setf (method-combination-compiler o) compiler
+	  (method-combination-name o) name
+	  (method-combination-options o) options)
+    o))
 
 (defun find-method-combination (gf method-combination-type-name method-combination-options)
-  (list (search-method-combination method-combination-type-name)
-	method-combination-options
-	method-combination-type-name))
+  (make-method-combination method-combination-type-name
+			   (search-method-combination method-combination-type-name)
+			   method-combination-options
+			   ))
 
 (defun define-simple-method-combination (name &key documentation
 					 identity-with-one-argument
@@ -321,14 +323,11 @@
 ;;;
 
 (defun std-compute-effective-method (gf method-combination applicable-methods)
-  (let* ((method-combination-function (first method-combination))
-	 (method-combination-args (second method-combination)))
-    (if method-combination-args
-	(apply method-combination-function
-	       gf applicable-methods
-	       method-combination-args)
-	(funcall method-combination-function
-		 gf applicable-methods))))
+  (let* ((compiler (method-combination-compiler method-combination))
+	 (options (method-combination-options method-combination)))
+    (if options
+	(apply compiler gf applicable-methods options)
+	(funcall compiler gf applicable-methods))))
 
 ;;
 ;; These method combinations are bytecompiled, for simplicity.

src/clos/generic.lsp

@@ -159,7 +159,7 @@
 			    gfun lambda-list)))
   (call-next-method)
   (let ((combination (generic-function-method-combination gfun)))
-    (unless (method-combination-object-p combination)
+    (unless (typep combination 'method-combination)
       (setf (generic-function-method-combination gfun)
 	    (find-method-combination gfun (first combination) (rest combination)))))
   (when (and l-l-p (not a-o-p))

src/clos/kernel.lsp

@@ -74,6 +74,17 @@
 
 #.(create-accessors +eql-specializer-slots+ 'eql-specializer)
 
+;;; ----------------------------------------------------------------------
+;;; Class METHOD-COMBINATION
+
+(eval-when (compile eval)
+  (defparameter +method-combination-slots+
+    `((name :initform :name :accessor method-combination-name)
+      (compiler :initform :compiler :accessor method-combination-compiler)
+      (options :initform :options :accessor method-combination-options))))
+
+#.(create-accessors +method-combination-slots+ 'method-combination)
+
 ;;; ----------------------------------------------------------------------
 ;;; Class CLASS
 
@@ -126,7 +137,7 @@
        :accessor generic-function-name)
       (spec-list :initform nil :accessor generic-function-spec-list)
       (method-combination 
-       :initarg :method-combination :initform '(standard-compute-effective-method nil standard)
+       :initarg :method-combination :initform (find-method-combination nil 'standard nil)
        :accessor generic-function-method-combination)
       (lambda-list :initarg :lambda-list
        :accessor generic-function-lambda-list)