/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Diff of /src/pcl/std-class.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.37 by pmai, Tue Oct 29 16:20:45 2002 UTC revision 1.38 by pmai, Wed Dec 18 16:29:06 2002 UTC
# Line 475  Line 475 
475    (setf (plist-value class 'class-slot-cells)    (setf (plist-value class 'class-slot-cells)
476          (let ((collected ()))          (let ((collected ()))
477            (dolist (dslotd direct-slots (nreverse collected))            (dolist (dslotd direct-slots (nreverse collected))
478              (when (eq (slot-definition-allocation dslotd) class)              (when (eq (slot-definition-allocation dslotd) :class)
479                (let ((initfunction (slot-definition-initfunction dslotd)))                (let ((initfunction (slot-definition-initfunction dslotd)))
480                  (push (cons (slot-definition-name dslotd)                  (push (cons (slot-definition-name dslotd)
481                              (if initfunction                              (if initfunction
# Line 703  Line 703 
703    (let ((instance-slots ())    (let ((instance-slots ())
704          (class-slots    ()))          (class-slots    ()))
705      (dolist (eslotd eslotds)      (dolist (eslotd eslotds)
706        (let ((alloc (slot-definition-allocation eslotd)))        (ecase (slot-definition-allocation eslotd)
707          (cond ((eq alloc :instance) (push eslotd instance-slots))          (:instance (push eslotd instance-slots))
708                ((classp alloc)       (push eslotd class-slots)))))          (:class    (push eslotd class-slots))))
709      ;;      ;;
710      ;; If there is a change in the shape of the instances then the      ;; If there is a change in the shape of the instances then the
711      ;; old class is now obsolete.      ;; old class is now obsolete.
# Line 748  Line 748 
748  (defun compute-class-slots (eslotds)  (defun compute-class-slots (eslotds)
749    (loop for eslotd in eslotds    (loop for eslotd in eslotds
750          for name = (slot-definition-name eslotd)          for name = (slot-definition-name eslotd)
751          and allocation = (slot-definition-allocation eslotd)          and class = (slot-definition-class eslotd)
752          collect (assoc name (class-slot-cells allocation))))          collect (assoc name (class-slot-cells class))))
753    
754  (defun compute-layout (cpl instance-eslotds)  (defun compute-layout (cpl instance-eslotds)
755    (let* ((names (loop for eslotd in instance-eslotds    (let* ((names (loop for eslotd in instance-eslotds
# Line 851  Line 851 
851          (instance-slots ())          (instance-slots ())
852          (class-slots    ()))          (class-slots    ()))
853      (dolist (eslotd eslotds)      (dolist (eslotd eslotds)
854        (let ((alloc (slot-definition-allocation eslotd)))        (ecase (slot-definition-allocation eslotd)
855          (cond ((eq alloc :instance) (push eslotd instance-slots))          (:instance (push eslotd instance-slots))
856                ((classp alloc)       (push eslotd class-slots)))))          (:class    (push eslotd class-slots))))
857      (let ((nlayout (compute-layout cpl instance-slots)))      (let ((nlayout (compute-layout cpl instance-slots)))
858        (dolist (eslotd instance-slots)        (dolist (eslotd instance-slots)
859          (setf (slot-definition-location eslotd)          (setf (slot-definition-location eslotd)
# Line 861  Line 861 
861      (dolist (eslotd class-slots)      (dolist (eslotd class-slots)
862        (setf (slot-definition-location eslotd)        (setf (slot-definition-location eslotd)
863              (assoc (slot-definition-name eslotd)              (assoc (slot-definition-name eslotd)
864                     (class-slot-cells (slot-definition-allocation eslotd)))))                     (class-slot-cells (slot-definition-class eslotd)))))
865      (mapc #'initialize-internal-slot-functions eslotds)      (mapc #'initialize-internal-slot-functions eslotds)
866      eslotds))      eslotds))
867    

Legend:
Removed from v.1.37  
changed lines
  Added in v.1.38

  ViewVC Help
Powered by ViewVC 1.1.5