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

Diff of /gcl/pcl/gcl_pcl_braid.lisp

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

revision 1.3 by camm, Sat Jul 23 08:55:27 2005 UTC revision 1.4 by camm, Wed Sep 7 03:02:50 2005 UTC
# Line 224  Line 224 
224                  (setf (wrapper-class-slots wrapper)                  (setf (wrapper-class-slots wrapper)
225                        ()))                        ()))
226                                
227                (setq proto (if (eq meta 'funcallable-standard-class)                (setq proto (if (eq name 'function) #'cons ;;FIXME -- not necessary
228                                (if (eq meta 'funcallable-standard-class)
229                                (allocate-funcallable-instance wrapper)                                (allocate-funcallable-instance wrapper)
230                                (allocate-standard-instance wrapper)))                                (allocate-standard-instance wrapper))))
231                            
232                (setq direct-slots                (setq direct-slots
233                      (bootstrap-make-slot-definitions                      (bootstrap-make-slot-definitions
# Line 462  Line 463 
463    (let* ((built-in-class (find-class 'built-in-class))    (let* ((built-in-class (find-class 'built-in-class))
464           (built-in-class-wrapper (class-wrapper built-in-class)))           (built-in-class-wrapper (class-wrapper built-in-class)))
465      (dolist (e *built-in-classes*)      (dolist (e *built-in-classes*)
466        (let ((class (allocate-standard-instance built-in-class-wrapper)))        (unless (find-class (car e) nil)
467          (setf (find-class (car e)) class))))          (let ((class (allocate-standard-instance built-in-class-wrapper)))
468              (setf (find-class (car e)) class)))))
469    
470    ;;    ;;
471    ;; In the second pass, we initialize the class objects.    ;; In the second pass, we initialize the class objects.
# Line 605  Line 607 
607      (if (structure-type-p symbol)      (if (structure-type-p symbol)
608          (unless (eq find-structure-class symbol)          (unless (eq find-structure-class symbol)
609            (let ((find-structure-class symbol))            (let ((find-structure-class symbol))
610              (ensure-class symbol              (let ((res (ensure-class symbol
611                            :metaclass 'structure-class                                       :metaclass 'structure-class
612                            :name symbol                                       :name symbol
613                            :direct-superclasses                                       :direct-superclasses
614                            (when (structure-type-included-type-name symbol)                                       (when (structure-type-included-type-name symbol)
615                              (list (structure-type-included-type-name symbol)))                                         (list (structure-type-included-type-name symbol)))
616                            :direct-slots                                       :direct-slots
617                            (mapcar #'slot-initargs-from-structure-slotd                                       (mapcar #'slot-initargs-from-structure-slotd
618                                    (structure-type-slot-description-list symbol)))))                                               (structure-type-slot-description-list symbol)))))
619                  (setf (class-defstruct-constructor res) (car (si::s-data-constructors (get symbol 'si::s-data))))
620                  res)))
621        (error "~S is not a legal structure class name." symbol))))        (error "~S is not a legal structure class name." symbol))))
622    
623  #-cmu17  #-cmu17

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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