From: Christophe R. <cr...@us...> - 2003-05-19 14:05:51
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1:/tmp/cvs-serv11709/src/pcl Modified Files: env.lisp Log Message: 0.8alpha.0.37: Make MAKE-LOAD-FORM(-SAVING-SLOTS) vaguely conform ... and in the process, remind myself of just how horrible the :JUST-DUMP-IT-NORMALLY hack was. ... more methods on MAKE-LOAD-FORM; ... real, CLOS-based introspective definition of MAKE-LOAD-FORM-SAVING-SLOTS... ... which means that we have to hold off from using MLFSS until it's around, so make JUST-DUMP-IT-NORMALLY use :SB-JUST-DUMP-IT-NORMALLY rather than MLFSS in its definition for the target. Fix the type.impure.lisp test for the new definition of condition classes (oops). Index: env.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/env.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- env.lisp 24 Mar 2003 18:39:09 -0000 1.9 +++ env.lisp 19 May 2003 14:05:18 -0000 1.10 @@ -132,3 +132,33 @@ (layout-classoid object))) `(classoid-layout (find-classoid ',pname)))) +(defmethod make-load-form ((object structure-object) &optional env) + (declare (ignore env)) + (error "~@<don't know how to dump ~S (default ~S method called).~@>" + object 'make-load-form)) + +(defmethod make-load-form ((object standard-object) &optional env) + (declare (ignore env)) + (error "~@<don't know how to dump ~S (default ~S method called).~@>" + object 'make-load-form)) + +(defmethod make-load-form ((object condition) &optional env) + (declare (ignore env)) + (error "~@<don't know how to dump ~S (default ~S method called).~@>" + object 'make-load-form)) + +(defun make-load-form-saving-slots (object &key slot-names environment) + (declare (ignore environment)) + (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)))))) |