From 20f739827c4f3d6a46feef268eaa43e6ea2cabc8 Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Mon, 20 Sep 1999 11:12:59 +0000
Subject: [PATCH] DEFAULT-STRUCTURE-PRINT was puking on certain cases of
 structures that included other defstructs. An example of a failing case is:

(defstruct a1 s1)
(defstruct (a2 (:include a1)(:conc-name a1-)) s2)

as seen in Hemlock source. The problem was that the dsd-accessor slot
is documented to sometimes contain NIL but default-structure-print
blindly called fdefinition on the sometimes NIL value. The fix here
is to compute the slot accessor name from the conc-name and slot-name.

NOTE: There is code in ir1tran that also blindly calls fdefinition
on the contents of dsd-accessor. Don't know if this is a latent bug.
---
 code/defstruct.lisp | 87 ++++++++++++++++++++++++---------------------
 1 file changed, 46 insertions(+), 41 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 3555b240f..ab8676810 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.66 1998/12/19 15:56:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.67 1999/09/20 11:12:59 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1619,47 +1619,52 @@
       (let* ((type (%instance-layout structure))
 	     (name (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
+	(flet ((slot-accessor (slot)
+		 (let ((aname
+			(intern (concatenate
+				 'simple-string
+				 (symbol-name (kernel::dd-conc-name dd))
+				 (dsd-%name slot)))))
+		   (fdefinition aname))))
+	  (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)
+		    (pprint-indent :block 2 stream)
+		    (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 (slot-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*)(eql *print-length* index)))
+		     (if (null slots)
+			 (write-string ")" stream)
+			 (write-string " ...)" stream)))
+		  (declare (type index index))
 		  (write-char #\space stream)
-		  (pprint-indent :block 2 stream)
-		  (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*) (eql *print-length* index)))
-		   (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))))))))
+		  (write-char #\: stream)
+		  (let ((slot (first slots)))
+		    (output-symbol-name (dsd-%name slot) stream)
+		    (write-char #\space stream)
+		    (output-object
+		     (funcall (slot-accessor slot) structure) stream)))))))))
 
 (defun make-structure-load-form (structure)
   (declare (type structure-object structure))
-- 
GitLab