X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=ef0761face226e618efccabb8f2e124a4e80eced;hb=ea3a2433c72ee97c5691c29d882a63e4d86f0a32;hp=4d6f1cb37bcfac28bac579a68a35f6cfdb30b175;hpb=c713eb2b521b048ff2c927ec52b861787d289f85;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 4d6f1cb..ef0761f 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -31,6 +31,60 @@ (defun %instance-set (instance index new-value) (setf (%instance-ref instance index) new-value)) +(defun %instance-compare-and-swap (instance index old new) + #!+(or x86 x86-64) + (%instance-compare-and-swap instance index old new) + #!-(or x86 x86-64) + (let ((n-old (%instance-ref instance index))) + (when (eq old n-old) + (%instance-set instance index new)) + n-old)) + +#!-hppa +(progn + (defun %raw-instance-ref/word (instance index) + (declare (type index index)) + (%raw-instance-ref/word instance index)) + (defun %raw-instance-set/word (instance index new-value) + (declare (type index index) + (type sb!vm:word new-value)) + (%raw-instance-set/word instance index new-value)) + + (defun %raw-instance-ref/single (instance index) + (declare (type index index)) + (%raw-instance-ref/single instance index)) + (defun %raw-instance-set/single (instance index new-value) + (declare (type index index) + (type single-float new-value)) + (%raw-instance-set/single instance index new-value)) + + (defun %raw-instance-ref/double (instance index) + (declare (type index index)) + (%raw-instance-ref/double instance index)) + (defun %raw-instance-set/double (instance index new-value) + (declare (type index index) + (type double-float new-value)) + (%raw-instance-set/double instance index new-value)) + + (defun %raw-instance-ref/complex-single (instance index) + (declare (type index index)) + (%raw-instance-ref/complex-single instance index)) + (defun %raw-instance-set/complex-single (instance index new-value) + (declare (type index index) + (type (complex single-float) new-value)) + (%raw-instance-set/complex-single instance index new-value)) + + (defun %raw-instance-ref/complex-double (instance index) + (declare (type index index)) + (%raw-instance-ref/complex-double instance index)) + (defun %raw-instance-set/complex-double (instance index new-value) + (declare (type index index) + (type (complex double-float) new-value)) + (%raw-instance-set/complex-double instance index new-value)) +) ; #!-HPPA + +#!+hppa +(progn (defun %raw-ref-single (vec index) (declare (type index index)) (%raw-ref-single vec index)) @@ -82,6 +136,7 @@ (defun %raw-set-complex-long (vec index val) (declare (type index index)) (%raw-set-complex-long vec index val)) +) ; #!+HPPA (defun %instance-layout (instance) (%instance-layout instance)) @@ -89,8 +144,8 @@ (defun %set-instance-layout (instance new-value) (%set-instance-layout instance new-value)) -(defun %make-funcallable-instance (len layout) - (%make-funcallable-instance len layout)) +(defun %make-funcallable-instance (len) + (%make-funcallable-instance len)) (defun funcallable-instance-p (x) (funcallable-instance-p x)) @@ -101,56 +156,39 @@ (%set-funcallable-instance-info fin i new-value)) (defun funcallable-instance-fun (fin) - (%funcallable-instance-lexenv fin)) - -;;; The heart of the magic of funcallable instances ("FINs"). The -;;; function for a FIN must be a magical INSTANCE-LAMBDA form. When -;;; called (as with any other function), we grab the code pointer, and -;;; call it, leaving the original function object in LEXENV (in case -;;; it was a closure). If it is actually a FIN, then we need to do an -;;; extra indirection with funcallable-instance-lexenv to get at any -;;; closure environment. This extra indirection is set up when -;;; accessing the closure environment of an INSTANCE-LAMBDA. Note that -;;; the original FIN pointer is lost, so if the called function wants -;;; to get at the original object to do some slot accesses, it must -;;; close over the FIN object. -;;; -;;; If we set the FIN function to be a FIN, we directly copy across -;;; 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. (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-FUN, then won't get a FIN back. This probably -;;; doesn't matter, since PCL only sets the FIN function. + (%funcallable-instance-function fin)) + (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))) + (setf (%funcallable-instance-function fin) new-value)) ;;; service function for structure constructors (defun %make-instance-with-layout (layout) - (let ((result (%make-instance (layout-length layout)))) + ;; Make sure the object ends at a two-word boundary. Note that this does + ;; not affect the amount of memory used, since the allocator would add the + ;; same padding anyway. However, raw slots are indexed from the length of + ;; the object as indicated in the header, so the pad word needs to be + ;; included in that length to guarantee proper alignment of raw double float + ;; slots, necessary for (at least) the SPARC backend. + (let* ((length (layout-length layout)) + (result (%make-instance (+ length (mod (1+ length) 2))))) (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*)) + (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)) + "attempting to modify a symbol in the COMMON-LISP package: ~S" + symbol)) (/show0 "leaving PROTECT-CL") (values)) @@ -177,19 +215,22 @@ (dolist (dsd (dd-slots dd)) (/show0 "doing FDEFINITION for slot accessor") (let ((accessor-name (dsd-accessor-name dsd))) - (/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))))) + ;; 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) @@ -200,37 +241,43 @@ ;; (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)) + ;; 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) - (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)))) + (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))) + (setf (fdocumentation (dd-name dd) 'structure) + (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)) @@ -242,6 +289,9 @@ ;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler ;;; thing, putting in the type checks unconditionally.) +;;; KLUDGE: Why use this closure approach at all? The macrology in +;;; SLOT-ACCESSOR-FUNS seems to be half stub, half OAOOM to me. --DFL + ;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN). (defun slot-accessor-funs (dd dsd) @@ -253,102 +303,101 @@ ;; 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)))))) + ;; 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))) + `((equal dsd-raw-type ',raw-type) + #+sb-xc (/show0 "in raw slot case") + (%slotplace-accessor-funs + (,accessor-name instance 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) + `(let ((typecheckfun (typespec-typecheckfun dsd-type))) + (values (if (dsd-safe-p dsd) + (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + ,slotplace) + (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + (let ((value ,slotplace)) + (funcall typecheckfun value) + value))) + (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))) - + (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 + ;; 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.. - #| + ;; 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)) + `(%check-structure-type-from-dd + :maybe-raw-p nil)) (vector (dd-type-slot-accessor-funs aref - :maybe-raw-p nil))) + :maybe-raw-p nil))) |# - )))) + )))) ;;; Copy any old kind of structure. (defun copy-structure (structure) @@ -356,102 +405,115 @@ "Return a copy of STRUCTURE with the same (EQL) slot values." (declare (type structure-object structure)) (let* ((len (%instance-length structure)) - (res (%make-instance len)) - (layout (%instance-layout structure))) + (res (%make-instance len)) + (layout (%instance-layout structure)) + (nuntagged (layout-n-untagged-slots layout))) (declare (type index len)) (when (layout-invalid layout) (error "attempt to copy an obsolete structure:~% ~S" structure)) ;; Copy ordinary slots. - (dotimes (i len) + (dotimes (i (- len nuntagged)) (declare (type index i)) (setf (%instance-ref res i) - (%instance-ref structure i))) + (%instance-ref structure i))) ;; Copy raw slots. - (let ((raw-index (dd-raw-index (layout-info layout)))) - (when raw-index - (let* ((data (%instance-ref structure raw-index)) - (raw-len (length data)) - (new (make-array raw-len :element-type '(unsigned-byte 32)))) - (declare (type (simple-array (unsigned-byte 32) (*)) data)) - (setf (%instance-ref res raw-index) new) - (dotimes (i raw-len) - (setf (aref new i) (aref data i)))))) + (dotimes (i nuntagged) + (declare (type index i)) + (setf (%raw-instance-ref/word res i) + (%raw-instance-ref/word structure i))) res)) -;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods +;;; default PRINT-OBJECT method (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) - (dd (layout-info layout))) + (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)) + ;; the structure type doesn't count as a component for + ;; *PRINT-LEVEL* processing. We can likewise elide the logical + ;; block processing, since all we have to print is the type name. + ;; -- CSR, 2004-10-05 + (when (and dd (null (dd-slots dd))) + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream) + (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 (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)))))))) + (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 (sb!xc:class-name (layout-class layout))) - (dd (layout-info layout))) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) + (when (and dd (null (dd-slots dd))) + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream) + (return-from %default-structure-ugly-print nil)) (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 (dsd-%name slot) stream) - (write-char #\space stream) - (output-object - (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream)))))) + (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)) (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)))) + (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-in-print*)) - -(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)) ;;;; testing structure types @@ -474,28 +536,26 @@ (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) + (and (%instancep 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) - ((layout-invalid obj-layout) - (/noshow0 "LAYOUT-INVALID case") - (error 'layout-invalid - :expected-type (layout-class obj-layout) - :datum obj)) - (t - (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)))))))) + (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) + ((layout-invalid obj-layout) + (/noshow0 "LAYOUT-INVALID case") + (error 'layout-invalid + :expected-type (layout-classoid obj-layout) + :datum obj)) + (t + (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)))))))) ;;;; checking structure types @@ -510,45 +570,46 @@ (ecase (dd-type dd) ((structure funcallable-instance) `(%check-structure-type-from-layout - ,x - ,(compiler-layout-or-lose class-name))) + ,x + ,(compiler-layout-or-lose class-name))) ((vector) - (let ((xx (gensym "X"))) - `(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 - "~@" - :format-arguments (list ',class-name ,xx))))) - (values)))) + :format-arguments (list ',class-name ,xx))))) + (values)))) ((list) - (let ((xx (gensym "X"))) - `(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))))))) + :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 (class-name (layout-class layout)))) + :datum x + :expected-type (classoid-name (layout-classoid layout)))) (values)) + (/show0 "target-defstruct.lisp end of file")