Changeset 7982


Ignore:
Timestamp:
Jan 1, 2008, 1:51:05 AM (12 years ago)
Author:
gb
Message:

Be sure that UPDATE-CPL returns the CPL; some early/low-level classes
weren't geting their wrapper's CPL set.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/1.2-devel/ccl/level-1/l1-clos-boot.lisp

    r7945 r7982  
    10451045
    10461046
    1047 
     1047(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument.  The dcode functions will be caled with all of the incoming arguments.")
     1048
     1049(defun non-dt-dcode-function (gf)
     1050  (dolist (f *non-dt-dcode-functions*)
     1051    (let* ((dcode (funcall f gf)))
     1052      (when dcode (return dcode)))))
     1053
     1054           
    10481055(defparameter dcode-proto-alist
    10491056  (list (cons #'%%one-arg-dcode *gf-proto-one-arg*)
     
    10741081              (if (or (null min-index) (< index min-index))
    10751082                (setq min-index index))))))
    1076       (let ((dcode (if 0-args?
    1077                      #'%%0-arg-dcode
    1078                      (or (if multi-method-index
    1079                            #'%%nth-arg-dcode)
    1080                          (if (null other-args?)
    1081                            (if (eql nreq 1)
    1082                              #'%%one-arg-dcode
    1083                              (if (eql nreq 2)
    1084                                #'%%1st-two-arg-dcode
    1085                                #'%%1st-arg-dcode))                           
    1086                              #'%%1st-arg-dcode)))))
     1083      (let* ((non-dt (non-dt-dcode-function gf))
     1084             (dcode (or non-dt
     1085                        (if 0-args?
     1086                          #'%%0-arg-dcode
     1087                          (or (if multi-method-index
     1088                                #'%%nth-arg-dcode)
     1089                              (if (null other-args?)
     1090                                (if (eql nreq 1)
     1091                                  #'%%one-arg-dcode
     1092                                  (if (eql nreq 2)
     1093                                    #'%%1st-two-arg-dcode
     1094                                    #'%%1st-arg-dcode))
     1095                                #'%%1st-arg-dcode))))))
    10871096        (setq multi-method-index
    10881097              (if multi-method-index
     
    10961105                                                 (function-name (%combined-method-dcode old-dcode)))
    10971106                                             (cdr (%combined-method-methods old-dcode)))))
    1098           (when (or (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
     1107          (when (or non-dt (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
    10991108                    (neq multi-method-index (%gf-dispatch-table-argnum dt)))
    1100             (let ((proto (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*)))
     1109            (let* ((proto (if non-dt
     1110                            #'funcallable-trampoline
     1111                            (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*))))
    11011112              (clear-gf-dispatch-table dt)
    11021113              (setf (%gf-dispatch-table-argnum dt) multi-method-index)
     
    13281339
    13291340
    1330 (defvar *t-class* (let ((class (%cons-built-in-class 't)))
    1331                     (setf (%class.cpl class) (list class))
    1332                     (setf (%class.own-wrapper class)
    1333                           (%cons-wrapper class (new-class-wrapper-hash-index)))
     1341(defvar *t-class* (let* ((class (%cons-built-in-class 't))
     1342                         (wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))
     1343                         (cpl (list class)))
     1344                    (setf (%class.cpl class) cpl)
     1345                    (setf (%wrapper-cpl wrapper) cpl)
     1346                    (setf (%class.own-wrapper class) wrapper)
    13341347                    (setf (%class.ctype class) (make-class-ctype class))
    13351348                    (setf (find-class 't) class)
     
    14301443                     (%cons-wrapper class))))
    14311444      (setf (%class.cpl class) cpl
    1432             (%wrapper-instance-slots wrapper) (vector)
     1445            (%wrapper-instance-slots wrapper) (vector)           
    14331446            (%class.own-wrapper class) wrapper
    14341447            (%class.ctype class) (make-class-ctype class)
    14351448            (%class.slots class) nil
    1436             (find-class name) class
    1437             )
     1449            (%wrapper-cpl wrapper) cpl
     1450            (find-class name) class)
    14381451      (dolist (sup supers)
    14391452        (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
Note: See TracChangeset for help on using the changeset viewer.