Fix issue with (process-load-forms) overwriting slot values, error checking on (referize) and (pointerize) (for #3)

wh-engine/actor.lisp

@@ -72,6 +72,9 @@
            :initform (meye 3)))
   (:documentation "Base class for entities in the game."))
 
+(defmethod make-load-form ((this actor) &optional environment)
+  (make-load-form-saving-slots this :environment environment))
+
 (defmethod scene ((this actor))
   "The scene containing this actor."
   (deref-pointer [this :slot scene]))
@@ -185,11 +188,11 @@
 (defmethod resume ((this actor))
   "Initialize or restore this actor's state."
   ; Restore self
-  (resume-setf [this :slot scene])
+  (pointerize-setf [this :slot scene])
-  (resume-setf [this :slot parent])
+  (pointerize-setf [this :slot parent])
   (loop for entry on [this :slot children]
         when (typep (car entry) 'id-ref)
-          do (rplaca entry (resume-ptr (car entry))))
+          do (rplaca entry (pointerize (car entry))))
   ; Restore components
   (loop for component in [this components]
         do [component (resume)]))
@@ -202,9 +205,9 @@
   ; Suspend self
   (loop for entry on [this :slot children]
         when (typep (car entry) 'weak-pointer)
-          do (rplaca entry (suspend-ptr (car entry))))
+          do (rplaca entry (referize (car entry))))
-  (suspend-setf [this :slot scene])
+  (referize-setf [this :slot scene])
-  (suspend-setf [this :slot parent]))
+  (referize-setf [this :slot parent]))
 
 (defmethod update ((this actor))
   "Update this actor's components."

wh-engine/component.lisp

@@ -17,6 +17,9 @@
               :initform nil))
   (:documentation "Base class for components attached to game entities."))
 
+(defmethod make-load-form ((this component) &optional environment)
+  (make-load-form-saving-slots this :environment environment))
+
 (defmethod actor ((this component))
   "The actor this component belongs to."
   (deref-pointer [this :slot actor]))
@@ -61,8 +64,8 @@
         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)
+               (when (typep value 'id-ref)
-                 (setf (slot-value this slot-name) (resume-ptr value))))
+                 (setf (slot-value this slot-name) (pointerize value))))
         ))
 
 (defmethod suspend ((this component))
@@ -71,8 +74,8 @@
         for slot-name = (sb-mop:slot-definition-name slot)
         when (slot-boundp this slot-name)
           do (let ((value (slot-value this slot-name)))
-               (when (typep value weak-pointer)
+               (when (typep value 'weak-pointer)
-                 (setf (slot-value this slot-name) (suspend-ptr value))))
+                 (setf (slot-value this slot-name) (referize value))))
         ))
 
 (defmethod start ((this component))

wh-engine/package.lisp

@@ -21,8 +21,8 @@
    ;; serialization.lisp
    id-ref make-id-ref
    pointer
-   suspend-ptr resume-ptr
+   referize pointerize
-   suspend-setf resume-setf
+   referize-setf pointerize-setf
    generate-load-forms
 
    ;; actor.lisp
@@ -70,6 +70,7 @@
    get-actor get-tagged-actors
    update
    destroy
+   resume suspend
 
    ;; render/drawable.lisp
    drawable

wh-engine/scene.lisp

@@ -22,6 +22,9 @@
                 :initform nil))
   (:documentation "A scene containing game entities."))
 
+(defmethod make-load-form ((this scene) &optional environment)
+  (make-load-form-saving-slots this :environment environment))
+
 (defmethod print-object ((this scene) stream)
   (print-unreadable-object (this stream :type t :identity t)
     (prin1 [this :slot id] stream)
@@ -68,3 +71,15 @@
                 do [actor (destroy)])
           (remove-scene this))
   (setf [this :slot destroyed-p] t))
+
+(defmethod resume ((this scene))
+  "Initialize or restore this scene's state."
+  ; Restore actors
+  (loop for actor in [this actors]
+        do [actor (resume)]))
+
+(defmethod suspend ((this scene))
+  "Prepare this scene for serialization."
+  ; Suspend actors
+  (loop for actor in [this actors]
+        do [actor (suspend)]))

wh-engine/serialization.lisp

