suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix serializer for cycles containing immutable structs

Browse Source
This commit is contained in:
Matthew Flatt 2016-05-16 16:28:28 -06:00
parent add08c902d
commit 6ba3461738
4 changed files with 29 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/racket-test-core/tests/racket/serialize.rktl
View File

@ -535,6 +535,13 @@
(test s read (open-input-string (get-output-string o))))
(delete-file fn))
;; ----------------------------------------
(define-serializable-struct immutable-a (b))
(let ([a (immutable-a (box #f))])
(set-box! (immutable-a-b a) a)
(deserialize (serialize a)))
;; ----------------------------------------

4
racket/collects/racket/private/class-internal.rkt
View File

@ -2459,9 +2459,7 @@ last few projections.
(lambda (obj)
((class-serializer c) obj))
deserialize-id
(and (not inspector)
(not (interface-extension? i externalizable<%>))
(eq? #t (class-serializer super)))
(not (interface-extension? i externalizable<%>))
(or (current-load-relative-directory)
(current-directory)))))
null))

3
racket/collects/racket/private/serialize.rkt
View File

@ -154,7 +154,8 @@
(vector? o)
(hash? o))
(not (immutable? o)))
(serializable-struct? o)
(and (serializable-struct? o)
(serialize-info-can-cycle? (serializable-info o)))
(flvector? o)
(fxvector? o)
(let ([k (prefab-struct-key o)])

34
racket/collects/racket/serialize.rkt
View File

@ -112,6 +112,11 @@
#'orig-stx
(syntax-case #'id/sup ()
[(_ sup) #'sup]))))
(define can-handle-cycles?
;; Yes, as long as we have mutators here and for the superclass
(and (andmap values setters)
(or (not super-info)
(andmap values (list-ref super-info 4)))))
#`(begin
;; =============== struct with serialize property ================
(define-struct/derived orig-stx
@ -139,11 +144,7 @@
;; The serializer id: --------------------
(quote-syntax #,deserialize-id)
;; Can handle cycles? --------------------
;; Yes, as long as we have mutators for the
;; superclass.
#,(and (andmap values setters)
(or (not super-info)
(andmap values (list-ref super-info 4))))
'#,can-handle-cycles?
;; Directory for last-ditch resolution --------------------
(or (current-load-relative-directory)
(current-directory))))
@ -174,16 +175,19 @@
(values
s0
(lambda (s)
#,@(if super-info
(map (lambda (set get)
#`((or #,set void) s0 (#,get s)))
(list-ref super-info 4)
(list-ref super-info 3))
null)
#,@(map (lambda (getter setter)
#`((or #,setter void) s0 (#,getter s)))
getters
setters)
#,(if can-handle-cycles?
#`(begin
#,@(if super-info
(map (lambda (set get)
#`(#,set s0 (#,get s)))
(list-ref super-info 4)
(list-ref super-info 3))
null)
#,@(map (lambda (getter setter)
#`(#,setter s0 (#,getter s)))
getters
setters))
#`(error "cannot mutate to complete a cycle"))
(void))))))))
#,@(map (lambda (other-deserialize-id proc-expr cycle-proc-expr)
#`(define #,other-deserialize-id