/[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.9.2.2 by dtc, Sat Aug 30 18:41:37 1997 UTC revision 1.9.2.3 by pw, Tue Jun 23 11:25:38 1998 UTC
# Line 324  Line 324 
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))      ;; Defclass of a class with a forward-referenced superclass does not
328        ;; have a wrapper. RES is the incomplete PCL class. The Lisp class
329        ;; does not yet exist. Maybe should return NIL in that case as RES
330        ;; is not useful to the user?
331        #+cmu17 (and (class-wrapper res)(kernel:layout-class (class-wrapper res)))
332      #-cmu17 res))      #-cmu17 res))
333    
334  (setf (gdefinition 'load-defclass) #'real-load-defclass)  (setf (gdefinition 'load-defclass) #'real-load-defclass)
# Line 408  Line 412 
412                   (direct-default-initargs nil direct-default-initargs-p)                   (direct-default-initargs nil direct-default-initargs-p)
413                   (predicate-name nil predicate-name-p))                   (predicate-name nil predicate-name-p))
414    (declare (ignore slot-names))    (declare (ignore slot-names))
415    (if direct-superclasses-p    (cond (direct-superclasses-p
416        (progn           (setq direct-superclasses
417          (setq direct-superclasses (or direct-superclasses                 (or direct-superclasses
418                                        (list *the-class-standard-object*)))                     (list (if (funcallable-standard-class-p class)
419          (dolist (superclass direct-superclasses)                               *the-class-funcallable-standard-object*
420            (unless (validate-superclass class superclass)                               *the-class-standard-object*))))
421              (error "The class ~S was specified as a~%super-class of the class ~S;~%~           (dolist (superclass direct-superclasses)
422                      but the meta-classes ~S and~%~S are incompatible.~%             (unless (validate-superclass class superclass)
423                      Define a method for ~S to avoid this error."               (error "The class ~S was specified as a~%
424                     superclass class (class-of superclass) (class-of class)                       super-class of the class ~S;~%~
425                     'validate-superclass)))                       but the meta-classes ~S and~%~S are incompatible.~@
426          (setf (slot-value class 'direct-superclasses) direct-superclasses))                       Define a method for ~S to avoid this error."
427        (setq direct-superclasses (slot-value class 'direct-superclasses)))                       superclass class (class-of superclass) (class-of class)
428                         'validate-superclass)))
429             (setf (slot-value class 'direct-superclasses) direct-superclasses))
430            (t
431             (setq direct-superclasses (slot-value class 'direct-superclasses))))
432    (setq direct-slots    (setq direct-slots
433          (if direct-slots-p          (if direct-slots-p
434              (setf (slot-value class 'direct-slots)              (setf (slot-value class 'direct-slots)
# Line 645  Line 653 
653      (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))      (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
654    
655  (defun update-cpl (class cpl)  (defun update-cpl (class cpl)
656    (when (class-finalized-p class)    (if (class-finalized-p class)
657      (unless (equal (class-precedence-list class) cpl)        (unless (equal (class-precedence-list class) cpl)
658        (force-cache-flushes class)))          ;; Need to have the cpl setup before update-lisp-class-layout
659    (setf (slot-value class 'class-precedence-list) cpl)          ;; is called on CMUCL.
660            (setf (slot-value class 'class-precedence-list) cpl)
661            (force-cache-flushes class))
662          (setf (slot-value class 'class-precedence-list) cpl))
663    (update-class-can-precede-p cpl))    (update-class-can-precede-p cpl))
664    
665  (defun update-class-can-precede-p (cpl)  (defun update-class-can-precede-p (cpl)
# Line 1010  Line 1021 
1021    (or (eq new-super *the-class-t*)    (or (eq new-super *the-class-t*)
1022        (eq (class-of class) (class-of new-super))))        (eq (class-of class) (class-of new-super))))
1023    
1024    (defmethod validate-superclass ((class standard-class) (new-super std-class))
1025      (let ((new-super-meta-class (class-of new-super)))
1026        (or (eq new-super-meta-class *the-class-std-class*)
1027            (eq (class-of class) new-super-meta-class))))
1028    
1029    
1030  ;;;  ;;;
# Line 1241  Line 1256 
1256    
1257  (defmethod change-class ((instance standard-object)  (defmethod change-class ((instance standard-object)
1258                           (new-class standard-class))                           (new-class standard-class))
   (unless (std-instance-p instance)  
     (error "Can't change the class of ~S to ~S~@  
             because it isn't already an instance with metaclass~%~S."  
            instance  
            new-class  
            'standard-class))  
1259    (change-class-internal instance new-class))    (change-class-internal instance new-class))
1260    
1261  (defmethod change-class ((instance standard-object)  (defmethod change-class ((instance funcallable-standard-object)
1262                           (new-class funcallable-standard-class))                           (new-class funcallable-standard-class))
   (unless (fsc-instance-p instance)  
     (error "Can't change the class of ~S to ~S~@  
             because it isn't already an instance with metaclass~%~S."  
            instance  
            new-class  
            'funcallable-standard-class))  
1263    (change-class-internal instance new-class))    (change-class-internal instance new-class))
1264    
1265    (defmethod change-class ((instance standard-object)
1266                             (new-class funcallable-standard-class))
1267      (error "Can't change the class of ~S to ~S~@
1268              because it isn't already an instance with metaclass ~S."
1269             instance new-class 'standard-class))
1270    
1271    (defmethod change-class ((instance funcallable-standard-object)
1272                             (new-class standard-class))
1273      (error "Can't change the class of ~S to ~S~@
1274              because it isn't already an instance with metaclass ~S."
1275             instance new-class 'funcallable-standard-class))
1276    
1277  (defmethod change-class ((instance t) (new-class-name symbol))  (defmethod change-class ((instance t) (new-class-name symbol))
1278    (change-class instance (find-class new-class-name)))    (change-class instance (find-class new-class-name)))
1279    
# Line 1285  Line 1300 
1300  (defmethod class-default-initargs        ((class built-in-class)) ())  (defmethod class-default-initargs        ((class built-in-class)) ())
1301    
1302  (defmethod validate-superclass ((c class) (s built-in-class))  (defmethod validate-superclass ((c class) (s built-in-class))
1303    (eq s *the-class-t*))    (or (eq s *the-class-t*) #+cmu (eq s *the-class-stream*)))
1304    
1305    
1306    
# Line 1294  Line 1309 
1309  ;;;  ;;;
1310    
1311  (defmethod validate-superclass ((c slot-class)  (defmethod validate-superclass ((c slot-class)
1312                                                  (f forward-referenced-class))                                  (f forward-referenced-class))
1313    't)    't)
1314    
1315    

Legend:
Removed from v.1.9.2.2  
changed lines
  Added in v.1.9.2.3

  ViewVC Help
Powered by ViewVC 1.1.5