From f19e1ba08e5e582df824944954ed521a76e083f2 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sat, 17 May 2003 19:02:37 +0000
Subject: [PATCH] 	Bogus MAKE-LOAD-FORM-SAVING-SLOTS detected by Paul
 Dietz.

	* src/pcl/env.lisp (make-load-form-saving-slots): Rewritten.
---
 general-info/release-19a.txt |  4 ++++
 pcl/env.lisp                 | 23 +++++++++++++++++------
 2 files changed, 21 insertions(+), 6 deletions(-)

diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index 9e92a15d4..9ae69c38d 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -77,6 +77,10 @@ New in this release:
      - VALUES types no longer accepting &KEY or &ALLOW-OTHER-KEYS.
      - THE conforming to ANSI.
      - SLOT-EXISTS-P can be used with conditions.
+     - REMOVE-METHOD always returning the generic function passed to it.
+     - Standard methods for STANDARD-OBJECT and STRUCTURE-OBJECT
+       defined on MAKE-LOAD-FORM.
+     - Compliant MAKE-LOAD-FORM-SAVING-SLOTS.
 
   * Numerous bugfixes:
      - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR
diff --git a/pcl/env.lisp b/pcl/env.lisp
index 4ad93356f..95a83dd2c 100644
--- a/pcl/env.lisp
+++ b/pcl/env.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.22 2003/05/17 16:20:36 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.23 2003/05/17 19:02:37 gerd Exp $")
 ;;;
 ;;; Basic environmental stuff.
 ;;;
@@ -303,11 +303,22 @@
       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 	     class))
     `(find-class ',name)))
-  
+
+(defgeneric make-load-form-saving-slots (object &key slot-names environment))
+
 (defun make-load-form-saving-slots (object &key slot-names environment)
   (declare (ignore environment))
-  (when slot-names
-    (warn "~@<~s ~s option not implemented, dumping all slots: ~S~@:>"
-	  :slot-names 'make-load-form object))
-  :just-dump-it-normally)
+  (let ((class (class-of object)))
+    (collect ((inits))
+      (dolist (slot (class-slots class))
+	(let ((slot-name (slot-definition-name slot)))
+	  (when (or (memq slot-name slot-names)
+		    (and (null slot-names)
+			 (eq :instance (slot-definition-allocation slot))))
+	    (if (slot-boundp-using-class class object slot)
+		(let ((value (slot-value-using-class class object slot)))
+		  (inits `(setf (slot-value ,object ',slot-name) ',value)))
+		(inits `(slot-makunbound ,object ',slot-name))))))
+      (values `(allocate-instance (find-class ',(class-name class)))
+	      `(progn .,(inits))))))
 
-- 
GitLab