Changeset 13351


Ignore:
Timestamp:
Jan 1, 2010, 9:32:36 PM (10 years ago)
Author:
gb
Message:

EXCHANGE-SLOT-VECTORS-AND-WRAPPERS: handle FUNCALLABLE-STANDARD-OBJECTs
which may not be GENERIC-FUNCTIONs.

UPDATE-OBSOLETE-INSTANCE: likewise, and use INSTANCE-SLOTS, not the
(confusingly similarly-named) INSTANCE.SLOTS (which only works on
STANDARD-INSTANCEs)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-clos-boot.lisp

    r13067 r13351  
    31113111
    31123112(defun exchange-slot-vectors-and-wrappers (a b)
    3113   (if (typep a 'generic-function)
     3113  (if (typep a 'funcallable-standard-object)
    31143114    (let* ((temp-wrapper (gf.instance.class-wrapper a))
    31153115           (orig-a-slots (gf.slots a))
     
    31583158     (let* ((old-wrapper (standard-object-p instance)))
    31593159       (unless old-wrapper
    3160          (when (standard-generic-function-p instance)
     3160         (when (typep instance 'funcallable-standard-object)
    31613161           (setq old-wrapper (gf.instance.class-wrapper instance)))
    31623162         (unless old-wrapper
    3163            (report-bad-arg instance '(or standard-instance standard-generic-function))))
    3164        (when (eql 0 (%wrapper-instance-slots old-wrapper))   ; is it really obsolete?
     3163           (report-bad-arg instance '(or standard-instance funcallable-standard-object))))
     3164       (when (eql 0 (%wrapper-instance-slots old-wrapper)) ; is it really obsolete?
    31653165         (let* ((class (%wrapper-class old-wrapper))
    31663166                (new-wrapper (or (%class.own-wrapper class)
     
    31743174                (new-class-slots (%wrapper-class-slots new-wrapper))
    31753175                (new-instance (allocate-instance class))
    3176                 (old-slot-vector (instance.slots instance))
    3177                 (new-slot-vector (instance.slots new-instance)))
    3178              ;; Lots to do.  Hold onto your hat.
    3179              (let* ((old-size (uvsize old-instance-slots))
    3180                     (new-size (uvsize new-instance-slots)))
    3181                (declare (fixnum old-size new-size))
    3182                (dotimes (i old-size)
    3183                  (declare (fixnum i))
    3184                  (let* ((slot-name (%svref old-instance-slots i))
    3185                         (pos (%vector-member slot-name new-instance-slots))
    3186                         (val (%svref old-slot-vector (%i+ i 1))))
    3187                    (if pos
    3188                      (setf (%svref new-slot-vector (%i+ pos 1)) val)
    3189                      (progn
    3190                        (push slot-name discarded)
    3191                        (unless (eq val (%slot-unbound-marker))
    3192                         (setf (getf plist slot-name) val))))))
    3193                ;; Go through old class slots
    3194                (dolist (pair old-class-slots)
    3195                  (let* ((slot-name (%car pair))
    3196                         (val (%cdr pair))
    3197                         (pos (%vector-member slot-name new-instance-slots)))
    3198                    (if pos
    3199                      (setf (%svref new-slot-vector (%i+ pos 1)) val)
    3200                      (progn
    3201                        (push slot-name discarded)
    3202                        (unless (eq val (%slot-unbound-marker))
    3203                         (setf (getf plist slot-name) val))))))
    3204                ; Go through new instance slots
    3205                (dotimes (i new-size)
    3206                  (declare (fixnum i))
    3207                  (let* ((slot-name (%svref new-instance-slots i)))
    3208                    (unless (or (%vector-member slot-name old-instance-slots)
    3209                                (assoc slot-name old-class-slots))
    3210                      (push slot-name added))))
    3211                ;; Go through new class slots
    3212                (dolist (pair new-class-slots)
    3213                  (let ((slot-name (%car pair)))
    3214                    (unless (or (%vector-member slot-name old-instance-slots)
    3215                                (assoc slot-name old-class-slots))
    3216                      (push slot-name added))))
    3217                (exchange-slot-vectors-and-wrappers new-instance instance))))))
     3176                (old-slot-vector (instance-slots instance))
     3177                (new-slot-vector (instance-slots new-instance)))
     3178           ;; Lots to do.  Hold onto your hat.
     3179           (let* ((old-size (uvsize old-instance-slots))
     3180                  (new-size (uvsize new-instance-slots)))
     3181             (declare (fixnum old-size new-size))
     3182             (dotimes (i old-size)
     3183               (declare (fixnum i))
     3184               (let* ((slot-name (%svref old-instance-slots i))
     3185                      (pos (%vector-member slot-name new-instance-slots))
     3186                      (val (%svref old-slot-vector (%i+ i 1))))
     3187                 (if pos
     3188                   (setf (%svref new-slot-vector (%i+ pos 1)) val)
     3189                   (progn
     3190                     (push slot-name discarded)
     3191                     (unless (eq val (%slot-unbound-marker))
     3192                      (setf (getf plist slot-name) val))))))
     3193             ;; Go through old class slots
     3194             (dolist (pair old-class-slots)
     3195               (let* ((slot-name (%car pair))
     3196                      (val (%cdr pair))
     3197                      (pos (%vector-member slot-name new-instance-slots)))
     3198                 (if pos
     3199                   (setf (%svref new-slot-vector (%i+ pos 1)) val)
     3200                   (progn
     3201                     (push slot-name discarded)
     3202                     (unless (eq val (%slot-unbound-marker))
     3203                      (setf (getf plist slot-name) val))))))
     3204                                        ; Go through new instance slots
     3205             (dotimes (i new-size)
     3206               (declare (fixnum i))
     3207               (let* ((slot-name (%svref new-instance-slots i)))
     3208                 (unless (or (%vector-member slot-name old-instance-slots)
     3209                             (assoc slot-name old-class-slots))
     3210                   (push slot-name added))))
     3211             ;; Go through new class slots
     3212             (dolist (pair new-class-slots)
     3213               (let ((slot-name (%car pair)))
     3214                 (unless (or (%vector-member slot-name old-instance-slots)
     3215                             (assoc slot-name old-class-slots))
     3216                   (push slot-name added))))
     3217             (exchange-slot-vectors-and-wrappers new-instance instance))))))
    32183218    ;; run user code with interrupts enabled.
    32193219    (update-instance-for-redefined-class instance added discarded plist))
Note: See TracChangeset for help on using the changeset viewer.