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

[gb at clozure.com]

Author: gb
Date: Thu Mar 22 08:23:42 2012
New Revision: 15265

Log:
When we optimize a GF via %SNAP-READER-METHOD, we store the GF's
original dcode in the dispatch-table's GF slot so that we can
restore it if/when we undo the optimization; this is done under
the assumption that the optimized dcode doesn't need access to
the GF for method dispatch, but it does need it in order to
report NO-APPLICABLE-METHOD sanely.  Store a CONS of (gf . dcode)
in the dispatch table's GF slot, access the car of that cons
when reporting no-applicable-method, and dtrt when undoing the
optimization.

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 Mar 22 08:23:42 2012
@@ -1991,7 +1991,7 @@
                   (progn (update-obsolete-instance instance)
                          (eq (instance.class-wrapper instance) wrapper)))
              (%slot-ref (instance.slots instance) location))
-            (t (no-applicable-method (%gf-dispatch-table-gf dt) instance))=
))))
+            (t (no-applicable-method (car (%gf-dispatch-table-gf dt)) inst=
ance))))))
 (register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*)
 =

 ;;; Dcode for a GF whose methods are all reader-methods which access a
@@ -2003,7 +2003,7 @@
               (%class-of-instance instance))
               (%svref dt %gf-dispatch-table-first-data))
       (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-tab=
le-first-data)))
-      (no-applicable-method (%gf-dispatch-table-gf dt) instance)))
+      (no-applicable-method (car (%gf-dispatch-table-gf dt)) instance)))
 (register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*)
 =

 ;;; Dcode for a GF whose methods are all reader-methods which access a
@@ -2025,7 +2025,7 @@
              (< defining-class-ordinal (the fixnum (uvsize bits)))
              (not (eql 0 (sbit bits defining-class-ordinal))))
       (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-tab=
le-first-data)))
-      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+      (no-applicable-method (car (%gf-dispatch-table-gf dt)) instance))))
 (register-dcode-proto #'reader-constant-location-inherited-from-single-cla=
ss-dcode *gf-proto-one-arg*)
 =

 ;;; It may be faster to make individual functions that take their
@@ -2082,7 +2082,7 @@
                      (not (eql 0 (sbit bits ordinal))))
             (return t)))
       (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-tab=
le-first-data)))
-      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+      (no-applicable-method (car (%gf-dispatch-table-gf dt)) instance))))
 (register-dcode-proto #'reader-constant-location-inherited-from-multiple-c=
lasses-dcode *gf-proto-one-arg*)
 =

 =

@@ -2098,7 +2098,7 @@
                      alist))))
     (if location
       (%slot-ref (instance.slots instance) location)
-      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+      (no-applicable-method (car (%gf-dispatch-table-gf dt)) instance))))
 (register-dcode-proto #'reader-variable-location-dcode *gf-proto-one-arg*)
 =

 (defun class-and-slot-location-alist (classes slot-name)
@@ -2168,7 +2168,7 @@
                 (let* ((argnum (%gf-dispatch-table-argnum dt)))
                   (unless (< argnum 0)
                     (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
-                          (%gf-dispatch-table-gf dt) (%gf-dcode f))))
+                          (%gf-dispatch-table-gf dt) (cons f (%gf-dcode f)=
))))
                     =

                 (cond ((null (cdr alist))
                        ;; Method is only applicable to a single class.
@@ -2566,7 +2566,7 @@
     (let* ((dt (%gf-dispatch-table f))
            (argnum (%gf-dispatch-table-argnum dt)))
       (when (< argnum 0)
-        (let* ((dcode (%gf-dispatch-table-gf dt)))
+        (let* ((dcode (cdr (%gf-dispatch-table-gf dt))))
           (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
                 (%gf-dispatch-table-gf dt) f
                 (%gf-dcode f) dcode)