X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=0e5742f9f7884f05932f051300a86e4adf9b4650;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=c463637a21326039e7f2b90e5f311706216e14b5;hpb=9719063b661a99d2cc2a1d9b2ea7dd81145ded59;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index c463637..0e5742f 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -31,57 +31,68 @@ (defun %instance-set (instance index new-value) (setf (%instance-ref instance index) new-value)) -(defun %raw-ref-single (vec index) +;;; Normally IR2 converted, definition needed for interpreted structure +;;; constructors only. +#!+sb-eval +(defun %make-structure-instance (dd slot-specs &rest slot-values) + (let ((instance (%make-instance (dd-instance-length dd)))) + (setf (%instance-layout instance) (dd-layout-or-lose dd)) + (mapc (lambda (spec value) + (destructuring-bind (raw-type . index) (cdr spec) + (macrolet ((make-case () + `(ecase raw-type + ((t) + (setf (%instance-ref instance index) value)) + ,@(mapcar + (lambda (rsd) + `(,(raw-slot-data-raw-type rsd) + (setf (,(raw-slot-data-accessor-name rsd) + instance index) + value))) + *raw-slot-data-list*)))) + (make-case)))) + slot-specs slot-values) + instance)) + +(defun %raw-instance-ref/word (instance index) (declare (type index index)) - (%raw-ref-single vec 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-ref-double (vec index) +(defun %raw-instance-ref/single (instance index) (declare (type index index)) - (%raw-ref-double vec 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)) -#!+long-float -(defun %raw-ref-long (vec index) +(defun %raw-instance-ref/double (instance index) (declare (type index index)) - (%raw-ref-long vec 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-set-single (vec index val) +(defun %raw-instance-ref/complex-single (instance index) (declare (type index index)) - (%raw-set-single vec index val)) + (%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-set-double (vec index val) +(defun %raw-instance-ref/complex-double (instance index) (declare (type index index)) - (%raw-set-double vec index val)) - -#!+long-float -(defun %raw-set-long (vec index val) - (declare (type index index)) - (%raw-set-long vec index val)) - -(defun %raw-ref-complex-single (vec index) - (declare (type index index)) - (%raw-ref-complex-single vec index)) - -(defun %raw-ref-complex-double (vec index) - (declare (type index index)) - (%raw-ref-complex-double vec index)) - -#!+long-float -(defun %raw-ref-complex-long (vec index) - (declare (type index index)) - (%raw-ref-complex-long vec index)) - -(defun %raw-set-complex-single (vec index val) - (declare (type index index)) - (%raw-set-complex-single vec index val)) - -(defun %raw-set-complex-double (vec index val) - (declare (type index index)) - (%raw-set-complex-double vec index val)) - -#!+long-float -(defun %raw-set-complex-long (vec index val) - (declare (type index index)) - (%raw-set-complex-long vec index val)) + (%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)) (defun %instance-layout (instance) (%instance-layout instance)) @@ -89,10 +100,14 @@ (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)) -(defun funcallable-instance-p (x) (funcallable-instance-p x)) +(deftype funcallable-instance () + `(satisfies funcallable-instance-p)) (defun %funcallable-instance-info (fin i) (%funcallable-instance-info fin i)) @@ -101,44 +116,10 @@ (%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))) - -;;; service function for structure constructors -(defun %make-instance-with-layout (layout) - (let ((result (%make-instance (layout-length layout)))) - (setf (%instance-layout result) layout) - result)) + (setf (%funcallable-instance-function fin) new-value)) ;;;; target-only parts of the DEFSTRUCT top level code @@ -151,13 +132,43 @@ (/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)) +(defun make-defstruct-predicate (dd layout) + (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,") + (/noshow0 " 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))) + +(defun make-defstruct-copier (dd layout) + (ecase (dd-type dd) + (structure + #'(lambda (instance) + (%check-structure-type-from-layout instance layout) + (copy-structure instance))))) + ;;; 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 @@ -183,20 +194,20 @@ (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)))))) + (/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) @@ -207,44 +218,24 @@ ;; (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)) + (make-defstruct-copier dd layout))) ;; 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)))) + (make-defstruct-predicate dd layout))) (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)) @@ -255,6 +246,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) @@ -266,206 +260,239 @@ ;; 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) #!+sb-doc "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))) + (let* ((layout (%instance-layout structure)) + (res (%make-instance (%instance-length structure))) + (len (layout-length layout)) + (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) + ;; Copy ordinary slots and layout. + (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)) + + + +;; Do an EQUALP comparison on the raw slots (only, not the normal slots) of a +;; structure. +(defun raw-instance-slots-equalp (layout x y) + ;; This implementation sucks, but hopefully EQUALP on raw structures + ;; won't be a major bottleneck for anyone. It'd be tempting to do + ;; all this with %RAW-INSTANCE-REF/WORD and bitwise comparisons, but + ;; that'll fail in some cases. For example -0.0 and 0.0 are EQUALP + ;; but have different bit patterns. -- JES, 2007-08-21 + (loop for dsd in (dd-slots (layout-info layout)) + for raw-type = (dsd-raw-type dsd) + for rsd = (unless (eql raw-type t) + (find raw-type + *raw-slot-data-list* + :key 'raw-slot-data-raw-type)) + always (or (not rsd) + (funcall (raw-slot-data-comparer rsd) (dsd-index dsd) x y)))) ;;; default PRINT-OBJECT method +(defun %print-structure-sans-layout-info (name stream) + ;; KLUDGE: during PCL build debugging, we can sometimes + ;; attempt to print out a PCL object (with null LAYOUT-INFO). + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)" stream))) + +(defun %print-structure-sans-slots (name stream) + ;; 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 + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream)) + (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 (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)))))))) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) + (cond ((not dd) + (%print-structure-sans-layout-info name stream)) + ((not (dd-slots dd)) + (%print-structure-sans-slots name stream)) + (t + (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 (dsd-%name slot) stream) - (write-char #\space stream) - (output-object - (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream)))))) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) + (cond ((not dd) + (%print-structure-sans-layout-info name stream)) + ((not (dd-slots dd)) + (%print-structure-sans-slots name stream)) + (t + (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-string " :" 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*)) @@ -488,30 +515,25 @@ (/nohexstr obj) (/nohexstr layout) (when (layout-invalid layout) - (error "An obsolete structure accessor function was called.")) + (error "An obsolete structure typecheck 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-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)))))))) + (when (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") + (return-from typep-to-layout t)) + (when (layout-invalid obj-layout) + (/noshow0 "LAYOUT-INVALID case") + (setf obj-layout (update-object-layout-or-invalid obj 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)))))) ;;;; checking structure types @@ -526,45 +548,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) (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 - "~@" - :format-arguments (list ',class-name ,xx))))) - (values)))) + :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))))))) + :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)))) + :datum x + :expected-type (classoid-name (layout-classoid layout)))) (values)) + (/show0 "target-defstruct.lisp end of file")