/[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.4 by camm, Wed Sep 7 03:02:50 2005 UTC revision 1.5 by camm, Mon Nov 14 04:51:23 2005 UTC
# Line 527  Line 527 
527                               (*structure-type* type)                               (*structure-type* type)
528                               #+lucid                               #+lucid
529                               (*structure-length* (structure-length x type)))                               (*structure-length* (structure-length x type)))
530                          (find-class-from-cell type cell))))                          (find-class-from-cell type cell nil))))
531             (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))             (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
532        (when (symbolp type)        (when (symbolp type)
533          (setq wft-type1 type  wft-wrapper1 wrapper))          (setq wft-type1 type  wft-wrapper1 wrapper))
# Line 607  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              (let ((res (ensure-class symbol              (when (fboundp 'ensure-class)
611                                       :metaclass 'structure-class                (let ((res (ensure-class symbol
612                                       :name symbol                                         :metaclass 'structure-class
613                                       :direct-superclasses                                         :name symbol
614                                       (when (structure-type-included-type-name symbol)                                         :direct-superclasses
615                                         (list (structure-type-included-type-name symbol)))                                         (when (structure-type-included-type-name symbol)
616                                       :direct-slots                                           (list (structure-type-included-type-name symbol)))
617                                       (mapcar #'slot-initargs-from-structure-slotd                                         :direct-slots
618                                               (structure-type-slot-description-list symbol)))))                                         (mapcar #'slot-initargs-from-structure-slotd
619                (setf (class-defstruct-constructor res) (car (si::s-data-constructors (get symbol 'si::s-data))))                                                 (structure-type-slot-description-list symbol)))))
620                res)))                  (setf (class-defstruct-constructor res) (car (si::s-data-constructors (get symbol 'si::s-data))))
621                    res))))
622        (error "~S is not a legal structure class name." symbol))))        (error "~S is not a legal structure class name." symbol))))
623    
624  #-cmu17  #-cmu17

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

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