@@ -8,11 +8,11 @@
 
 (deftype pointer () '(or id-ref weak-pointer null))
 
-(defun suspend-ptr (ptr)
+(defun referize (ptr)
-  "Convert weak-pointer ptr to an id-ref."
+  "Convert weak-pointer ptr into an id-ref."
   (declare (type weak-pointer ptr))
 
-  (let (target (weak-pointer-value ptr))
+  (let ((target (weak-pointer-value ptr)))
     (cond
       ((typep target 'scene)
        (make-id-ref :scene [target id]))
@@ -23,19 +23,32 @@
        (make-id-ref :scene [target scene id]
                     :actor [target actor id]
                     :component (class-name (class-of target))))
-    (t ptr))))
+      (t (error "can't referize ~S (not an actor, component, or scene)" ptr)))))
 
-(defun resume-ptr (ref)
+(defun pointerize (ref)
-  "Convert id-ref ref to a weak-pointer."
+  "Convert id-ref ref into a weak-pointer."
   (declare (type id-ref ref))
 
   (let ((scene (get-scene (id-ref-scene ref))) actor component)
+    (unless scene
+      (error "can't pointerize ~S (scene not found)" ref))
+    (if (id-ref-actor ref)
         (if (setf actor [scene (get-actor (id-ref-actor ref))])
+            (if (id-ref-component ref)
                 (if (setf component [actor (get-component (find-class (id-ref-component ref)))])
                     (make-weak-pointer component)
+                    (error "can't pointerize ~S (component not found)" ref))
                 (make-weak-pointer actor))
+            (error "can't pointerize ~S (actor not found)" ref))
         (make-weak-pointer scene))))
 
+(defmacro referize-setf (place)
+  `(when (typep ,place 'weak-pointer)
+     (setf ,place (referize ,place))))
+(defmacro pointerize-setf (place)
+  `(when (typep ,place 'id-ref)
+     (setf ,place (pointerize ,place))))
+
 (defun replace-in-tree (tree atom-fun)
   (if (consp (car tree))
       (replace-in-tree (car tree) atom-fun)
@@ -45,29 +58,48 @@
       (rplacd tree (funcall atom-fun (cdr tree))))
   tree)
 
+(defun copy-replace-tree (tree atom-fun)
+  (when tree
+    (let ((new-car (car tree)) (new-cdr (cdr tree)))
+      (if (consp new-car)
+          (setf new-car (copy-replace-tree new-car atom-fun))
+          (setf new-car (funcall atom-fun new-car)))
+      (if (consp new-cdr)
+          (setf new-cdr (copy-replace-tree new-cdr atom-fun))
+          (setf new-cdr (funcall atom-fun new-cdr)))
+      (cons new-car new-cdr))))
+
 (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))
+      (setf (gethash obj table) sym)
-      (replace-in-tree init-form (lambda (x)
+      (setf init-form
+            (copy-replace-tree init-form
+                               (lambda (x)
                                  (cond
-                                     ; x has already been processed
+                                   ;; x has already been processed
-                                     ((gethash x table)
+                                   ((gethash x table))
-                                      (car (gethash x table)))
+                                   ;; x is an id-ref, just serialize it like this
-                                     ; x needs to be run through process-load-forms
+                                   ((typep x 'id-ref)
+                                    `(make-id-ref :scene ,(id-ref-scene x)
+                                                  :actor ,(id-ref-actor x)
+                                                  :component ,(id-ref-component x)))
+                                   ;; 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))
+                                      (when x-init-forms
+                                        (setf output-init-forms (nconc output-init-forms x-init-forms)))
                                       x-sym))
-                                     ; x is a type that doesn't need processing
+                                   ;; x doesn't need processing
-                                     (t x))))
+                                   (t x)))))
       (setf output-cons-forms (nconc output-cons-forms `((,sym ,cons-form))))
-      (setf output-init-forms (nconc output-init-forms `(,init-form)))
+      (when init-form
+        (setf output-init-forms (nconc output-init-forms `(,init-form))))
       (values output-cons-forms output-init-forms sym))))
 
 (defun generate-load-forms (obj)
@@ -77,15 +109,3 @@
        ,@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))))
-(defmacro resume-setf (place)
-  `(when (typep ,place 'id-ref)
-     (setf ,place (resume-ptr ,place))))