diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index 9e92a15d4f8c3f1428a050ebd956d9fcff7d881c..9ae69c38d9a2275aff519c9107b6d5aa1cfc598c 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 4ad93356f12fe9baa758bacf6051f065dde4765e..95a83dd2c71dcac4f766d941e3e089d917b5e6c5 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))))))