Rough serialization of classes to S-expressions (for #3)
This commit is contained in:
parent
46473ee8ce
commit
01b787e7bf
|
@ -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))))
|
||||
|
|
|
@ -23,6 +23,7 @@
|
|||
pointer
|
||||
suspend-ptr resume-ptr
|
||||
suspend-setf resume-setf
|
||||
generate-load-forms
|
||||
|
||||
;; actor.lisp
|
||||
actor
|
||||
|
|
|
@ -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))))
|
||||
|
|
Loading…
Reference in New Issue