Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
Hayley Patton
netfarm
Commits
4f468fc3
Commit
4f468fc3
authored
Feb 26, 2020
by
Hayley Patton
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add a function to deep copy Netfarm datum.
parent
74bba036
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
77 additions
and
2 deletions
+77
-2
Code/Objects/deep-copy.lisp
Code/Objects/deep-copy.lisp
+74
-0
Code/netfarm.asd
Code/netfarm.asd
+2
-1
Code/package.lisp
Code/package.lisp
+1
-1
No files found.
Code/Objects/deep-copy.lisp
0 → 100644
View file @
4f468fc3
(
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
)))
Code/netfarm.asd
View file @
4f468fc3
...
...
@@ -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"
...
...
Code/package.lisp
View file @
4f468fc3
...
...
@@ -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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment