[Openmcl-cvs-notifications] r8534 - /trunk/source/level-1/l1-clos.lisp

[gb at clozure.com]

Author: gb
Date: Thu Feb 21 04:30:38 2008
New Revision: 8534

Log:
DCODE-FOR-UNIVERSALLAY-APPLICABLE-SINGLETON: only call method-function
directly if standard method combination.

Modified:
    trunk/source/level-1/l1-clos.lisp

Modified: trunk/source/level-1/l1-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos.lisp (original)
+++ trunk/source/level-1/l1-clos.lisp Thu Feb 21 04:30:38 2008
@@ -2276,15 +2276,17 @@
       f)))
 =

 (defun dcode-for-universally-applicable-singleton (gf)
-  (let* ((methods (generic-function-methods gf))
-         (method (car methods)))
-    (when (and method
-               (null (cdr methods))
-               (null (method-qualifiers method))
-               (dolist (spec (method-specializers method) t)
-                 (unless (eq spec *t-class*)
-                   (return nil))))
-      (method-function method))))
+  (when (eq (generic-function-method-combination gf)
+            *standard-method-combination*)
+    (let* ((methods (generic-function-methods gf))
+           (method (car methods)))
+      (when (and method
+                 (null (cdr methods))
+                 (null (method-qualifiers method))
+                 (dolist (spec (method-specializers method) t)
+                   (unless (eq spec *t-class*)
+                     (return nil))))
+        (method-function method)))))
 =

 (register-non-dt-dcode-function #'dcode-for-universally-applicable-singlet=
on)
 =