/[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.8 by phg, Mon Feb 8 17:39:23 1993 UTC revision 1.9 by pw, Thu Feb 6 21:24:22 1997 UTC
# Line 318  Line 318 
318    
319  (defun real-load-defclass (name metaclass-name supers slots other accessors)  (defun real-load-defclass (name metaclass-name supers slots other accessors)
320    (do-standard-defsetfs-for-defclass accessors)                 ;***    (do-standard-defsetfs-for-defclass accessors)                 ;***
321    (apply #'ensure-class name :metaclass metaclass-name    (let ((res (apply #'ensure-class name :metaclass metaclass-name
322                               :direct-superclasses supers                      :direct-superclasses supers
323                               :direct-slots slots                      :direct-slots slots
324                               :definition-source `((defclass ,name)                      :definition-source `((defclass ,name)
325                                                    ,(load-truename))                                           ,(load-truename))
326                               other))                      other)))
327        #+cmu17 (kernel:layout-class (class-wrapper res))
328        #-cmu17 res))
329    
330  (setf (gdefinition 'load-defclass) #'real-load-defclass)  (setf (gdefinition 'load-defclass) #'real-load-defclass)
331    
# Line 413  Line 415 
415          (dolist (superclass direct-superclasses)          (dolist (superclass direct-superclasses)
416            (unless (validate-superclass class superclass)            (unless (validate-superclass class superclass)
417              (error "The class ~S was specified as a~%super-class of the class ~S;~%~              (error "The class ~S was specified as a~%super-class of the class ~S;~%~
418                      but the meta-classes ~S and~%~S are incompatible."                      but the meta-classes ~S and~%~S are incompatible.~%
419                     superclass class (class-of superclass) (class-of class))))                      Define a method for ~S to avoid this error."
420                       superclass class (class-of superclass) (class-of class)
421                       'validate-superclass)))
422          (setf (slot-value class 'direct-superclasses) direct-superclasses))          (setf (slot-value class 'direct-superclasses) direct-superclasses))
423        (setq direct-superclasses (slot-value class 'direct-superclasses)))        (setq direct-superclasses (slot-value class 'direct-superclasses)))
424    (setq direct-slots    (setq direct-slots
# Line 552  Line 556 
556    (setf (slot-value class 'class-precedence-list)    (setf (slot-value class 'class-precedence-list)
557          (compute-class-precedence-list class))          (compute-class-precedence-list class))
558    (setf (slot-value class 'slots) (compute-slots class))    (setf (slot-value class 'slots) (compute-slots class))
559    #-new-kcl-wrapper    #-(or cmu17 new-kcl-wrapper)
560    (unless (slot-value class 'wrapper)    (unless (slot-value class 'wrapper)
561      (setf (slot-value class 'wrapper) (make-wrapper 0 class)))      (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
562      #+cmu17
563     (let ((lclass (lisp:find-class (class-name class))))
564        (setf (kernel:class-pcl-class lclass) class)
565        (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
566    #+new-kcl-wrapper    #+new-kcl-wrapper
567    (let ((wrapper (get (class-name class) 'si::s-data)))    (let ((wrapper (get (class-name class) 'si::s-data)))
568      (setf (slot-value class 'wrapper) wrapper)      (setf (slot-value class 'wrapper) wrapper)
# Line 689  Line 697 
697                     ;;                     ;;
698                     (make-instances-obsolete class)                     (make-instances-obsolete class)
699                     (class-wrapper class)))))                     (class-wrapper class)))))
700    
701        (with-slots (wrapper slots) class        (with-slots (wrapper slots) class
702          #+new-kcl-wrapper          #+new-kcl-wrapper
703          (setf (si::s-data-name nwrapper) (class-name class))          (setf (si::s-data-name nwrapper) (class-name class))
704            #+cmu17
705            (update-lisp-class-layout class nwrapper)
706          (setf slots eslotds          (setf slots eslotds
707                (wrapper-instance-slots-layout nwrapper) nlayout                (wrapper-instance-slots-layout nwrapper) nlayout
708                (wrapper-class-slots nwrapper) nwrapper-class-slots                (wrapper-class-slots nwrapper) nwrapper-class-slots
709                (wrapper-no-of-instance-slots nwrapper) nslots                (wrapper-no-of-instance-slots nwrapper) nslots
710                wrapper nwrapper))                wrapper nwrapper))
711    
712        (unless (eq owrapper nwrapper)        (unless (eq owrapper nwrapper)
713          (update-pv-table-cache-info class)))))          (update-pv-table-cache-info class)))))
714    
# Line 1021  Line 1033 
1033          (setf (wrapper-class-slots nwrapper)          (setf (wrapper-class-slots nwrapper)
1034                (wrapper-class-slots owrapper))                (wrapper-class-slots owrapper))
1035          (without-interrupts          (without-interrupts
1036              #+cmu17
1037              (update-lisp-class-layout class nwrapper)
1038            (setf (slot-value class 'wrapper) nwrapper)            (setf (slot-value class 'wrapper) nwrapper)
1039            (invalidate-wrapper owrapper ':flush nwrapper))))))            (invalidate-wrapper owrapper ':flush nwrapper))))))
1040    
# Line 1044  Line 1058 
1058        (setf (wrapper-class-slots nwrapper)        (setf (wrapper-class-slots nwrapper)
1059              (wrapper-class-slots owrapper))              (wrapper-class-slots owrapper))
1060        (without-interrupts        (without-interrupts
1061            #+cmu17
1062            (update-lisp-class-layout class nwrapper)
1063          (setf (slot-value class 'wrapper) nwrapper)          (setf (slot-value class 'wrapper) nwrapper)
1064          (invalidate-wrapper owrapper ':obsolete nwrapper)          (invalidate-wrapper owrapper ':obsolete nwrapper)
1065          class)))          class)))
# Line 1072  Line 1088 
1088  ;;; happening when they should, and that the trap methods are computing  ;;; happening when they should, and that the trap methods are computing
1089  ;;; apropriate new wrappers.  ;;; apropriate new wrappers.
1090  ;;;  ;;;
 (defun obsolete-instance-trap (owrapper nwrapper instance)  
   ;;  
   ;; local  --> local        transfer  
   ;; local  --> shared       discard  
   ;; local  -->  --          discard  
   ;; shared --> local        transfer  
   ;; shared --> shared       discard  
   ;; shared -->  --          discard  
   ;;  --    --> local        add  
   ;;  --    --> shared        --  
   ;;  
   (let* ((class (wrapper-class* nwrapper))  
          (guts (allocate-instance class))       ;??? allocate-instance ???  
          (olayout (wrapper-instance-slots-layout owrapper))  
          (nlayout (wrapper-instance-slots-layout nwrapper))  
          (oslots (get-slots instance))  
          (nslots (get-slots guts))  
          (oclass-slots (wrapper-class-slots owrapper))  
          (added ())  
          (discarded ())  
          (plist ()))  
     ;;  
     ;; Go through all the old local slots.  
     ;;  
     (iterate ((name (list-elements olayout))  
               (opos (interval :from 0)))  
       (let ((npos (posq name nlayout)))  
         (if npos  
             (setf (instance-ref nslots npos) (instance-ref oslots opos))  
             (progn (push name discarded)  
                    (unless (eq (instance-ref oslots opos) *slot-unbound*)  
                      (setf (getf plist name) (instance-ref oslots opos)))))))  
     ;;  
     ;; Go through all the old shared slots.  
     ;;  
     (iterate ((oclass-slot-and-val (list-elements oclass-slots)))  
       (let ((name (car oclass-slot-and-val))  
             (val (cdr oclass-slot-and-val)))  
         (let ((npos (posq name nlayout)))  
           (if npos  
               (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))  
               (progn (push name discarded)  
                      (unless (eq val *slot-unbound*)  
                        (setf (getf plist name) val)))))))  
     ;;  
     ;; Go through all the new local slots to compute the added slots.  
     ;;  
     (dolist (nlocal nlayout)  
       (unless (or (memq nlocal olayout)  
                   (assq nlocal oclass-slots))  
         (push nlocal added)))  
   
     (swap-wrappers-and-slots instance guts)  
1091    
1092      (update-instance-for-redefined-class instance  ;;; obsolete-instance-trap might be called on structure instances
1093                                           added  ;;; after a structure is redefined.  In most cases, obsolete-instance-trap
1094                                           discarded  ;;; will not be able to fix the old instance, so it must signal an
1095                                           plist)  ;;; error.  The hard part of this is that the error system and debugger
1096      nwrapper))  ;;; might cause obsolete-instance-trap to be called again, so in that
1097    ;;; case, we have to return some reasonable wrapper, instead.
1098    
1099    (defvar *in-obsolete-instance-trap* nil)
1100    (defvar *the-wrapper-of-structure-object*
1101      (class-wrapper (find-class 'structure-object)))
1102    
1103    #+cmu17
1104    (define-condition obsolete-structure (error)
1105      ((datum :reader obsolete-structure-datum :initarg :datum))
1106      (:report
1107       (lambda (condition stream)
1108         ;; Don't try to print the structure, since it probably
1109         ;; won't work.
1110         (format stream "Obsolete structure error in ~S:~@
1111                         For a structure of type: ~S"
1112                 (conditions::condition-function-name condition)
1113                 (type-of (obsolete-structure-datum condition))))))
1114    
1115    (defun obsolete-instance-trap (owrapper nwrapper instance)
1116      (if (not #-(or cmu17 new-kcl-wrapper)
1117               (or (std-instance-p instance) (fsc-instance-p instance))
1118               #+cmu17
1119               (pcl-instance-p instance)
1120               #+new-kcl-wrapper
1121               nil)
1122          (if *in-obsolete-instance-trap*
1123              *the-wrapper-of-structure-object*
1124               (let ((*in-obsolete-instance-trap* t))
1125                 #-cmu17
1126                 (error "The structure ~S is obsolete." instance)
1127                 #+cmu17
1128                 (error 'obsolete-structure :datum instance)))
1129          (let* ((class (wrapper-class* nwrapper))
1130                 (copy (allocate-instance class)) ;??? allocate-instance ???
1131                 (olayout (wrapper-instance-slots-layout owrapper))
1132                 (nlayout (wrapper-instance-slots-layout nwrapper))
1133                 (oslots (get-slots instance))
1134                 (nslots (get-slots copy))
1135                 (oclass-slots (wrapper-class-slots owrapper))
1136                 (added ())
1137                 (discarded ())
1138                 (plist ()))
1139            ;; local  --> local        transfer
1140            ;; local  --> shared       discard
1141            ;; local  -->  --          discard
1142            ;; shared --> local        transfer
1143            ;; shared --> shared       discard
1144            ;; shared -->  --          discard
1145            ;;  --    --> local        add
1146            ;;  --    --> shared        --
1147            ;;
1148            ;; Go through all the old local slots.
1149            ;;
1150            (iterate ((name (list-elements olayout))
1151                      (opos (interval :from 0)))
1152              (let ((npos (posq name nlayout)))
1153                (if npos
1154                    (setf (instance-ref nslots npos) (instance-ref oslots opos))
1155                    (progn
1156                      (push name discarded)
1157                      (unless (eq (instance-ref oslots opos) *slot-unbound*)
1158                        (setf (getf plist name) (instance-ref oslots opos)))))))
1159            ;;
1160            ;; Go through all the old shared slots.
1161            ;;
1162            (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
1163              (let ((name (car oclass-slot-and-val))
1164                    (val (cdr oclass-slot-and-val)))
1165                (let ((npos (posq name nlayout)))
1166                  (if npos
1167                      (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
1168                      (progn (push name discarded)
1169                             (unless (eq val *slot-unbound*)
1170                               (setf (getf plist name) val)))))))
1171            ;;
1172            ;; Go through all the new local slots to compute the added slots.
1173            ;;
1174            (dolist (nlocal nlayout)
1175              (unless (or (memq nlocal olayout)
1176                          (assq nlocal oclass-slots))
1177                (push nlocal added)))
1178    
1179            (swap-wrappers-and-slots instance copy)
1180    
1181            (update-instance-for-redefined-class instance
1182                                                 added
1183                                                 discarded
1184                                                 plist)
1185            nwrapper)))
1186    
1187    
1188  ;;;  ;;;
# Line 1151  Line 1202 
1202    
1203  (defun change-class-internal (instance new-class)  (defun change-class-internal (instance new-class)
1204    (let* ((old-class (class-of instance))    (let* ((old-class (class-of instance))
1205           (copy (copy-instance-internal instance))           (copy (allocate-instance new-class))
1206           (guts (allocate-instance new-class))           (new-wrapper (get-wrapper copy))
          (new-wrapper (get-wrapper guts))  
1207           (old-wrapper (class-wrapper old-class))           (old-wrapper (class-wrapper old-class))
1208           (old-layout (wrapper-instance-slots-layout old-wrapper))           (old-layout (wrapper-instance-slots-layout old-wrapper))
1209           (new-layout (wrapper-instance-slots-layout new-wrapper))           (new-layout (wrapper-instance-slots-layout new-wrapper))
1210           (old-slots (get-slots instance))           (old-slots (get-slots instance))
1211           (new-slots (get-slots guts))           (new-slots (get-slots copy))
1212           (old-class-slots (wrapper-class-slots old-wrapper)))           (old-class-slots (wrapper-class-slots old-wrapper)))
1213    
1214      ;;      ;;
# Line 1184  Line 1234 
1234    
1235      ;; Make the copy point to the old instance's storage, and make the      ;; Make the copy point to the old instance's storage, and make the
1236      ;; old instance point to the new storage.      ;; old instance point to the new storage.
1237      (swap-wrappers-and-slots instance guts)      (swap-wrappers-and-slots instance copy)
1238    
1239      (update-instance-for-different-class copy instance)      (update-instance-for-different-class copy instance)
1240      instance))      instance))

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

  ViewVC Help
Powered by ViewVC 1.1.5