- (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
- (let ((class (sb!xc:find-class (car body) nil)))
- (unless (typep class 'sb!xc:structure-class)
- (%reader-error stream "~S is not a defined structure type."
- (car body)))
- (let ((def-con (dd-default-constructor
- (layout-info
- (class-layout class)))))
- (unless def-con
- (%reader-error
- stream "The ~S structure does not have a default constructor."
- (car body)))
- (apply (fdefinition def-con) (rest body))))))
+ (simple-reader-error stream
+ "Structure type is not a symbol: ~S"
+ (car body)))
+ (let ((classoid (find-classoid (car body) nil)))
+ (unless (typep classoid 'structure-classoid)
+ (simple-reader-error stream
+ "~S is not a defined structure type."
+ (car body)))
+ (let ((default-constructor (dd-default-constructor
+ (layout-info (classoid-layout classoid)))))
+ (unless default-constructor
+ (simple-reader-error
+ stream
+ "The ~S structure does not have a default constructor."
+ (car body)))
+ (when (and (atom (rest body))
+ (not (null (rest body))))
+ (simple-reader-error stream "improper list for #S: ~S." body))
+ (apply (fdefinition default-constructor)
+ (loop for tail on (rest body) by #'cddr
+ with slot-name = (and (consp tail) (car tail))
+ do (progn
+ (when (null (cdr tail))
+ (simple-reader-error
+ stream
+ "the arglist for the ~S constructor in #S ~
+ has an odd length: ~S."
+ (car body) (rest body)))
+ (when (or (atom (cdr tail))
+ (and (atom (cddr tail))
+ (not (null (cddr tail)))))
+ (simple-reader-error
+ stream
+ "the arglist for the ~S constructor in #S ~
+ is improper: ~S."
+ (car body) (rest body)))
+ (when (not (typep (car tail) 'string-designator))
+ (simple-reader-error
+ stream
+ "a slot name in #S is not a string ~
+ designator: ~S."
+ slot-name))
+ (when (not (keywordp slot-name))
+ (warn 'structure-initarg-not-keyword
+ :format-control
+ "in #S ~S, the use of non-keywords ~
+ as slot specifiers is deprecated: ~S."
+ :format-arguments
+ (list (car body) slot-name))))
+ collect (intern (string (car tail)) *keyword-package*)
+ collect (cadr tail)))))))