X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=bad8d9554e6265b4a97a2e442a0cfa751c8b13bc;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=87aab71c961ae8850a9ebc576cf267c70274702c;hpb=00c93ebddb9224ae6d554fa010d3c19ddbf401d9;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 87aab71..bad8d95 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -395,12 +395,21 @@ 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 (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))) @@ -413,7 +422,7 @@ (pprint-pop) (let ((slot (pop remaining-slots))) (write-char #\: stream) - (output-symbol-name (dsd-%name slot) 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)) @@ -443,7 +452,7 @@ (write-char #\space stream) (write-char #\: stream) (let ((slot (first remaining-slots))) - (output-symbol-name (dsd-%name slot) stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) (write-char #\space stream) (output-object (funcall (fdefinition (dsd-accessor-name slot)) @@ -459,12 +468,6 @@ (%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 - :sb-just-dump-it-normally)) ;;;; testing structure types @@ -526,7 +529,7 @@ ,x ,(compiler-layout-or-lose class-name))) ((vector) - (let ((xx (gensym "X"))) + (with-unique-names (xx) `(let ((,xx ,x)) (declare (type vector ,xx)) ,@(when (dd-named dd) @@ -541,7 +544,7 @@ :format-arguments (list ',class-name ,xx))))) (values)))) ((list) - (let ((xx (gensym "X"))) + (with-unique-names (xx) `(let ((,xx ,x)) (declare (type list ,xx)) ,@(when (dd-named dd)