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)))) (test s read (open-input-string (get-output-string o))))
(delete-file fn)) (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)))
;; ---------------------------------------- ;; ----------------------------------------

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

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

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

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

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

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