92 lines
3.5 KiB
Common Lisp
92 lines
3.5 KiB
Common Lisp
;;;; wh-engine/serialization.lisp
|
|
(in-package wh-engine)
|
|
|
|
(defstruct id-ref
|
|
(scene 0 :type fixnum)
|
|
(actor nil :type (or fixnum null))
|
|
(component nil :type (or symbol null)))
|
|
|
|
(deftype pointer () '(or id-ref weak-pointer null))
|
|
|
|
(defun suspend-ptr (ptr)
|
|
"Convert weak-pointer ptr to an id-ref."
|
|
(declare (type weak-pointer ptr))
|
|
|
|
(let (target (weak-pointer-value ptr))
|
|
(cond
|
|
((typep target 'scene)
|
|
(make-id-ref :scene [target id]))
|
|
((typep target 'actor)
|
|
(make-id-ref :scene [target scene id]
|
|
:actor [target id]))
|
|
((typep target 'component)
|
|
(make-id-ref :scene [target scene id]
|
|
:actor [target actor id]
|
|
:component (class-name (class-of target))))
|
|
(t ptr))))
|
|
|
|
(defun resume-ptr (ref)
|
|
"Convert id-ref ref to a weak-pointer."
|
|
(declare (type id-ref ref))
|
|
|
|
(let ((scene (get-scene (id-ref-scene ref))) actor component)
|
|
(if (setf actor [scene (get-actor (id-ref-actor ref))])
|
|
(if (setf component [actor (get-component (find-class (id-ref-component ref)))])
|
|
(make-weak-pointer component)
|
|
(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))))
|
|
(defmacro resume-setf (place)
|
|
`(when (typep ,place 'id-ref)
|
|
(setf ,place (resume-ptr ,place))))
|