diff --git a/wh-engine/component.lisp b/wh-engine/component.lisp index b2405df..e508779 100644 --- a/wh-engine/component.lisp +++ b/wh-engine/component.lisp @@ -58,7 +58,8 @@ "Initialize or restore this component's state." (loop for slot in (sb-mop:class-slots (class-of this)) for slot-name = (sb-mop:slot-definition-name slot) - when (slot-boundp this slot-name) + when (and (eq (sb-mop:slot-definition-allocation slot) :instance) + (slot-boundp this slot-name)) do (let ((value (slot-value this slot-name))) (when (typep value id-ref) (setf (slot-value this slot-name) (resume-ptr value)))) diff --git a/wh-engine/package.lisp b/wh-engine/package.lisp index 16dc3d6..79012a4 100644 --- a/wh-engine/package.lisp +++ b/wh-engine/package.lisp @@ -23,6 +23,7 @@ pointer suspend-ptr resume-ptr suspend-setf resume-setf + generate-load-forms ;; actor.lisp actor diff --git a/wh-engine/serialization.lisp b/wh-engine/serialization.lisp index 2f253a8..e58dddd 100644 --- a/wh-engine/serialization.lisp +++ b/wh-engine/serialization.lisp @@ -36,6 +36,53 @@ (make-weak-pointer actor)) (make-weak-pointer scene)))) +(defun replace-in-tree (tree atom-fun) + (if (consp (car tree)) + (replace-in-tree (car tree) atom-fun) + (rplaca tree (funcall atom-fun (car tree)))) + (if (consp (cdr tree)) + (replace-in-tree (cdr tree) atom-fun) + (rplacd tree (funcall atom-fun (cdr tree)))) + tree) + +(defun process-load-forms (obj table) + (multiple-value-bind (cons-form init-form) + (make-load-form obj) + (let ((sym (gensym)) + (output-cons-forms ()) + (output-init-forms ())) + (setf (gethash obj table) (cons sym cons-form)) + (replace-in-tree init-form (lambda (x) + (cond + ; x has already been processed + ((gethash x table) + (car (gethash x table))) + ; x needs to be run through process-load-forms + ((typep x '(or standard-object structure-object condition class)) + (multiple-value-bind (x-cons-forms x-init-forms x-sym) + (process-load-forms x table) + (setf output-cons-forms (nconc output-cons-forms x-cons-forms)) + (setf output-init-forms (nconc output-init-forms x-init-forms)) + x-sym)) + ; x is a type that doesn't need processing + (t x)))) + (setf output-cons-forms (nconc output-cons-forms `((,sym ,cons-form)))) + (setf output-init-forms (nconc output-init-forms `(,init-form))) + (values output-cons-forms output-init-forms sym)))) + +(defun generate-load-forms (obj) + (multiple-value-bind (cons-forms init-forms sym) + (process-load-forms obj (make-hash-table :test #'eq)) + `(let ,cons-forms + ,@init-forms + ,sym))) + +(defun serialize-instance (obj) + "Serialize obj into a Lisp expression that evaluates back to it." + (let ((obj-sym (gensym)) forms) + (setf forms `(let ((,obj-sym (make-instance ',(class-name (class-of obj))))))) + )) + (defmacro suspend-setf (place) `(when (typep ,place 'weak-pointer) (setf ,place (suspend-ptr ,place))))