- (let* ((include (car (slot-value class 'direct-superclasses)))
- (conc-name (intern (format nil "~S structure class " name)))
- (constructor (intern (format nil "~A constructor" conc-name)))
- (defstruct `(defstruct (,name
- ,@(when include
- `((:include ,(class-name include))))
- (:print-function print-std-instance)
- (:predicate nil)
- (:conc-name ,conc-name)
- (:constructor ,constructor ()))
- ,@(mapcar #'(lambda (slot)
- `(,(slot-definition-name slot)
- +slot-unbound+))
- direct-slots)))
- (reader-names (mapcar (lambda (slotd)
- (intern (format nil
- "~A~A reader"
- conc-name
- (slot-definition-name
- slotd))))
- direct-slots))
- (writer-names (mapcar (lambda (slotd)
- (intern (format nil
- "~A~A writer"
- conc-name
- (slot-definition-name
- slotd))))
- direct-slots))
- (readers-init
- (mapcar (lambda (slotd reader-name)
- (let ((accessor
- (slot-definition-defstruct-accessor-symbol
- slotd)))
- `(defun ,reader-name (obj)
- (declare (type ,name obj))
- (,accessor obj))))
- direct-slots reader-names))
- (writers-init
- (mapcar (lambda (slotd writer-name)
- (let ((accessor
- (slot-definition-defstruct-accessor-symbol
- slotd)))
- `(defun ,writer-name (nv obj)
- (declare (type ,name obj))
- (setf (,accessor obj) nv))))
- direct-slots writer-names))
- (defstruct-form
- `(progn
- ,defstruct
- ,@readers-init ,@writers-init
- (cons nil nil))))
- (unless (structure-type-p name) (eval defstruct-form))
- (mapc #'(lambda (dslotd reader-name writer-name)
- (let* ((reader (gdefinition reader-name))
- (writer (when (gboundp writer-name)
- (gdefinition writer-name))))
- (setf (slot-value dslotd 'internal-reader-function)
- reader)
- (setf (slot-value dslotd 'internal-writer-function)
- writer)))
- direct-slots reader-names writer-names)
- (setf (slot-value class 'defstruct-form) defstruct-form)
- (setf (slot-value class 'defstruct-constructor) constructor))))
- (add-direct-subclasses class direct-superclasses)
- (setf (slot-value class 'class-precedence-list)
- (compute-class-precedence-list class))
- (setf (slot-value class 'slots) (compute-slots class))
- (let ((lclass (cl:find-class (class-name class))))
- (setf (sb-kernel:class-pcl-class lclass) class)
- (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass)))
- (update-pv-table-cache-info class)
- (setq predicate-name (if predicate-name-p
+ (let ((include (car (slot-value class 'direct-superclasses))))
+ (multiple-value-bind (defstruct-form constructor reader-names writer-names)
+ (make-structure-class-defstruct-form name direct-slots include)
+ (unless (structure-type-p name) (eval defstruct-form))
+ (mapc #'(lambda (dslotd reader-name writer-name)
+ (let* ((reader (gdefinition reader-name))
+ (writer (when (gboundp writer-name)
+ (gdefinition writer-name))))
+ (setf (slot-value dslotd 'internal-reader-function)
+ reader)
+ (setf (slot-value dslotd 'internal-writer-function)
+ writer)))
+ direct-slots reader-names writer-names)
+ (setf (slot-value class 'defstruct-form) defstruct-form)
+ (setf (slot-value class 'defstruct-constructor) constructor))))
+ (add-direct-subclasses class direct-superclasses)
+ (setf (slot-value class 'class-precedence-list)
+ (compute-class-precedence-list class))
+ (setf (slot-value class 'slots) (compute-slots class))
+ (let ((lclass (cl:find-class (class-name class))))
+ (setf (sb-kernel:class-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass)))
+ (update-pv-table-cache-info class)
+ (setq predicate-name (if predicate-name-p