racket/serialize: repairs for structs that have auto fields
Closes #1650
This commit is contained in:
Matthew Flatt
parent
bb2f1998f1
commit
de0d84f7b3
|
|
@ -17,8 +17,13 @@
|
|||
(define-serializable-struct (c a) (z) #:inspector insp #:mutable)
|
||||
(define-serializable-struct (d b) (w) #:inspector insp #:mutable)
|
||||
|
||||
(serializable-struct a/auto ([v #:auto]) #:auto-value 10 #:inspector insp)
|
||||
(serializable-struct b/auto ([v #:auto #:mutable]) #:auto-value 11 #:inspector insp)
|
||||
(serializable-struct c/auto b/auto (v) #:inspector insp)
|
||||
(serializable-struct d/auto b/auto ([v #:auto #:mutable]) #:inspector insp)
|
||||
|
||||
(define (same? v1 v2)
|
||||
;; This is not quite the same as `equal?', veuase it knows
|
||||
;; This is not quite the same as `equal?', becuase it knows
|
||||
;; about the structure types a, b, etc.
|
||||
(define ht (make-hasheq))
|
||||
(let loop ([v1 v1][v2 v2])
|
||||
|
|
@ -40,6 +45,24 @@
|
|||
[(and (c? v1) (c? v2))
|
||||
(hash-set! ht v1 v2)
|
||||
(loop (c-z v1) (c-z v2))]
|
||||
[(and (a/auto? v1)
|
||||
(a/auto? v2))
|
||||
(same? (a/auto-v v1) (a/auto-v v2))]
|
||||
[(and (b/auto? v1)
|
||||
(b/auto? v2)
|
||||
(not (c/auto? v1))
|
||||
(not (c/auto? v2))
|
||||
(not (d/auto? v1))
|
||||
(not (d/auto? v2)))
|
||||
(same? (b/auto-v v1) (b/auto-v v2))]
|
||||
[(and (c/auto? v1)
|
||||
(c/auto? v2))
|
||||
(and (same? (b/auto-v v1) (b/auto-v v2))
|
||||
(same? (c/auto-v v1) (c/auto-v v2)))]
|
||||
[(and (d/auto? v1)
|
||||
(d/auto? v2))
|
||||
(and (same? (b/auto-v v1) (b/auto-v v2))
|
||||
(same? (d/auto-v v1) (d/auto-v v2)))]
|
||||
[(and (d? v1) (d? v2))
|
||||
(hash-set! ht v1 v2)
|
||||
(and (loop (b-x v1) (b-x v2))
|
||||
|
|
@ -162,6 +185,17 @@
|
|||
(test-ser (make-b 1 2))
|
||||
(test-ser (make-c 30))
|
||||
(test-ser (make-d 100 200 300))
|
||||
(test-ser (a/auto))
|
||||
(test-ser (let ([s (b/auto)])
|
||||
(set-b/auto-v! s 'changed)
|
||||
s))
|
||||
(test-ser (let ([s (c/auto 'two)])
|
||||
(set-b/auto-v! s 'changed)
|
||||
s))
|
||||
(test-ser (let ([s (d/auto)])
|
||||
(set-b/auto-v! s 'changed)
|
||||
(set-d/auto-v! s 'also-new)
|
||||
s))
|
||||
|
||||
(test-ser (make-srcloc 1 2 3 4 5))
|
||||
(test-ser (make-srcloc (string->path "/tmp/test.rkt") 2 3 4 5))
|
||||
|
|
|
|||
|
|
@ -34,10 +34,35 @@
|
|||
(let* ([id (if (identifier? #'id/sup)
|
||||
#'id/sup
|
||||
(car (syntax-e #'id/sup)))]
|
||||
[super-info (if (identifier? #'id/sup)
|
||||
#f
|
||||
(extract-struct-info (syntax-local-value (cadr (syntax->list #'id/sup)))))]
|
||||
[super-v (if (identifier? #'id/sup)
|
||||
#f
|
||||
(syntax-local-value (cadr (syntax->list #'id/sup))))]
|
||||
[super-info (and super-v
|
||||
(extract-struct-info super-v))]
|
||||
[super-auto-info (and (struct-auto-info? super-v)
|
||||
(struct-auto-info-lists super-v))]
|
||||
[fields (syntax->list #'(field ...))]
|
||||
[extract-field-name (lambda (field)
|
||||
(cond
|
||||
[(identifier? field) field]
|
||||
[(pair? (syntax-e field))
|
||||
(define id (car (syntax-e field)))
|
||||
(if (identifier? id)
|
||||
id
|
||||
#'bad)]
|
||||
[else #'bad]))]
|
||||
[field-names (for/list ([field (in-list fields)])
|
||||
(extract-field-name field))]
|
||||
[non-auto-field-names (for/list ([field (in-list fields)]
|
||||
#:unless (let loop ([e field])
|
||||
(cond
|
||||
[(null? e) #f]
|
||||
[(syntax? e) (loop (syntax-e e))]
|
||||
[(pair? e)
|
||||
(or (eq? '#:auto (syntax-e (car e)))
|
||||
(loop (cdr e)))]
|
||||
[else #f])))
|
||||
(extract-field-name field))]
|
||||
[given-maker (let loop ([props (syntax->list #'(prop ...))])
|
||||
(cond
|
||||
[(null? props) #f]
|
||||
|
|
@ -60,15 +85,7 @@
|
|||
(string->symbol
|
||||
(format "~a-~a"
|
||||
(syntax-e id)
|
||||
(syntax-e
|
||||
(if (identifier? field)
|
||||
field
|
||||
(syntax-case field ()
|
||||
[(id . _)
|
||||
(if (identifier? #'id)
|
||||
#'id
|
||||
#'bad)]
|
||||
[_ #'bad])))))))
|
||||
(syntax-e (extract-field-name field))))))
|
||||
fields)]
|
||||
[mutable? (ormap (lambda (x)
|
||||
(eq? '#:mutable (syntax-e x)))
|
||||
|
|
@ -152,7 +169,43 @@
|
|||
(define #,deserialize-id
|
||||
(make-deserialize-info
|
||||
;; The maker: --------------------
|
||||
#,maker
|
||||
#,(let* ([n-fields (length field-names)]
|
||||
[n-non-auto-fields (length non-auto-field-names)]
|
||||
[super-field-names (if super-info
|
||||
(generate-temporaries
|
||||
(list-ref super-info 3))
|
||||
null)]
|
||||
[super-setters (if super-info
|
||||
(list-ref super-info 4)
|
||||
null)]
|
||||
[n-super-fields (length super-field-names)]
|
||||
[n-super-non-auto-fields (- n-super-fields
|
||||
(if super-auto-info
|
||||
(length (car super-auto-info))
|
||||
0))]
|
||||
[super-non-auto-field-names (let loop ([super-field-names super-field-names]
|
||||
[n n-super-non-auto-fields])
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons (car super-field-names)
|
||||
(loop (cdr super-field-names)
|
||||
(sub1 n)))))])
|
||||
(if (and (= n-fields n-non-auto-fields)
|
||||
(= n-super-fields n-super-non-auto-fields))
|
||||
maker
|
||||
#`(lambda (#,@super-field-names #,@field-names)
|
||||
(let ([s (#,maker #,@super-non-auto-field-names #,@non-auto-field-names)])
|
||||
#,@(for/list ([field-name (in-list
|
||||
(append
|
||||
(list-tail super-field-names n-super-non-auto-fields)
|
||||
(list-tail field-names n-non-auto-fields)))]
|
||||
[setter (in-list
|
||||
(append
|
||||
(list-tail super-setters n-super-non-auto-fields)
|
||||
(list-tail setters n-non-auto-fields)))]
|
||||
#:when setter)
|
||||
#`(#,setter s #,field-name))
|
||||
s))))
|
||||
;; The shell function: --------------------
|
||||
;; Returns an shell object plus
|
||||
;; a function to update the shell (used for
|
||||
|
|
@ -169,9 +222,9 @@
|
|||
(map (lambda (x) #f)
|
||||
(list-ref super-info 3))
|
||||
null)
|
||||
(map (lambda (g)
|
||||
(map (lambda (f)
|
||||
#f)
|
||||
getters)))])
|
||||
non-auto-field-names)))])
|
||||
(values
|
||||
s0
|
||||
(lambda (s)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user