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