/[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.57 by gerd, Tue Apr 29 10:33:51 2003 UTC revision 1.58 by gerd, Tue Apr 29 11:57:43 2003 UTC
# Line 622  Line 622 
622                                (make-direct-slotd class pl))                                (make-direct-slotd class pl))
623                              direct-slots)))                              direct-slots)))
624          (setq direct-slots (slot-value class 'direct-slots)))          (setq direct-slots (slot-value class 'direct-slots)))
625      (when defstruct-p      (if defstruct-p
626        (let* ((include (car (slot-value class 'direct-superclasses)))          (let* ((include (car (slot-value class 'direct-superclasses)))
627               (conc-name (symbolicate *package*                 (conc-name (symbolicate *package*
628                                       (if (symbol-package name)                                         (if (symbol-package name)
629                                           (package-name (symbol-package name))                                             (package-name (symbol-package name))
630                                           "")                                             "")
631                                       "::" name " structure class "))                                         "::" name " structure class "))
632               ;;                 ;;
633               ;; It's not possible to use a generalized name for the                 ;; It's not possible to use a generalized name for the
634               ;; constructor function.  It shouldn't matter though, I think,                 ;; constructor function.  It shouldn't matter though, I think,
635               ;; like for the slot names above, because this stuff is not                 ;; like for the slot names above, because this stuff is not
636               ;; supposed to be used by users directly.                 ;; supposed to be used by users directly.
637               (constructor                 (constructor
638                 (symbolicate *package* conc-name " constructor"))                  (symbolicate *package* conc-name " constructor"))
639               (defstruct `(defstruct (,name                 (defstruct `(defstruct (,name
640                                        ,@(when include                                          ,@(when include
641                                            `((:include ,(class-name include))))                                              `((:include ,(class-name include))))
642                                        (:predicate nil)                                          (:predicate nil)
643                                        (:conc-name ,conc-name)                                          (:conc-name ,conc-name)
644                                        (:constructor ,constructor ()))                                          (:constructor ,constructor ()))
645                             ;;                               ;;
646                             ;; Use a temporary unbound marker that lets                               ;; Use a temporary unbound marker that lets
647                             ;; SHARED-INITIALIZE recognize if a before-method                               ;; SHARED-INITIALIZE recognize if a before-method
648                             ;; has written to a slot.                               ;; has written to a slot.
649                             ,@(mapcar (lambda (slot)                               ,@(mapcar (lambda (slot)
650                                         `(,(slot-definition-name slot)                                           `(,(slot-definition-name slot)
651                                           '.unbound.))                                              '.unbound.))
652                                       direct-slots)))                                         direct-slots)))
653               (reader-names (mapcar (lambda (slotd)                 (reader-names (mapcar (lambda (slotd)
654                                       (list 'slot-accessor name                                         (list 'slot-accessor name
655                                             (slot-definition-name slotd)                                               (slot-definition-name slotd)
656                                             'reader))                                               'reader))
657                                     direct-slots))                                       direct-slots))
658               (writer-names (mapcar (lambda (slotd)                 (writer-names (mapcar (lambda (slotd)
659                                       (list 'slot-accessor name                                         (list 'slot-accessor name
660                                             (slot-definition-name slotd)                                               (slot-definition-name slotd)
661                                             'writer))                                               'writer))
662                                     direct-slots))                                       direct-slots))
663               (readers-init                 (readers-init
664                (mapcar (lambda (slotd reader-name)                  (mapcar (lambda (slotd reader-name)
665                          (let ((accessor                            (let ((accessor
666                                 (slot-definition-defstruct-accessor-symbol slotd)))                                   (slot-definition-defstruct-accessor-symbol slotd)))
667                            `(defun ,reader-name (obj)                              `(defun ,reader-name (obj)
668                               (declare (type ,name obj))                                 (declare (type ,name obj))
669                               (,accessor obj))))                                 (,accessor obj))))
670                        direct-slots reader-names))                          direct-slots reader-names))
671               (writers-init                 (writers-init
672                (mapcar (lambda (slotd writer-name)                  (mapcar (lambda (slotd writer-name)
673                          (let ((accessor                            (let ((accessor
674                                 (slot-definition-defstruct-accessor-symbol slotd)))                                   (slot-definition-defstruct-accessor-symbol slotd)))
675                            `(defun ,writer-name (nv obj)                              `(defun ,writer-name (nv obj)
676                               (declare (type ,name obj))                                 (declare (type ,name obj))
677                               (setf (,accessor obj) nv))))                                 (setf (,accessor obj) nv))))
678                        direct-slots writer-names))                          direct-slots writer-names))
679               (defstruct-form                 (defstruct-form
680                 `(progn                  `(progn
681                    ,defstruct                     ,defstruct
682                    ,@readers-init ,@writers-init)))                     ,@readers-init ,@writers-init)))
683          (unless (structure-type-p name) (eval defstruct-form))            (unless (structure-type-p name) (eval defstruct-form))
684          (mapc (lambda (dslotd reader-name writer-name)            (mapc (lambda (dslotd reader-name writer-name)
685                  (let* ((reader (when (fboundp reader-name)                    (let* ((reader (when (fboundp reader-name)
686                                   (gdefinition reader-name)))                                     (gdefinition reader-name)))
687                         (writer (when (fboundp writer-name)                           (writer (when (fboundp writer-name)
688                                   (gdefinition writer-name))))                                     (gdefinition writer-name))))
689                    (setf (slot-value dslotd 'internal-reader-function) reader)                      (setf (slot-value dslotd 'internal-reader-function) reader)
690                    (setf (slot-value dslotd 'internal-writer-function) writer)))                      (setf (slot-value dslotd 'internal-writer-function) writer)))
691                direct-slots reader-names writer-names)                  direct-slots reader-names writer-names)
692          (setf (slot-value class 'defstruct-form) defstruct-form)            (setf (slot-value class 'defstruct-form) defstruct-form)
693          (setf (slot-value class 'defstruct-constructor) constructor))))            (setf (slot-value class 'defstruct-constructor) constructor))
694            ;;
695            ;; ALLOCATE-INSTANCE is supposed to work with structures
696            ;; defined with DEFSTRUCT.
697            (with-slots (defstruct-constructor) class
698              (setq defstruct-constructor
699                    (make-defstruct-allocation-function class)))))
700      ;;
701    (add-direct-subclasses class direct-superclasses)    (add-direct-subclasses class direct-superclasses)
702    (setf (slot-value class 'class-precedence-list)    (setf (slot-value class 'class-precedence-list)
703          (compute-class-precedence-list class))          (compute-class-precedence-list class))
# Line 709  Line 716 
716    (make-class-predicate class predicate-name)    (make-class-predicate class predicate-name)
717    (add-slot-accessors class direct-slots))    (add-slot-accessors class direct-slots))
718    
719    ;;;
720    ;;; Return a closure for allocating an uninitialized structure
721    ;;; instance of class CLASS.
722    ;;;
723    (defun make-defstruct-allocation-function (class)
724      (let ((dd (get-structure-dd (class-name class))))
725        (lambda ()
726          (let ((instance (kernel::%make-instance (kernel::dd-length dd)))
727                (raw-index (kernel::dd-raw-index dd)))
728            (setf (kernel::%instance-layout instance)
729                  (kernel::compiler-layout-or-lose (kernel::dd-name dd)))
730            (when raw-index
731              (setf (kernel::%instance-ref
732                     instance raw-index
733                     (make-array (kernel::dd-raw-length dd)
734                                 :element-type '(unsigned-byte 32)))))
735            instance))))
736    
737  (defmethod direct-slot-definition-class ((class structure-class)  (defmethod direct-slot-definition-class ((class structure-class)
738                                           &rest initargs)                                           &rest initargs)
739    (declare (ignore initargs))    (declare (ignore initargs))

Legend:
Removed from v.1.57  
changed lines
  Added in v.1.58

  ViewVC Help
Powered by ViewVC 1.1.5