From f2251d1bc288f63de22aa873e486c00beed08a7c Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Fri, 21 Sep 2001 12:00:43 +0000
Subject: [PATCH] Second attempt at using new cvs server. Hopefully mail system
 config problems are fixed now.

This revision fixes an omission from a previous rev that added support
for :print-object and :print-function defstruct options. The default
method created was calling DEFAULT-STRUCTURE-PRINT with only two
arguments. It seems to work correctly now.
---
 code/defstruct.lisp | 19 +++++++++----------
 1 file changed, 9 insertions(+), 10 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 0bc314460..a7bf41ee1 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.73 2001/03/15 18:01:36 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.74 2001/09/21 12:00:43 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -328,7 +328,6 @@
   (declare (ignore depth))
   (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
 
-
 (defun dd-maybe-make-print-method (defstruct)
   ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.
   (let ((print-function-value (dd-print-function defstruct)))
@@ -337,17 +336,17 @@
 	    (function (cdr print-function-value)))
 	(unless (eq kind 'lambda)
 	  (setf (dd-print-function defstruct) nil)
-	  (let* ((name (dd-name defstruct))
-		 (function (if (symbolp function) `',function `#',function))
-		 (mcall `(funcall ,function o s))
-		 (fcall `(funcall ,function o s *current-level*)))
+	  (let* ((class (dd-name defstruct))
+		 (func (if (symbolp function) `',function `#',function)))
 	    ;; We can only generate this code if CLOS is loaded. Maybe should
 	    ;; signal an error instead of quietly ignoring the defmethod?
 	    `((when (fboundp 'print-object)
-		(defmethod print-object ((o ,name) s)
-		  ,(ecase kind
-		     (:print-object mcall)
-		     (:print-function fcall)))))))))))
+		(defmethod print-object ((object ,class) stream)
+		  (funcall
+		   ,func object stream
+		   ,@(when (or (eq kind :print-function)
+			       (eq function 'default-structure-print))
+		       '(*current-level*))))))))))))
 
 
 ;;; The legendary macro itself.
-- 
GitLab