(and layout (typep (layout-info layout) 'defstruct-description))))
(sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
- `(truly-the ,(dd-name dd)
- ,(if (compiler-layout-ready-p (dd-name dd))
- `(%make-structure-instance ,dd ,slot-specs ,@slot-vars)
- ;; Non-toplevel defstructs don't have a layout at compile time,
- ;; so we need to construct the actual function at runtime -- but
- ;; we cache it at the call site, so that we don't perform quite
- ;; so horribly.
- `(let* ((cell (load-time-value (list nil)))
- (fun (car cell)))
- (if (functionp fun)
- (funcall fun ,@slot-vars)
- (funcall (setf (car cell)
- (%make-structure-instance-allocator ,dd ,slot-specs))
- ,@slot-vars))))))
+ (if (compiler-layout-ready-p (dd-name dd))
+ `(truly-the ,(dd-name dd)
+ (%make-structure-instance ,dd ,slot-specs ,@slot-vars))
+ ;; Non-toplevel defstructs don't have a layout at compile time,
+ ;; so we need to construct the actual function at runtime -- but
+ ;; we cache it at the call site, so that we don't perform quite
+ ;; so horribly.
+ `(let* ((cell (load-time-value (list nil)))
+ (fun (car cell)))
+ (if (functionp fun)
+ (funcall fun ,@slot-vars)
+ (funcall (setf (car cell)
+ (%make-structure-instance-allocator ,dd ,slot-specs))
+ ,@slot-vars)))))
(declaim (ftype (sfunction (defstruct-description list) function)
%make-structure-instance-allocator))
(let* ((accessor-name (dsd-accessor-name dsd))
(dsd-type (dsd-type dsd)))
(when accessor-name
- (setf (info :function :structure-accessor accessor-name) dd)
(let ((inherited (accessor-inherited-data accessor-name dd)))
(cond
((not inherited)
+ (setf (info :function :structure-accessor accessor-name) dd)
(multiple-value-bind (reader-designator writer-designator)
(slot-accessor-transforms dd dsd)
(sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
arg
(arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
- (arg-type (get-slot name))))
+ (arg-type (get-slot name))
+ (when supplied-test-p
+ (vars supplied-test))))
(t
(do-default arg)))))
(arglist `(,wot ,(if def-p def slot-def)
,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
- (arg-type type key name))))
+ (arg-type type key name)
+ (when supplied-test-p
+ (vars supplied-test)))))
(do-default key t))))
(when allowp