- (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 ())
- (:copier nil))
- ,@(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 ((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)