[Openmcl-cvs-notifications] r9134 - in /trunk/source/level-1: l1-clos-boot.lisp l1-clos.lisp l1-dcode.lisp

[gz at clozure.com]

Author: gz
Date: Fri Apr 11 14:26:42 2008
New Revision: 9134

Log:
Propagate r9131 to trunk

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

Modified: trunk/source/level-1/l1-clos-boot.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-boot.lisp (original)
+++ trunk/source/level-1/l1-clos-boot.lisp Fri Apr 11 14:26:42 2008
@@ -1049,10 +1049,6 @@
       (when dcode (return dcode)))))
 =

            =

-(defparameter dcode-proto-alist
-  (list (cons #'%%one-arg-dcode *gf-proto-one-arg*)
-        (cons #'%%1st-two-arg-dcode *gf-proto-two-arg*)))
-    =

 (defun compute-dcode (gf &optional dt)
   (setq gf (require-type gf 'standard-generic-function))
   (unless dt (setq dt (%gf-dispatch-table gf)))

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 Fri Apr 11 14:26:42 2008
@@ -1808,6 +1808,7 @@
             class)
       (%slot-ref (instance.slots instance) location)
       (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*)
 =

 ;;; Dcode for a GF whose methods are all reader-methods which access a
 ;;; slot in one or more classes which have multiple subclasses, all of
@@ -1821,6 +1822,7 @@
             classes)
       (%slot-ref (instance.slots instance) location)
       (no-applicable-method (%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
 ;;; slot in one or more classes which have multiple subclasses, all of
@@ -1837,6 +1839,7 @@
                                             (%inited-class-cpl class))))
       (%slot-ref (instance.slots instance) location)
       (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+(register-dcode-proto #'reader-constant-location-inherited-from-single-cla=
ss-dcode *gf-proto-one-arg*)
 =

 ;;; Dcode for a GF whose methods are all reader-methods which access a
 ;;; slot in one or more classes which have multiple subclasses, all of
@@ -1853,6 +1856,7 @@
           (when (memq defining-class cpl) (return t)))
       (%slot-ref (instance.slots instance) location)
       (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
+(register-dcode-proto #'reader-constant-location-inherited-from-multiple-c=
lasses-dcode *gf-proto-one-arg*)
 =

 =

 ;;; Similar to the case above, but we use an alist to map classes
@@ -1868,6 +1872,7 @@
     (if location
       (%slot-ref (instance.slots instance) location)
       (no-applicable-method (%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)
   (let* ((alist nil))
@@ -1992,11 +1997,13 @@
     (if mf
       (funcall mf arg1 arg2)
       (%%1st-two-arg-dcode dt arg1 arg2))))
+(register-dcode-proto #'reader-variable-location-dcode *gf-proto-two-arg*)
 =

 (defun %%one-arg-eql-method-hack-dcode (dt arg)
   (let* ((mf (if (typep arg 'symbol) (get arg dt))))
     (if mf
       (funcall mf arg))))
+(register-dcode-proto #'%%one-arg-eql-method-hack-dcode *gf-proto-one-arg*)
 =

 (defun install-eql-method-hack-dcode (gf)
   (let* ((bits (inner-lfun-bits gf))

Modified: trunk/source/level-1/l1-dcode.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-dcode.lisp (original)
+++ trunk/source/level-1/l1-dcode.lisp Fri Apr 11 14:26:42 2008
@@ -780,6 +780,16 @@
 =

 ;;;;;;;;;;;;;;;;;;;;;;;;; generic-function dcode ;;;;;;;;;;;;;;;;;;;;;;;;;=
;;
 =

+;; dcode functions using other than *gf-proto*
+(defparameter dcode-proto-alist ())
+
+(defun register-dcode-proto (dcode proto)
+  (let ((a (assoc dcode dcode-proto-alist)))
+    (if a
+      (setf (cdr a) proto)
+      (push (cons dcode proto) dcode-proto-alist))))
+
+
 ;;; Simple case for generic-functions with no specializers
 ;;; Why anyone would want to do this I can't imagine.
 =

@@ -816,12 +826,13 @@
 (defun %%one-arg-dcode (dt  arg)
   (let ((method (%find-1st-arg-combined-method dt arg)))
     (funcall method arg)))
+(register-dcode-proto #'%%one-arg-dcode *gf-proto-one-arg*)
 =

 ;;; two args - specialized on first
 (defun %%1st-two-arg-dcode (dt arg1 arg2)
   (let ((method (%find-1st-arg-combined-method dt arg1)))
     (funcall method arg1 arg2)))
-
+(register-dcode-proto #'%%1st-two-arg-dcode *gf-proto-two-arg*)
 =

 =

 ;;;  arg is dispatch-table and argnum is in the dispatch table