/[gcl]/gcl/pcl/pcl_std_class.lisp
ViewVC logotype

Diff of /gcl/pcl/pcl_std_class.lisp

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

revision 1.1 by camm, Wed Feb 26 22:21:42 2003 UTC revision 1.2 by camm, Fri Oct 10 03:35:53 2003 UTC
# Line 362  Line 362 
362           (supplied-supers (getf initargs :direct-superclasses unsupplied))           (supplied-supers (getf initargs :direct-superclasses unsupplied))
363           (supplied-slots  (getf initargs :direct-slots unsupplied))           (supplied-slots  (getf initargs :direct-slots unsupplied))
364           (meta           (meta
365             (cond ((neq supplied-meta unsupplied)            (cond ((neq supplied-meta unsupplied)
366                    (find-class supplied-meta))                   (find-class supplied-meta))
367                   ((or (null class)                  ((or (null class)
368                        (forward-referenced-class-p class))                       (forward-referenced-class-p class))
369                    *the-class-standard-class*)                   *the-class-standard-class*)
370                   (t                  (t
371                    (class-of class)))))                     (class-of class)))))  
372      (flet ((fix-super (s)      (flet ((fix-super (s)
373               (cond ((classp s) s)                        (cond ((classp s) s)
374                     ((not (legal-class-name-p s))                              ((not (legal-class-name-p s))
375                      (error "~S is not a class or a legal class name." s))                               (error "~S is not a class or a legal class name." s))
376                     (t                              (t
377                      (or (find-class s nil)                               (or (find-class s nil)
378                          (setf (find-class s)                                   (setf (find-class s)
379                                (make-instance 'forward-referenced-class                                         (make-instance 'forward-referenced-class
380                                               :name s)))))))                                                              :name s)))))))      
381        (loop (unless (remf initargs :metaclass) (return)))            ;;
382        (loop (unless (remf initargs :direct-superclasses) (return)))            ;; CLHS: signal PROGRAM-ERROR, if
383        (loop (unless (remf initargs :direct-slots) (return)))            ;; (a) there are any duplicate slot names
384        (values meta            ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
385                (list* :direct-superclasses            ;; :DOCUMENTATION appears more than one in a single slot description.
386                       (and (neq supplied-supers unsupplied)            (loop for (slot . more) on (getf initargs :direct-slots)
387                            (mapcar #'fix-super supplied-supers))                  for slot-name = (getf slot :name)
388                       :direct-slots                  if (some (lambda (s) (eq slot-name (getf s :name))) more) do
389                       (and (neq supplied-slots unsupplied) supplied-slots)                  (specific-error :invalid-form
390                       initargs)))))                                  "More than one direct slot with name ~S."
391                                    slot-name)
392                    else do
393                    (loop for (option value . more) on slot by #'cddr
394                          when (and (member option '(:allocation :type :initform
395                                                                 :documentation))
396                                    (not (eq unsupplied
397                                             (getf more option unsupplied)))) do
398                                             (specific-error :invalid-form
399                                                             "Duplicate slot option ~S for slot ~S."
400                                                             option slot-name)))
401              ;;
402              ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
403              ;; appears more than once in :DEFAULT-INITARGS class option.
404              (loop for (initarg . more) on (getf initargs :direct-default-initargs)
405                    for name = (car initarg)
406                    when (some (lambda (a) (eq (car a) name)) more) do
407                    (specific-error :invalid-form
408                                    "Duplicate initialization argument ~
409                    name ~S in :default-initargs of class ~A."
410                                    name class))
411              ;;
412              (loop (unless (remf initargs :metaclass) (return)))
413              (loop (unless (remf initargs :direct-superclasses) (return)))
414              (loop (unless (remf initargs :direct-slots) (return)))
415              (values meta
416                      (list* :direct-superclasses
417                             (and (neq supplied-supers unsupplied)
418                                  (mapcar #'fix-super supplied-supers))
419                             :direct-slots
420                             (and (neq supplied-slots unsupplied) supplied-slots)
421                             initargs)))))
422    
423    
424  ;;;  ;;;
# Line 1204  Line 1235 
1235        #+new-kcl-wrapper        #+new-kcl-wrapper
1236        (copy-structure-header ,instance)))        (copy-structure-header ,instance)))
1237    
1238  (defun change-class-internal (instance new-class)  (defun change-class-internal (instance new-class initargs)
1239    (let* ((old-class (class-of instance))    (let* ((old-class (class-of instance))
1240           (copy (allocate-instance new-class))           (copy (allocate-instance new-class))
1241           (new-wrapper (get-wrapper copy))           (new-wrapper (get-wrapper copy))
# Line 1220  Line 1251 
1251      ;; Cfrom are retained.  If such a local slot was unbound, it remains      ;; Cfrom are retained.  If such a local slot was unbound, it remains
1252      ;; unbound."      ;; unbound."
1253      ;;          ;;    
1254      (iterate ((new-slot (list-elements new-layout))      (loop for new-slot in new-layout and new-position from 0
1255                (new-position (interval :from 0)))            for old-position = (posq new-slot old-layout)
1256        (let* ((new-position new-position)            when old-position do
1257               (old-position (posq new-slot old-layout)))              (setf (instance-ref new-slots new-position)
1258          (declare (fixnum new-position))                    (instance-ref old-slots old-position)))
         (when old-position  
           (setf (instance-ref new-slots new-position)  
                 (instance-ref old-slots old-position)))))  
1259    
1260      ;;      ;;
1261      ;; "The values of slots specified as shared in the class Cfrom and      ;; "The values of slots specified as shared in the class Cfrom and
1262      ;; as local in the class Cto are retained."      ;; as local in the class Cto are retained."
1263      ;;      ;;
1264      (iterate ((slot-and-val (list-elements old-class-slots)))      (loop for (name . val) in old-class-slots
1265        (let ((position (posq (car slot-and-val) new-layout)))            for new-position = (posq name new-layout)
1266          (when position            when new-position do
1267            (setf (instance-ref new-slots position) (cdr slot-and-val)))))              (setf (instance-ref new-slots new-position) val))
1268    
1269      ;; 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
1270      ;; old instance point to the new storage.      ;; old instance point to the new storage.
1271      (swap-wrappers-and-slots instance copy)      (swap-wrappers-and-slots instance copy)
1272    
1273      (update-instance-for-different-class copy instance)      (apply #'update-instance-for-different-class copy instance initargs)
1274      instance))      instance))
1275    
1276  (defmethod change-class ((instance standard-object)  (defmethod change-class ((instance standard-object)
1277                           (new-class standard-class))                           (new-class standard-class)
1278    (unless (std-instance-p instance)                           &rest initargs)
1279      (error "Can't change the class of ~S to ~S~@    (change-class-internal instance new-class initargs))
1280              because it isn't already an instance with metaclass~%~S."  
1281             instance  ;; FIXME add class funcallable-standard-object ??
1282             new-class  ;(defmethod change-class ((instance funcallable-standard-object)
1283             'standard-class))  ;                        (new-class funcallable-standard-class)
1284    (change-class-internal instance new-class))  ;                        &rest initargs)
1285    ;  (change-class-internal instance new-class initargs))
1286    
1287  (defmethod change-class ((instance standard-object)  (defmethod change-class ((instance standard-object)
1288                           (new-class funcallable-standard-class))                           (new-class funcallable-standard-class)
1289    (unless (fsc-instance-p instance)                           &rest initargs)
1290      (error "Can't change the class of ~S to ~S~@    (declare (ignore initargs))
1291              because it isn't already an instance with metaclass~%~S."    (error "Can't change the class of ~S to ~S~@
1292             instance            because it isn't already an instance with metaclass ~S."
1293             new-class           instance new-class 'standard-class))
1294             'funcallable-standard-class))  
1295    (change-class-internal instance new-class))  ;(defmethod change-class ((instance funcallable-standard-object)
1296    ;                        (new-class standard-class)
1297    ;                        &rest initargs)
1298    ;  (declare (ignore initargs))
1299    ;  (error "Can't change the class of ~S to ~S~@
1300    ;          because it isn't already an instance with metaclass ~S."
1301    ;        instance new-class 'funcallable-standard-class))
1302    
1303    (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
1304      (apply #'change-class instance (find-class new-class-name) initargs))
1305    
 (defmethod change-class ((instance t) (new-class-name symbol))  
   (change-class instance (find-class new-class-name)))  
1306    
1307    
1308    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26