X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=f179459a85bd96ef77485f38bf886efa4146adca;hb=9b1fade83db8453b75b8c7380eb12ce41b5b889c;hp=810ebce8e2e20aac65129ace8cf3fa6f633a8d56;hpb=b9e94e326f79ab01e56cb437e424ce5ea489471f;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 810ebce..f179459 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -417,84 +417,113 @@ (%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 with i = -1 + for dsd in (dd-slots (layout-info layout)) + for raw-type = (dsd-raw-type dsd) + for rsd = (when raw-type + (find raw-type + *raw-slot-data-list* + :key 'raw-slot-data-raw-type)) + for accessor = (when rsd + (raw-slot-data-accessor-name rsd)) + always (or (not accessor) + (progn + (incf i) + (equalp (funcall accessor x i) + (funcall accessor y i)))))) ;;; 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)) - ;; 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 (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)))))))) + (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))) - (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 (symbol-name (dsd-name slot)) stream) - (write-char #\space stream) - (output-object - (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream)))))) + (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) @@ -503,6 +532,7 @@ (%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*)) @@ -601,5 +631,6 @@ :datum x :expected-type (classoid-name (layout-classoid layout)))) (values)) + (/show0 "target-defstruct.lisp end of file")