Implemented COMPUTE-DISCRIMINATING-FUNCTION

src/CHANGELOG

@@ -64,6 +64,8 @@ ECL 12.2.2:
  - DEFMETHOD now relies on MAKE-METHOD-LAMBDA to create the appropriate
    function.
 
+ - Implemented COMPUTE-DISCRIMINATING-FUNCTION.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/clos/fixup.lsp

@@ -225,7 +225,9 @@ their lambda lists ~A and ~A are not congruent."
 	(method-generic-function method) nil)
   (si:clear-gfun-hash gf)
   (loop for spec in (method-specializers method)
-     do (add-direct-method spec method))
+     do (remove-direct-method spec method))
+  (compute-g-f-spec-list gf)
+  (set-generic-function-dispatch gf)
   (update-dependents gf (list 'remove-method method))
   gf)
 
@@ -344,3 +346,5 @@ their lambda lists ~A and ~A are not congruent."
 
 (function-to-method 'make-method-lambda
   '((gf standard-generic-function) (method standard-method) lambda-form environment))
+(function-to-method 'compute-discriminating-function
+  '((gf standard-generic-function)))

src/clos/generic.lsp

@@ -170,6 +170,7 @@
   (when (and l-l-p (not a-o-p))
     (setf (generic-function-argument-precedence-order gfun)
 	  (lambda-list-required-arguments lambda-list)))
+  (set-generic-function-dispatch gfun)
   gfun)
 
 (defmethod shared-initialize ((gfun standard-generic-function) slot-names
@@ -228,9 +229,7 @@
   (remf args :delete-methods)
   (when (and method-class-p (symbolp generic-function-class))
     (setf args (list* :method-class (find-class method-class) args)))
-  (set-funcallable-instance-function
-   (apply #'make-instance generic-function-class :name name args)
-   t))
+  (apply #'make-instance generic-function-class :name name args))
 
 (defun ensure-generic-function (name &rest args &key &allow-other-keys)
   (let ((gfun (si::traced-old-definition name)))

src/clos/kernel.lsp

@@ -268,16 +268,36 @@
 	(setf (fdefinition name) gfun)
 	gfun)))
 
+(defun compute-discriminating-function (generic-function)
+  (values #'(lambda (&rest args)
+	      (multiple-value-bind (method-list ok)
+		  (compute-applicable-methods-using-classes
+		   generic-function
+		   (mapcar #'class-of args))
+		(unless ok
+		  (setf method-list
+			(compute-applicable-methods generic-function args))
+		  (unless method-list
+		    (no-applicable-methods generic-function args)))
+		(funcall (compute-effective-method
+			  generic-function
+			  (generic-function-method-combination generic-function)
+			  method-list)
+			 args
+			 nil)))
+	  t))
+
 (defun set-generic-function-dispatch (gfun)
-  (flet ((gf-type (gfun)
-	   (loop with common-class = nil
+  (let ((gf-type
+	   (loop named gf-type
+	      with common-class = nil
 	      for method in (generic-function-methods gfun)
 	      for class = (si::instance-class method)
 	      for specializers = (method-specializers method)
 	      do (cond ((null common-class)
 			(setf common-class class))
 		       ((not (eq common-class class))
-			(return t)))
+			(return-from gf-type t)))
 	      do (loop for spec in specializers
 		    unless (or (eq spec +the-t-class+)
 			       (and (si::instancep spec)
@@ -285,17 +305,22 @@
 					+the-standard-class+)))
 		    do (return-from gf-type t))
 	      finally (cond ((null class)
-			     (return t))
+			     (return-from gf-type t))
 			    ((eq class (find-class 'standard-reader-method nil))
-			     (return 'standard-reader-method))
+			     (return-from gf-type 'standard-reader-method))
 			    ((eq class (find-class 'standard-writer-method nil))
-			     (return 'standard-writer-method))
+			     (return-from gf-type 'standard-writer-method))
 			    (t
-			     (return t))))))
-    (set-funcallable-instance-function gfun (gf-type gfun))))
+			     (return-from gf-type t))))))
+    (when (and *clos-booted* (eq gf-type t))
+      (multiple-value-bind (function optimize)
+	  (compute-discriminating-function gfun)
+	(unless optimize
+	  (setf gf-type function))))
+    ;(print (list (generic-function-name gfun) gf-type))
+    (set-funcallable-instance-function gfun gf-type)))
 
 
-
 ;;; ----------------------------------------------------------------------
 ;;; COMPUTE-APPLICABLE-METHODS
 ;;;