X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=bad8d9554e6265b4a97a2e442a0cfa751c8b13bc;hb=8af1983e6de2609fec800b6ac2bf3b12ff9c68b9;hp=91a361bf4dd2c319eeb07d5eef08de7b76c33c70;hpb=e37366e7bb72bc80c6c9908efe09f94ce26add16;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 91a361b..bad8d95 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -13,26 +13,22 @@ ;;;; structure frobbing primitives +;;; Allocate a new instance with LENGTH data slots. (defun %make-instance (length) - #!+sb-doc - "Allocate a new instance with LENGTH data slots." (declare (type index length)) (%make-instance length)) +;;; Given an instance, return its length. (defun %instance-length (instance) - #!+sb-doc - "Given an instance, return its length." (declare (type instance instance)) (%instance-length instance)) +;;; Return the value from the INDEXth slot of INSTANCE. This is SETFable. (defun %instance-ref (instance index) - #!+sb-doc - "Return the value from the INDEXth slot of INSTANCE. This is SETFable." (%instance-ref instance index)) +;;; Set the INDEXth slot of INSTANCE to NEW-VALUE. (defun %instance-set (instance index new-value) - #!+sb-doc - "Set the INDEXth slot of INSTANCE to NEW-VALUE." (setf (%instance-ref instance index) new-value)) (defun %raw-ref-single (vec index) @@ -104,7 +100,7 @@ (defun %set-funcallable-instance-info (fin i new-value) (%set-funcallable-instance-info fin i new-value)) -(defun funcallable-instance-function (fin) +(defun funcallable-instance-fun (fin) (%funcallable-instance-lexenv fin)) ;;; The heart of the magic of funcallable instances ("FINs"). The @@ -123,22 +119,249 @@ ;;; both the code pointer and the lexenv, since that code pointer (for ;;; an instance-lambda) is expecting that lexenv to be accessed. This ;;; effectively pre-flattens what would otherwise be a chain of -;;; indirections. Lest this sound like an excessively obscure case, -;;; note that it happens when PCL dispatch functions are -;;; byte-compiled. +;;; indirections. (That used to happen when PCL dispatch functions +;;; were byte-compiled; now that the byte compiler is gone, I can't +;;; think of another example offhand. -- WHN 2001-10-06) ;;; ;;; The only loss is that if someone accesses the -;;; FUNCALLABLE-INSTANCE-FUNCTION, then won't get a FIN back. This -;;; probably doesn't matter, since PCL only sets the FIN function. And -;;; the only reason that interpreted functions are FINs instead of -;;; bare closures is for debuggability. -(defun (setf funcallable-instance-function) (new-value fin) - (setf (%funcallable-instance-function fin) - (%closure-function new-value)) +;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This probably +;;; doesn't matter, since PCL only sets the FIN function. +(defun (setf funcallable-instance-fun) (new-value fin) + (setf (%funcallable-instance-fun fin) + (%closure-fun new-value)) (setf (%funcallable-instance-lexenv fin) (if (funcallable-instance-p new-value) (%funcallable-instance-lexenv new-value) new-value))) + +;;; service function for structure constructors +(defun %make-instance-with-layout (layout) + (let ((result (%make-instance (layout-length layout)))) + (setf (%instance-layout result) layout) + result)) + +;;;; target-only parts of the DEFSTRUCT top level code + +;;; A list of hooks designating functions of one argument, the +;;; classoid, to be called when a defstruct is evaluated. +(defvar *defstruct-hooks* nil) + +;;; Catch attempts to mess up definitions of symbols in the CL package. +(defun protect-cl (symbol) + (/show0 "entering PROTECT-CL, SYMBOL=..") + (/hexstr symbol) + (when (and *cold-init-complete-p* + (eq (symbol-package symbol) *cl-package*)) + (cerror "Go ahead and patch the system." + "attempting to modify a symbol in the COMMON-LISP package: ~S" + symbol)) + (/show0 "leaving PROTECT-CL") + (values)) + +;;; the part of %DEFSTRUCT which makes sense only on the target SBCL +;;; +;;; (The "static" in the name is because it needs to be done not only +;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as +;;; possible, to simulate static linking of structure functions as +;;; nearly as possible.) +(defun %target-defstruct (dd layout) + (declare (type defstruct-description dd)) + (declare (type layout layout)) + + (/show0 "entering %TARGET-DEFSTRUCT") + + (remhash (dd-name dd) *typecheckfuns*) + + ;; (Constructors aren't set up here, because constructors are + ;; varied enough (possibly parsing any specified argument list) + ;; that we can't reasonably implement them as closures, so we + ;; implement them with DEFUN instead.) + + ;; Set FDEFINITIONs for slot accessors. + (dolist (dsd (dd-slots dd)) + (/show0 "doing FDEFINITION for slot accessor") + (let ((accessor-name (dsd-accessor-name dsd))) + ;; We mustn't step on any inherited accessors + (unless (accessor-inherited-data accessor-name dd) + (/show0 "ACCESSOR-NAME=..") + (/hexstr accessor-name) + (protect-cl accessor-name) + (/hexstr "getting READER-FUN and WRITER-FUN") + (multiple-value-bind (reader-fun writer-fun) + (slot-accessor-funs dd dsd) + (declare (type function reader-fun writer-fun)) + (/show0 "got READER-FUN and WRITER-FUN=..") + (/hexstr reader-fun) + (setf (symbol-function accessor-name) reader-fun) + (unless (dsd-read-only dsd) + (/show0 "setting FDEFINITION for WRITER-FUN=..") + (/hexstr writer-fun) + (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))) + + ;; Set FDEFINITION for copier. + (when (dd-copier-name dd) + (/show0 "doing FDEFINITION for copier") + (protect-cl (dd-copier-name dd)) + ;; We can't use COPY-STRUCTURE for other kinds of objects, notably + ;; funcallable structures, since it returns a STRUCTURE-OBJECT. + ;; (And funcallable instances don't need copiers anyway.) + (aver (eql (dd-type dd) 'structure)) + (setf (symbol-function (dd-copier-name dd)) + ;; FIXME: should use a closure which checks arg type before copying + #'copy-structure)) + + ;; Set FDEFINITION for predicate. + (when (dd-predicate-name dd) + (/show0 "doing FDEFINITION for predicate") + (protect-cl (dd-predicate-name dd)) + (setf (symbol-function (dd-predicate-name dd)) + (ecase (dd-type dd) + ;; structures with LAYOUTs + ((structure funcallable-structure) + (/show0 "with-LAYOUT case") + (lambda (object) + (locally ; <- to keep SAFETY 0 from affecting arg count checking + (declare (optimize (speed 3) (safety 0))) + (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") + (/nohexstr object) + (/nohexstr layout) + (typep-to-layout object layout)))) + ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) + ;; + ;; FIXME: should handle the :NAMED T case in these cases + (vector + (/show0 ":TYPE VECTOR case") + #'vectorp) + (list + (/show0 ":TYPE LIST case") + #'listp)))) + + (when (dd-doc dd) + (setf (fdocumentation (dd-name dd) 'type) + (dd-doc dd))) + + ;; the BOUNDP test here is to get past cold-init. + (when (boundp '*defstruct-hooks*) + (dolist (fun *defstruct-hooks*) + (funcall fun (find-classoid (dd-name dd))))) + + (/show0 "leaving %TARGET-DEFSTRUCT") + (values)) + +;;;; generating out-of-line slot accessor functions + +;;; FIXME: Ideally, the presence of the type checks in the functions +;;; here would be conditional on the optimization policy at the point +;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler +;;; thing, putting in the type checks unconditionally.) + +;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN). +(defun slot-accessor-funs (dd dsd) + + #+sb-xc (/show0 "entering SLOT-ACCESSOR-FUNS") + + ;; various code generators + ;; + ;; Note: They're only minimally parameterized, and cavalierly grab + ;; things like INSTANCE and DSD-INDEX from the namespace they're + ;; expanded in. + (macrolet (;; code shared between funcallable instance case and the + ;; ordinary STRUCTURE-OBJECT case: Handle native + ;; structures with LAYOUTs and (possibly) raw slots. + (%native-slot-accessor-funs (dd-ref-fun-name) + (let ((instance-type-check-form + '(%check-structure-type-from-layout instance layout))) + (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form) + `(let ((layout (dd-layout-or-lose dd)) + (dsd-raw-type (dsd-raw-type dsd))) + #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code") + ;; Map over all the possible RAW-TYPEs, compiling + ;; a different closure function for each one, so + ;; that once the COND over RAW-TYPEs happens (at + ;; the time closure is allocated) there are no + ;; more decisions to be made and things execute + ;; reasonably efficiently. + (cond + ;; nonraw slot case + ((eql dsd-raw-type t) + #+sb-xc (/show0 "in nonraw slot case") + (%slotplace-accessor-funs + (,dd-ref-fun-name instance dsd-index) + ,instance-type-check-form)) + ;; raw slot cases + ,@(mapcar (lambda (rtd) + (let ((raw-type (raw-slot-data-raw-type rtd)) + (accessor-name + (raw-slot-data-accessor-name rtd)) + (n-words (raw-slot-data-n-words rtd))) + `((equal dsd-raw-type ',raw-type) + #+sb-xc (/show0 "in raw slot case") + (let ((raw-index (dd-raw-index dd))) + (multiple-value-bind (scaled-dsd-index + misalignment) + (floor dsd-index ,n-words) + (aver (zerop misalignment)) + (%slotplace-accessor-funs + (,accessor-name (,dd-ref-fun-name + instance + raw-index) + scaled-dsd-index) + ,instance-type-check-form)))))) + *raw-slot-data-list*) + ;; oops + (t + (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type)))))) + ;; code shared between DEFSTRUCT :TYPE LIST and + ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed + ;; structure" case, with no LAYOUTs and no raw slots. + (%colontyped-slot-accessor-funs () (error "stub")) + ;; the common structure of the raw-slot and not-raw-slot + ;; cases, defined in terms of the writable SLOTPLACE. All + ;; possible flavors of slot access should be able to pass + ;; through here. + (%slotplace-accessor-funs (slotplace instance-type-check-form) + (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form) + `(values (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + ,slotplace) + (let ((typecheckfun (typespec-typecheckfun dsd-type))) + (lambda (new-value instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + (funcall typecheckfun new-value) + (/noshow0 "back from TYPECHECKFUN") + (setf ,slotplace new-value)))))) + + (let ((dsd-index (dsd-index dsd)) + (dsd-type (dsd-type dsd))) + + #+sb-xc (/show0 "got DSD-TYPE=..") + #+sb-xc (/hexstr dsd-type) + (ecase (dd-type dd) + + ;; native structures + (structure + #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE") + (%native-slot-accessor-funs %instance-ref)) + + ;; structures with the :TYPE option + + ;; FIXME: Worry about these later.. + #| + ;; In :TYPE LIST and :TYPE VECTOR structures, ANSI specifies the + ;; layout completely, so that raw slots are impossible. + (list + (dd-type-slot-accessor-funs nth-but-with-sane-arg-order + `(%check-structure-type-from-dd + :maybe-raw-p nil)) + (vector + (dd-type-slot-accessor-funs aref + :maybe-raw-p nil))) + |# + )))) ;;; Copy any old kind of structure. (defun copy-structure (structure) @@ -172,220 +395,176 @@ res)) -;;; default PRINT and MAKE-LOAD-FORM methods - +;;; default PRINT-OBJECT method + +(defun %default-structure-pretty-print (structure stream) + (let* ((layout (%instance-layout structure)) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) + ;; KLUDGE: during the build process with SB-SHOW, we can sometimes + ;; attempt to print out a PCL object (with null LAYOUT-INFO). + #!+sb-show + (when (null dd) + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)")) + (return-from %default-structure-pretty-print nil)) + (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") + (prin1 name stream) + (let ((remaining-slots (dd-slots dd))) + (when remaining-slots + (write-char #\space stream) + ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here, + ;; but I can't see why. -- WHN 20000205 + (pprint-newline :linear stream) + (loop + (pprint-pop) + (let ((slot (pop remaining-slots))) + (write-char #\: stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (output-object (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream) + (when (null remaining-slots) + (return)) + (write-char #\space stream) + (pprint-newline :linear stream)))))))) +(defun %default-structure-ugly-print (structure stream) + (let* ((layout (%instance-layout structure)) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) + (descend-into (stream) + (write-string "#S(" stream) + (prin1 name stream) + (do ((index 0 (1+ index)) + (remaining-slots (dd-slots dd) (cdr remaining-slots))) + ((or (null remaining-slots) + (and (not *print-readably*) + *print-length* + (>= index *print-length*))) + (if (null remaining-slots) + (write-string ")" stream) + (write-string " ...)" stream))) + (declare (type index index)) + (write-char #\space stream) + (write-char #\: stream) + (let ((slot (first remaining-slots))) + (output-symbol-name (symbol-name (dsd-name slot)) stream) + (write-char #\space stream) + (output-object + (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream)))))) (defun default-structure-print (structure stream depth) (declare (ignore depth)) - (if (funcallable-instance-p structure) - (print-unreadable-object (structure stream :identity t :type t)) - (let* ((type (%instance-layout structure)) - (name (sb!xc:class-name (layout-class type))) - (dd (layout-info type))) - (if *print-pretty* - (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") - (prin1 name stream) - (let ((slots (dd-slots dd))) - (when slots - (write-char #\space stream) - ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here, - ;; but I can't see why. -- WHN 20000205 - (pprint-newline :linear stream) - (loop - (pprint-pop) - (let ((slot (pop slots))) - (write-char #\: stream) - (output-symbol-name (dsd-%name slot) stream) - (write-char #\space stream) - (pprint-newline :miser stream) - (output-object (funcall (fdefinition (dsd-accessor slot)) - structure) - stream) - (when (null slots) - (return)) - (write-char #\space stream) - (pprint-newline :linear stream)))))) - (descend-into (stream) - (write-string "#S(" stream) - (prin1 name stream) - (do ((index 0 (1+ index)) - (slots (dd-slots dd) (cdr slots))) - ((or (null slots) - (and (not *print-readably*) - *print-length* - (>= index *print-length*))) - (if (null slots) - (write-string ")" stream) - (write-string " ...)" stream))) - (declare (type index index)) - (write-char #\space stream) - (write-char #\: stream) - (let ((slot (first slots))) - (output-symbol-name (dsd-%name slot) stream) - (write-char #\space stream) - (output-object (funcall (fdefinition (dsd-accessor slot)) - structure) - stream)))))))) + (cond ((funcallable-instance-p structure) + (print-unreadable-object (structure stream :identity t :type t))) + (*print-pretty* + (%default-structure-pretty-print structure stream)) + (t + (%default-structure-ugly-print structure stream)))) (def!method print-object ((x structure-object) stream) - (default-structure-print x stream *current-level*)) - -(defun make-load-form-saving-slots (object &key slot-names environment) - (declare (ignore object environment)) - (if slot-names - (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE - :just-dump-it-normally)) + (default-structure-print x stream *current-level-in-print*)) +;;;; testing structure types + ;;; Return true if OBJ is an object of the structure type ;;; corresponding to LAYOUT. This is called by the accessor closures, -;;; which have a handle on the type's layout. +;;; which have a handle on the type's LAYOUT. ;;; ;;; FIXME: This is fairly big, so it should probably become -;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so -;;; that the things which call it are all closures, so that it's -;;; expanded only in a small number of places. +;;; MAYBE-INLINE instead of INLINE, or its inlineness should become +;;; conditional (probably through DEFTRANSFORM) on (> SPEED SPACE). Or +;;; else we could fix things up so that the things which call it are +;;; all closures, so that it's expanded only in a small number of +;;; places. #!-sb-fluid (declaim (inline typep-to-layout)) (defun typep-to-layout (obj layout) (declare (type layout layout) (optimize (speed 3) (safety 0))) + (/noshow0 "entering TYPEP-TO-LAYOUT, OBJ,LAYOUT=..") + (/nohexstr obj) + (/nohexstr layout) (when (layout-invalid layout) (error "An obsolete structure accessor function was called.")) + (/noshow0 "back from testing LAYOUT-INVALID LAYOUT") ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code. (and (typep obj 'instance) - (let (;; FIXME: Mightn't there be a slight efficiency improvement - ;; by delaying the binding of DEPTHOID 'til it's needed? - (depthoid (layout-depthoid layout)) - (obj-layout (%instance-layout obj))) + (let ((obj-layout (%instance-layout obj))) (cond ((eq obj-layout layout) + ;; (In this case OBJ-LAYOUT can't be invalid, because + ;; we determined LAYOUT is valid in the test above.) + (/noshow0 "EQ case") t) - ;; FIXME: Does the test for LAYOUT-INVALID really belong - ;; after the test for EQ LAYOUT? Either explain why this - ;; is, or change the order. ((layout-invalid obj-layout) + (/noshow0 "LAYOUT-INVALID case") (error 'layout-invalid - :expected-type (layout-class obj-layout) + :expected-type (layout-classoid obj-layout) :datum obj)) (t - (and (> (layout-depthoid obj-layout) depthoid) - (eq (svref (layout-inherits obj-layout) depthoid) - layout))))))) + (let ((depthoid (layout-depthoid layout))) + (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..") + (/nohexstr depthoid) + (/nohexstr layout-inherits) + (and (> (layout-depthoid obj-layout) depthoid) + (eq (svref (layout-inherits obj-layout) depthoid) + layout)))))))) -;;;; implementing structure slot accessors as closures - -;;; In the normal case of structures that have a real type (i.e. no -;;; :TYPE option was specified), we want to optimize things for space -;;; as well as speed, since there can be thousands of defined slot -;;; accessors. -;;; -;;; What we do is define the accessors and copier as closures over -;;; general-case code. Since the compiler will normally open-code -;;; accessors, the (minor) extra speed penalty for full calls is not a -;;; concern. -;;; -;;; KLUDGE: This is a minor headache at cold init time, since genesis -;;; doesn't know how to create the closures in the cold image, so the -;;; function definitions aren't done until the appropriate top level -;;; forms are executed, so any forward references to structure slots -;;; (which are compiled into full calls) fail. The headache can be -;;; treated by using SB!XC:DEFSTRUCT on the relevant structure at -;;; build-the-cross-compiler time, so that the compiler is born -;;; knowing how to inline accesses to the relevant structure, so no -;;; full calls are made. This can be achieved by calling -;;; SB!XC:DEFSTRUCT directly, or by using DEF!STRUCT, which (among -;;; other things) calls SB!XC:DEFSTRUCT for you. - -;;; Return closures to do slot access according to Layout and DSD. We check -;;; types, then do the access. This is only used for normal slots, not raw -;;; slots. -(defun structure-slot-getter (layout dsd) - (let ((class (layout-class layout))) - (if (typep class 'basic-structure-class) - #'(lambda (structure) - (declare (optimize (speed 3) (safety 0))) - (flet ((structure-test (structure) - (typep-to-layout structure layout))) - (unless (structure-test structure) - (error 'simple-type-error - :datum structure - ;; FIXME: :EXPECTED-TYPE should be something - ;; comprehensible to the user, not this. Perhaps we - ;; could work backwards from the LAYOUT-CLASS slot to - ;; find something. (Note that all four SIMPLE-TYPE-ERROR - ;; calls in this section have the same disease.) - :expected-type '(satisfies structure-test) - :format-control - "Structure for accessor ~S is not a ~S:~% ~S" - :format-arguments - (list (dsd-accessor dsd) - (sb!xc:class-name (layout-class layout)) - structure)))) - (%instance-ref structure (dsd-index dsd))) - #'(lambda (structure) - (declare (optimize (speed 3) (safety 0))) - (unless (%typep structure class) - (error 'simple-type-error - :datum structure - :expected-type 'class +;;;; checking structure types + +;;; Check that X is an instance of the named structure type. +(defmacro %check-structure-type-from-name (x name) + `(%check-structure-type-from-layout ,x ,(compiler-layout-or-lose name))) + +;;; Check that X is a structure of the type described by DD. +(defmacro %check-structure-type-from-dd (x dd) + (declare (type defstruct-description dd)) + (let ((class-name (dd-name dd))) + (ecase (dd-type dd) + ((structure funcallable-instance) + `(%check-structure-type-from-layout + ,x + ,(compiler-layout-or-lose class-name))) + ((vector) + (with-unique-names (xx) + `(let ((,xx ,x)) + (declare (type vector ,xx)) + ,@(when (dd-named dd) + `((unless (eql (aref ,xx 0) ',class-name) + (error + 'simple-type-error + :datum (aref ,xx 0) + :expected-type `(member ,class-name) :format-control - "The structure for accessor ~S is not a ~S:~% ~S" - :format-arguments - (list (dsd-accessor dsd) class - structure))) - (%instance-ref structure (dsd-index dsd)))))) -(defun structure-slot-setter (layout dsd) - (let ((class (layout-class layout))) - (if (typep class 'basic-structure-class) - #'(lambda (new-value structure) - (declare (optimize (speed 3) (safety 0))) - (flet ((structure-test (structure) - (typep-to-layout structure layout)) - (typep-test (new-value) - (%typep new-value (dsd-type dsd)))) - (unless (structure-test structure) - (error 'simple-type-error - :datum structure - :expected-type '(satisfies structure-test) - :format-control - "The structure for setter ~S is not a ~S:~% ~S" - :format-arguments - (list `(setf ,(dsd-accessor dsd)) - (sb!xc:class-name (layout-class layout)) - structure))) - (unless (typep-test new-value) - (error 'simple-type-error - :datum new-value - :expected-type '(satisfies typep-test) - :format-control - "The new value for setter ~S is not a ~S:~% ~S" - :format-arguments - (list `(setf ,(dsd-accessor dsd)) - (dsd-type dsd) - new-value)))) - (setf (%instance-ref structure (dsd-index dsd)) new-value)) - #'(lambda (new-value structure) - (declare (optimize (speed 3) (safety 0))) - (flet ((structure-test (structure) - (sb!xc:typep structure class)) - (typep-test (new-value) - (%typep new-value (dsd-type dsd)))) - (unless (structure-test structure) - (error 'simple-type-error - :datum structure - :expected-type '(satisfies structure-test) - :format-control - "The structure for setter ~S is not a ~S:~% ~S" - :format-arguments - (list `(setf ,(dsd-accessor dsd)) - (sb!xc:class-name class) - structure))) - (unless (typep-test new-value) - (error 'simple-type-error - :datum new-value - :expected-type '(satisfies typep-test) - :format-control - "The new value for setter ~S is not a ~S:~% ~S" - :format-arguments - (list `(setf ,(dsd-accessor dsd)) - (dsd-type dsd) - new-value)))) - (setf (%instance-ref structure (dsd-index dsd)) new-value))))) - + "~@" + :format-arguments (list ',class-name ,xx))))) + (values)))) + ((list) + (with-unique-names (xx) + `(let ((,xx ,x)) + (declare (type list ,xx)) + ,@(when (dd-named dd) + `((unless (eql (first ,xx) ',class-name) + (error + 'simple-type-error + :datum (aref ,xx 0) + :expected-type `(member ,class-name) + :format-control + "~@" + :format-arguments (list ',class-name ,xx))))) + (values))))))) + +;;; Check that X is an instance of the structure class with layout LAYOUT. +(defun %check-structure-type-from-layout (x layout) + (unless (typep-to-layout x layout) + (error 'type-error + :datum x + :expected-type (classoid-name (layout-classoid layout)))) + (values)) + (/show0 "target-defstruct.lisp end of file")