diff --git a/collects/lang/private/teach-shared.rkt b/collects/lang/private/teach-shared.rkt index 284b94ce7d..79de7212bb 100644 --- a/collects/lang/private/teach-shared.rkt +++ b/collects/lang/private/teach-shared.rkt @@ -3,6 +3,7 @@ (require syntax/stx syntax/kerncase syntax/struct + racket/struct-info scheme/include) (provide shared/proc) diff --git a/collects/mzlib/private/shared-body.rkt b/collects/mzlib/private/shared-body.rkt index 72ac6ca9c1..3cb600a05e 100644 --- a/collects/mzlib/private/shared-body.rkt +++ b/collects/mzlib/private/shared-body.rkt @@ -49,7 +49,11 @@ (let ([decl (extract-struct-info v)]) (and (cadr decl) (andmap values (list-ref decl 4)) - decl)))))]) + (append decl + (list + (if (struct-auto-info? v) + (struct-auto-info-lists v) + (list null null)))))))))]) (or (get-struct id) (let ([s (syntax-property id 'constructor-for)]) (and s @@ -75,7 +79,17 @@ #f (if (eq? 'the-cons (syntax-e b)) 'cons - (syntax-e b))))))]) + (syntax-e b))))))] + [remove-all (lambda (lst rmv-lst) + (define (remove e l) + (cond + [(free-identifier=? e (car l)) (cdr l)] + [else (cons (car l) (remove e (cdr l)))])) + (let loop ([lst lst] [rmv-lst rmv-lst]) + (if (null? rmv-lst) + lst + (loop (remove (car rmv-lst) lst) + (cdr rmv-lst)))))]) (with-syntax ([(graph-expr ...) (map (lambda (expr) (let loop ([expr expr]) @@ -153,13 +167,15 @@ [args (syntax->list (syntax args))]) (unless args (bad "structure constructor")) - (unless (= (length (list-ref decl 4)) (length args)) - (raise-syntax-error - 'shared - (format "wrong argument count for structure constructor; expected ~a, found ~a" - (length (list-ref decl 4)) (length args)) - stx - expr)) + (let ([expected (- (length (list-ref decl 4)) + (length (car (list-ref decl 6))))]) + (unless (= expected (length args)) + (raise-syntax-error + 'shared + (format "wrong argument count for structure constructor; expected ~a, found ~a" + expected (length args)) + stx + expr))) (with-syntax ([undefineds (map (lambda (x) (syntax undefined)) args)]) (syntax (make-x . undefineds))))] [_else expr]))) @@ -253,7 +269,7 @@ [(make-x e ...) (struct-decl-for (syntax make-x)) (let ([decl (struct-decl-for (syntax make-x))]) - (syntax-case (reverse (list-ref decl 4)) () + (syntax-case (remove-all (reverse (list-ref decl 4)) (cadr (list-ref decl 6))) () [() (syntax (void))] [(setter ...) diff --git a/collects/mzlib/shared.rkt b/collects/mzlib/shared.rkt index 361fc018cc..bb6e262e8e 100644 --- a/collects/mzlib/shared.rkt +++ b/collects/mzlib/shared.rkt @@ -4,6 +4,7 @@ syntax/stx syntax/kerncase syntax/struct + racket/struct-info scheme/include)) (provide shared) diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index 8875f8748f..1569f0c882 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -16,13 +16,26 @@ (for-syntax (rename checked-struct-info-rec? checked-struct-info?))) + (define-values-for-syntax + (struct:struct-auto-info + make-struct-auto-info + struct-auto-info-rec? + struct-auto-info-ref + struct-auto-info-set!) + (make-struct-type 'struct-auto-info struct:struct-info + 1 0 #f + (list (cons prop:struct-auto-info + (lambda (rec) + (struct-auto-info-ref rec 0)))))) + + (define-values-for-syntax (struct:checked-struct-info make-checked-struct-info checked-struct-info-rec? checked-struct-info-ref checked-struct-info-set!) - (make-struct-type 'checked-struct-info struct:struct-info + (make-struct-type 'checked-struct-info struct:struct-auto-info 0 0 #f null (current-inspector) (lambda (v stx) @@ -31,10 +44,10 @@ "identifier for static struct-type information cannot be used as an expression" stx)) null - (lambda (proc info) + (lambda (proc autos info) (if (and (procedure? proc) (procedure-arity-includes? proc 0)) - proc + (values proc autos) (raise-type-error 'make-struct-info "procedure (arity 0)" proc))))) @@ -54,7 +67,7 @@ (define-values-for-syntax (make-self-ctor-struct-info) (letrec-values ([(struct: make- ? ref set!) - (make-struct-type 'self-ctor-struct-info struct:struct-info + (make-struct-type 'self-ctor-struct-info struct:struct-auto-info 1 0 #f (list (cons prop:procedure (lambda (v stx) @@ -335,11 +348,15 @@ "bad syntax; expected for structure-type name or ( ) for name and supertype name" stx #'id)]))]) - (let-values ([(super-info super-info-checked?) + (let-values ([(super-info super-autos super-info-checked?) (if super-id (let ([v (syntax-local-value super-id (lambda () #f))]) (if (struct-info? v) - (values (extract-struct-info v) (checked-struct-info-rec? v)) + (values (extract-struct-info v) + (if (struct-auto-info? v) + (struct-auto-info-lists v) + (list null null)) + (checked-struct-info-rec? v)) (raise-syntax-error #f (format "parent struct type not defined~a" @@ -350,7 +367,7 @@ stx super-id))) ;; if there's no super type, it's like it was checked - (values #f #t))]) + (values #f #f #t))]) (when (and super-info (not (car super-info))) (raise-syntax-error @@ -411,7 +428,9 @@ (let ([struct: (build-name id "struct:" id)] [make- (if ctor-name (if self-ctor? - (car (generate-temporaries (list id))) + (if omit-define-syntaxes? + ctor-name + (car (generate-temporaries (list id)))) ctor-name) (build-name id "make-" id))] [? (build-name id id "?")] @@ -498,18 +517,26 @@ (loop (add1 i) (cdr fields)))))))))))] [compile-time-defns (lambda () - (let ([protect (lambda (sel) - (and sel - (if (syntax-e sel) - #`(quote-syntax #,(prune sel)) - sel)))] - [mk-info (if super-info-checked? - (if name-as-ctor? - #'make-self-ctor-checked-struct-info - #'make-checked-struct-info) - (if name-as-ctor? - #'make-self-ctor-struct-info - #'make-struct-info))]) + (let* ([protect (lambda (sel) + (and sel + (if (syntax-e sel) + #`(quote-syntax #,(prune sel)) + sel)))] + [include-autos? (or super-info-checked? + name-as-ctor? + (and super-autos + (or (pair? (car super-autos)) + (pair? (cadr super-autos)))) + (positive? auto-count))] + [mk-info (if super-info-checked? + (if name-as-ctor? + #'make-self-ctor-checked-struct-info + #'make-checked-struct-info) + (if name-as-ctor? + #'make-self-ctor-struct-info + (if include-autos? + #'make-struct-auto-info + #'make-struct-info)))]) (quasisyntax/loc stx (define-syntaxes (#,id) (#,mk-info @@ -547,6 +574,18 @@ (if super-expr #f #t)))) + #,@(if include-autos? + (list #`(list (list #,@(map protect + (list-tail sels (- (length sels) auto-count))) + #,@(if super-autos + (map protect (car super-autos)) + null)) + (list #,@(map protect + (list-tail sets (max 0 (- (length sets) auto-count)))) + #,@(if super-autos + (map protect (cadr super-autos)) + null)))) + null) #,@(if name-as-ctor? (list #`(lambda () (quote-syntax #,make-))) null))))))]) diff --git a/collects/racket/private/struct-info.rkt b/collects/racket/private/struct-info.rkt index 90954bd2be..c77d6275bf 100644 --- a/collects/racket/private/struct-info.rkt +++ b/collects/racket/private/struct-info.rkt @@ -9,7 +9,11 @@ struct-info? extract-struct-info struct:struct-info - prop:struct-info) + prop:struct-info + + prop:struct-auto-info + struct-auto-info? + struct-auto-info-lists) (define-values (prop:struct-info has-struct-info-prop? struct-info-prop-ref) (make-struct-type-property 'struct-info @@ -99,4 +103,31 @@ (identifier/#f? (caddr x)) (id/#f-list? identifier? (list-ref x 3)) (id/#f-list? identifier/#f? (list-ref x 4)) - (or (eq? #t (list-ref x 5)) (identifier/#f? (list-ref x 5)))))))) + (or (eq? #t (list-ref x 5)) (identifier/#f? (list-ref x 5))))))) + + (define-values (prop:struct-auto-info + struct-auto-info? + struct-auto-info-ref) + (make-struct-type-property 'struct-auto-info + (lambda (val info) + (unless (and (procedure? val) + (procedure-arity-includes? val 1)) + (raise-type-error 'guard-for-prop:struct-auto-info "procedure (arity 1)" val)) + val))) + + (define-values (struct-auto-info-lists) + (lambda (v) + (unless (struct-auto-info? v) + (raise-type-error 'struct-auto-info-lists "struct-auto-info" v)) + (let ([l ((struct-auto-info-ref v) v)] + [identifier? (lambda (v) (and (syntax? v) (symbol? (syntax-e v))))]) + (unless (and (list? l) + (= 2 (length l)) + (list? (car l)) + (list? (cadr l)) + (andmap identifier? (car l)) + (andmap identifier? (cadr l))) + (error 'struct-auto-info-lists + "struct-auto-info procedure result not properly formed: ~e" + l)) + l)))) diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 952429b452..40c2c3a40b 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -620,7 +620,8 @@ Finally, the representation can be an instance of a structure type derived from @racket[struct:struct-info] or with the @racket[prop:struct-info] property that also implements @racket[prop:procedure], and where the instance is further is wrapped -by @racket[make-set!-transformer]. +by @racket[make-set!-transformer]. In addition, the representation may +implement the @racket[prop:struct-auto-info] property. Use @racket[struct-info?] to recognize all allowed forms of the information, and use @racket[extract-struct-info] to obtain a list @@ -682,6 +683,31 @@ like @racket[struct:struct-info]. The property value must be a procedure of one argument that takes an instance structure and returns structure-type information in list form.} +@deftogether[( +@defthing[prop:struct-auto-info struct-type-property?] +@defproc[(struct-auto-info? [v any/c]) boolean?] +@defproc[(struct-auto-info-lists [sai struct-auto-info?]) + (list/c (listof identifier?) (listof identifier?))] +)]{ + +The @racket[prop:struct-auto-info] property is implemented to provide +static information about which of the accessor and mutator identifiers +for a structure type correspond to @racket[#:auto] fields (so that +they have no corresponding argument in the constructor). The property +value must be a procedure that accepts an instance structure to which +the property is given, and the result must be two lists of identifiers +suitable as a result from @racket[struct-auto-info-lists]. + +The @racket[struct-auto-info?] predicate recognizes values that +implement the @racket[prop:struct-auto-info] property. + +The @racket[struct-auto-info-lists] function extracts two lists of +identifiers from a value that implements the +@racket[prop:struct-auto-info] property. The first list should be a +subset of the accessor identifiers for the structure type described by +@racket[sai], and the second list should be a subset of the mutator +identifiers. The two subsets correspond to @racket[#:auto] fields.} + @; ---------------------------------------------------------------------- @close-eval[struct-eval] diff --git a/collects/tests/racket/shared.rktl b/collects/tests/racket/shared.rktl index c8dd2d0069..d4308cb8f4 100644 --- a/collects/tests/racket/shared.rktl +++ b/collects/tests/racket/shared.rktl @@ -15,4 +15,20 @@ (require (only-in mzscheme define-struct)) (load-relative "shared-tests.rktl") +;; Check that `shared' works with `struct': +(let () + (struct a (x y) #:mutable #:transparent) + (define an-a (a 1 2)) + (set-a-y! an-a an-a) + (test an-a 'an-a (shared ([t (a 1 t)]) + t))) + +;; Check that `shared' works with auto fields: +(let () + (struct a (x y [z #:auto]) #:mutable #:transparent) + (define an-a (a 1 2)) + (set-a-y! an-a an-a) + (test an-a 'an-a (shared ([t (a 1 t)]) + t))) + (report-errs)