- (bind (((&optional g-name c-name) (ensure-list g-name-and-c-name))
- ((&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch)
- (superclass-slots (get superclass 'boxed-combined-slots))
- (combined-slots (append superclass-slots slots)))
- (setf c-name (or c-name (gensym "C-UNION-")))
- `(progn ,(cstruct-definition name combined-slots)
- ,(struct-definition name superclass slots)
- ,(parse-method-definition name combined-slots)
- ,(unparse-method-definition name combined-slots)
- (eval-when (:load-toplevel :compile-toplevel :execute)
- (setf (get ',name 'boxed-slots) ',slots
- (get ',name 'boxed-combined-slots) ',combined-slots
- (get ',name 'superclass) ',superclass
- (get ',name 'c-name) (or (get ',name 'c-name) ',c-name))
- ,@(when superclass
- (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp))))
- (update-g-boxed-root-c-class ,name)
- ,@(when g-name
- (list `(register-boxed-type ,g-name ',name)))
- ,@(when export
- (append (list `(export ',name (symbol-package ',name))
- `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name))))
- (mapcar (lambda (slot) (slot->export-accessor name slot)) slots))))))
+ (destructuring-bind (&optional g-name c-name) (ensure-list g-name-and-c-name)
+ (destructuring-bind (&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch
+ (let* ((superclass-slots (get superclass 'boxed-combined-slots))
+ (combined-slots (append superclass-slots slots)))
+
+ (setf c-name (or c-name (gensym "C-UNION-")))
+ `(progn ,(cstruct-definition name combined-slots)
+ ,(struct-definition name superclass slots)
+ ,(parse-method-definition name combined-slots)
+ ,(unparse-method-definition name combined-slots)
+ (eval-when (:load-toplevel :compile-toplevel :execute)
+ (setf (get ',name 'boxed-slots) ',slots
+ (get ',name 'boxed-combined-slots) ',combined-slots
+ (get ',name 'superclass) ',superclass
+ (get ',name 'c-name) (or (get ',name 'c-name) ',c-name))
+ ,@(when superclass
+ (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp))))
+ (update-g-boxed-root-c-class ,name)
+ ,@(when g-name
+ (list `(register-boxed-type ,g-name ',name)))
+ ,@(when export
+ (append (list `(export ',name (symbol-package ',name))
+ `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name))))
+ (mapcar (lambda (slot) (slot->export-accessor name slot)) slots))))))))