Prune symbols in serialized object code (for #4)
This commit is contained in:
parent
67d6fe13b2
commit
62ace0204e
GPG key ID:
5BEBEEAB2C73D520
1 changed files with 89 additions and 43 deletions
|
|
@ -59,53 +59,99 @@
|
|||
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))))
|
||||
(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)
|
||||
"Update table with the forms necessary to generate obj."
|
||||
(multiple-value-bind (cons-form init-form)
|
||||
(make-load-form obj)
|
||||
(let ((sym (gensym))
|
||||
(output-cons-forms ())
|
||||
(output-init-forms ()))
|
||||
(setf (gethash obj table) sym)
|
||||
(setf init-form
|
||||
(copy-replace-tree init-form
|
||||
(lambda (x)
|
||||
(cond
|
||||
;; x has already been processed
|
||||
((gethash x table))
|
||||
;; x is an id-ref, just serialize it like this
|
||||
((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))
|
||||
(when x-init-forms
|
||||
(setf output-init-forms (nconc output-init-forms x-init-forms)))
|
||||
x-sym))
|
||||
;; x doesn't need processing
|
||||
(t x)))))
|
||||
(setf output-cons-forms (nconc output-cons-forms `((,sym ,cons-form))))
|
||||
(let ((sym (gensym)))
|
||||
(setf (gethash obj table) (cons sym (cons cons-form nil)))
|
||||
(when init-form
|
||||
(setf output-init-forms (nconc output-init-forms `(,init-form))))
|
||||
(values output-cons-forms output-init-forms sym))))
|
||||
(setf init-form
|
||||
(copy-replace-tree init-form
|
||||
(lambda (x)
|
||||
(cond
|
||||
;; x has already been processed
|
||||
((gethash x table)
|
||||
(car (gethash x table)))
|
||||
;; x is an id-ref, just serialize it like this
|
||||
((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))
|
||||
(process-load-forms x table))
|
||||
;; x doesn't need processing
|
||||
(t x)))))
|
||||
(setf (gethash obj table) (cons sym (cons cons-form init-form))))
|
||||
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
|
||||
(defun apply-in-tree (tree atom-fun)
|
||||
"Run atom-fun on everything in tree. Stop if atom-fun returns nil."
|
||||
(when tree
|
||||
(if (if (consp (car tree))
|
||||
(apply-in-tree (car tree) atom-fun)
|
||||
(funcall atom-fun (car tree)))
|
||||
(if (consp (cdr tree))
|
||||
(apply-in-tree (cdr tree) atom-fun)
|
||||
(funcall atom-fun (cdr tree)))
|
||||
nil)
|
||||
))
|
||||
|
||||
(defun prune-form-symbols (table init-forms)
|
||||
"Replace symbols in init-forms with their cons-form from table if they're only referenced once."
|
||||
(let ((count-table (make-hash-table)))
|
||||
;; collect symbols without an init-form
|
||||
(loop for entry being each hash-value in table
|
||||
using (hash-key key)
|
||||
unless (cddr entry)
|
||||
do (setf (gethash (car entry) count-table) (cons 0 key)))
|
||||
;; count occurences of prunable symbols
|
||||
(apply-in-tree init-forms
|
||||
(lambda (x)
|
||||
(when (and (symbolp x) (gethash x count-table))
|
||||
(incf (car (gethash x count-table)) 1))
|
||||
t))
|
||||
;; replace symbols that occur exactly once
|
||||
(replace-in-tree init-forms
|
||||
(lambda (x)
|
||||
(if (symbolp x)
|
||||
(let ((pair (gethash x count-table)))
|
||||
(if (and pair (= (car pair) 1))
|
||||
(prog1
|
||||
(cadr (gethash (cdr pair) table))
|
||||
(remhash (cdr pair) table))
|
||||
x))
|
||||
x)))
|
||||
))
|
||||
|
||||
(defun generate-load-forms (obj &key (prune t))
|
||||
"Generate code that restores the current state of obj."
|
||||
(declare (type boolean prune))
|
||||
|
||||
(let ((table (make-hash-table :test #'eq))
|
||||
sym init-forms)
|
||||
;; serialize
|
||||
(setf sym (process-load-forms obj table))
|
||||
;; collect init-forms
|
||||
(setf init-forms (loop for entry being each hash-value in table
|
||||
when (cddr entry)
|
||||
collect it))
|
||||
;; prune if requested
|
||||
(when prune (setf init-forms (prune-form-symbols table init-forms)))
|
||||
;; generate final form
|
||||
`(let ,(loop for entry being each hash-value in table
|
||||
;; (sym cons-form)
|
||||
collect (list (car entry) (cadr entry)))
|
||||
,@init-forms
|
||||
,sym)))
|
||||
|
||||
,sym)
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in a new issue