From de0d84f7b3cfc0ed5416a589733f3883b7ab0f77 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 29 Apr 2017 13:20:25 -0700 Subject: [PATCH] racket/serialize: repairs for structs that have auto fields Closes #1650 --- .../tests/racket/serialize.rktl | 36 +++++++- racket/collects/racket/serialize.rkt | 83 +++++++++++++++---- 2 files changed, 103 insertions(+), 16 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/serialize.rktl b/pkgs/racket-test-core/tests/racket/serialize.rktl index a5312cc3b8..59e8367fd0 100644 --- a/pkgs/racket-test-core/tests/racket/serialize.rktl +++ b/pkgs/racket-test-core/tests/racket/serialize.rktl @@ -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)) diff --git a/racket/collects/racket/serialize.rkt b/racket/collects/racket/serialize.rkt index 84018a6c3b..9ce0e400dd 100644 --- a/racket/collects/racket/serialize.rkt +++ b/racket/collects/racket/serialize.rkt @@ -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)