From dfb7784b7c6812d65b89bda5a4b8c0af93b2d33c Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 14 Dec 1991 08:56:10 +0000
Subject: [PATCH] Added make-load-form support.  Changed the pretty printer to
 not indent quite as much.

---
 code/defstruct.lisp | 59 ++++++++++++++++++++++++++++++---------------
 1 file changed, 40 insertions(+), 19 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index a8f4f0e6c..94e77e3c7 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.28 1991/12/05 06:25:25 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.29 1991/12/14 08:56:10 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -75,12 +75,6 @@
 
 ;;; The legendary macro itself.
 
-;;; ### Bootstrap hack...
-;;; Install this definition only into the new compiler's environment so that we
-;;; don't break the bootstrap environment.
-;;;
-(compiler-let ((lisp::*bootstrap-defmacro* t))
-
 (defmacro defstruct (name-and-options &rest slot-descriptions)
   "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
   Define the structure type Name.  See the manual for details."
@@ -102,6 +96,12 @@
 			 ,(if (symbolp pf)
 			      `',pf
 			      `#',pf)))))
+	   ,@(let ((mlff (dd-make-load-form-fun defstruct)))
+	       (when mlff
+		 `((setf (info type load-form-maker ',name)
+			 ,(if (symbolp mlff)
+			      `',mlff
+			      `#',mlff)))))
 	   ',name)
 	`(progn
 	   (eval-when (compile load eval)
@@ -113,8 +113,6 @@
 	   ,@(define-accessors defstruct)
 	   ,@(define-copier defstruct)
 	   ',name))))
-
-); Compiler-Let
 	   
 
 ;;;; Parsing:
@@ -136,7 +134,9 @@
 	(saw-type)
 	(type 'structure)
 	(saw-named)
-	(offset 0))
+	(offset 0)
+	(make-load-form-fun nil)
+	(make-load-form-fun-p nil))
        ((null options)
 	(make-defstruct-description
 	 :name name
@@ -158,7 +158,8 @@
 			   (cons 'simple-array (cdr type)))
 			  (t (error "~S is a bad :TYPE for Defstruct." type)))
 	 :named (if saw-type saw-named t)
-	 :offset offset))
+	 :offset offset
+	 :make-load-form-fun make-load-form-fun))
     (if (atom (car options))
 	(case (car options)
 	  (:constructor
@@ -197,22 +198,26 @@
 	     (setf include args)
 	     (let* ((name (car include))
 		    (included-structure
-		     (info type structure-info name))
-		    (included-print-function
-		     (if included-structure
-			 (dd-print-function included-structure))))
+		     (info type structure-info name)))
 	       (unless included-structure
 		 (error "Cannot find description of structure ~S to use for ~
 		         inclusion."
 			name))
 	       (unless pf-supplied-p
-		 (setf print-function included-print-function))))
+		 (setf print-function
+		       (dd-print-function included-structure)))
+	       (unless make-load-form-fun-p
+		 (setf make-load-form-fun
+		       (dd-make-load-form-fun included-structure)))))
 	    (:print-function
 	     (setf print-function (car args))
 	     (setf pf-supplied-p t))
 	    (:type (setf saw-type t type (car args)))
 	    (:named (error "The Defstruct option :NAMED takes no arguments."))
 	    (:initial-offset (setf offset (car args)))
+	    (:make-load-form-fun
+	     (setf make-load-form-fun (car args))
+	     (setf make-load-form-fun-p t))
 	    (t (error "~S is an unknown Defstruct option." option)))))))
 
 
@@ -669,13 +674,14 @@
   (let* ((type (structure-ref structure 0))
 	 (dd (info type defined-structure-info type)))
     (cond (*print-pretty*
-	   (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
+	   (pprint-logical-block (stream structure :allow-atoms t
+					 :prefix "#S(" :suffix ")")
 	     (prin1 type stream)
 	     (let ((slots (dd-slots dd)))
 	       (when slots
 		 (write-char #\space stream)
-		 (pprint-indent :current 0 stream)
-		 (pprint-newline :miser stream)
+		 (pprint-indent :block 2 stream)
+		 (pprint-newline :linear stream)
 		 (loop
 		   (pprint-pop)
 		   (let ((slot (pop slots)))
@@ -705,3 +711,18 @@
 	     (output-object (dsd-name (car slots)) stream)
 	     (write-char #\space stream)
 	     (output-object (structure-ref structure index) stream))))))
+
+
+(defun make-structure-load-form (structure)
+  (declare (type structure structure))
+  (let* ((type (structure-ref structure 0))
+	 (fun (info type load-form-maker type)))
+    (etypecase fun
+      ((member :just-dump-it-normally :ignore-it)
+       fun)
+      (null
+       (error "Structures of type ~S cannot be dumped as constants." type))
+      (function
+       (funcall fun structure))
+      (symbol
+       (funcall (symbol-function fun) structure)))))
-- 
GitLab