Commit 4f468fc3 authored by  Hayley Patton's avatar Hayley Patton 🐢

Add a function to deep copy Netfarm datum.

parent 74bba036
(in-package :netfarm)
(defgeneric %deep-copy-object (object callback)
(:method (garbage callback)
(warn "Can't copy ~s" garbage)
(funcall callback garbage)
'())
(:method ((hash-table hash-table) callback)
;; This isn't Netfarm data, but is used for metadata tables, so we have
;; to be able to copy those too.
(let ((new-table (alexandria:copy-hash-table hash-table)))
(funcall callback new-table)
(loop for key being the hash-keys of new-table
for value being the hash-values of new-table
collect (cons value
(lambda (value)
(setf (gethash key new-table) value))))))
(:method ((class class) callback)
(funcall callback class)
'())
(:method ((object object) callback)
(let* ((class (class-of object))
(new-object (allocate-instance class)))
(flet ((update-slot (slot)
(lambda (slot-value)
(setf (closer-mop:slot-value-using-class class new-object
slot)
slot-value))))
(funcall callback new-object)
(loop for slot in (closer-mop:class-slots class)
when (closer-mop:slot-boundp-using-class class object slot)
collect (cons (closer-mop:slot-value-using-class class
object
slot)
(update-slot slot))))))
(:method ((number number) callback)
(funcall callback number)
'())
(:method ((cons cons) callback)
(let ((new-cons (cons nil nil)))
(funcall callback new-cons)
(list (cons (car cons)
(lambda (car)
(setf (car new-cons) car)))
(cons (cdr cons)
(lambda (cdr)
(setf (cdr new-cons) cdr))))))
(:method ((vector vector) callback)
(funcall callback (alexandria:copy-array vector))
'())
(:method ((null null) callback)
(funcall callback '())
'()))
(defun deep-copy-object (object)
;; This deep copying algorithm uses an auxiliary stack that is a list of
;; conses, each with an object to copy in the CAR and a function to call
;; with the shallow-copied object in the CDR.
(loop with copied-object = nil
with cache = (make-hash-table :test 'eql)
with stack = (list
(cons object
(lambda (new-object)
(setf copied-object new-object))))
until (null stack)
do (destructuring-bind (object-to-copy . callback)
(pop stack)
(multiple-value-bind (already-copied-object present?)
(gethash object-to-copy cache)
(if present?
(funcall callback already-copied-object)
(setf stack (append (%deep-copy-object object-to-copy callback)
stack)))))
finally (return-from deep-copy-object copied-object)))
......@@ -18,7 +18,8 @@
(:file "schema")
(:file "type-specifiers")
(:file "inbuilt-netfarm-class")
(:file "computed-values")))
(:file "computed-values")
(:file "deep-copy")))
(:module "Scripts"
:components ((:file "package")
(:module "Script-machine"
......
......@@ -13,7 +13,7 @@
#:netfarm-class-name
#:object-value #:set-object-value #:object-makunbound #:object-boundp
#:map-objects
#:compute-dependencies
#:compute-dependencies #:deep-copy-object
#:find-netfarm-class
#:find-netfarm-slot #:find-netfarm-computed-slot
#:map-slots #:map-computed-slots
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment