Rough serialization of classes to S-expressions (for #3)

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))))

wh-engine/package.lisp

@@ -23,6 +23,7 @@
    pointer
    suspend-ptr resume-ptr
    suspend-setf resume-setf
+   generate-load-forms
 
    ;; actor.lisp
    actor

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))))