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

fix shared' for #:auto' fields and constructors without `make-'

Browse Source 
Closes PR 11588
 Closes PR 11591
This commit is contained in:
Matthew Flatt 2011-01-05 13:14:30 -07:00
parent b32287fa2d
commit 655f6045a2
7 changed files with 163 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/lang/private/teach-shared.rkt
View File

@ -3,6 +3,7 @@
(require syntax/stx (require syntax/stx
syntax/kerncase syntax/kerncase
syntax/struct syntax/struct
racket/struct-info
scheme/include) scheme/include)
(provide shared/proc) (provide shared/proc)

36
collects/mzlib/private/shared-body.rkt
View File

@ -49,7 +49,11 @@
(let ([decl (extract-struct-info v)]) (let ([decl (extract-struct-info v)])
(and (cadr decl) (and (cadr decl)
(andmap values (list-ref decl 4)) (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) (or (get-struct id)
(let ([s (syntax-property id 'constructor-for)]) (let ([s (syntax-property id 'constructor-for)])
(and s (and s
@ -75,7 +79,17 @@
#f #f
(if (eq? 'the-cons (syntax-e b)) (if (eq? 'the-cons (syntax-e b))
'cons '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 ...) (with-syntax ([(graph-expr ...)
(map (lambda (expr) (map (lambda (expr)
(let loop ([expr expr]) (let loop ([expr expr])
@ -153,13 +167,15 @@
[args (syntax->list (syntax args))]) [args (syntax->list (syntax args))])
(unless args (unless args
(bad "structure constructor")) (bad "structure constructor"))
(unless (= (length (list-ref decl 4)) (length args)) (let ([expected (- (length (list-ref decl 4))
(raise-syntax-error (length (car (list-ref decl 6))))])
'shared (unless (= expected (length args))
(format "wrong argument count for structure constructor; expected ~a, found ~a" (raise-syntax-error
(length (list-ref decl 4)) (length args)) 'shared
stx (format "wrong argument count for structure constructor; expected ~a, found ~a"
expr)) expected (length args))
stx
expr)))
(with-syntax ([undefineds (map (lambda (x) (syntax undefined)) args)]) (with-syntax ([undefineds (map (lambda (x) (syntax undefined)) args)])
(syntax (make-x . undefineds))))] (syntax (make-x . undefineds))))]
[_else expr]))) [_else expr])))
@ -253,7 +269,7 @@
[(make-x e ...) [(make-x e ...)
(struct-decl-for (syntax make-x)) (struct-decl-for (syntax make-x))
(let ([decl (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))] (syntax (void))]
[(setter ...) [(setter ...)

1
collects/mzlib/shared.rkt
View File

@ -4,6 +4,7 @@
syntax/stx syntax/stx
syntax/kerncase syntax/kerncase
syntax/struct syntax/struct
racket/struct-info
scheme/include)) scheme/include))
(provide shared) (provide shared)

79
collects/racket/private/define-struct.rkt
View File

@ -16,13 +16,26 @@
(for-syntax (for-syntax
(rename checked-struct-info-rec? checked-struct-info?))) (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 (define-values-for-syntax
(struct:checked-struct-info (struct:checked-struct-info
make-checked-struct-info make-checked-struct-info
checked-struct-info-rec? checked-struct-info-rec?
checked-struct-info-ref checked-struct-info-ref
checked-struct-info-set!) 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 0 0 #f
null (current-inspector) null (current-inspector)
(lambda (v stx) (lambda (v stx)
@ -31,10 +44,10 @@
"identifier for static struct-type information cannot be used as an expression" "identifier for static struct-type information cannot be used as an expression"
stx)) stx))
null null
(lambda (proc info) (lambda (proc autos info)
(if (and (procedure? proc) (if (and (procedure? proc)
(procedure-arity-includes? proc 0)) (procedure-arity-includes? proc 0))
proc (values proc autos)
(raise-type-error 'make-struct-info (raise-type-error 'make-struct-info
"procedure (arity 0)" "procedure (arity 0)"
proc))))) proc)))))
@ -54,7 +67,7 @@
(define-values-for-syntax (make-self-ctor-struct-info) (define-values-for-syntax (make-self-ctor-struct-info)
(letrec-values ([(struct: make- ? ref set!) (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 1 0 #f
(list (cons prop:procedure (list (cons prop:procedure
(lambda (v stx) (lambda (v stx)
@ -335,11 +348,15 @@
"bad syntax; expected <id> for structure-type name or (<id> <id>) for name and supertype name" "bad syntax; expected <id> for structure-type name or (<id> <id>) for name and supertype name"
stx stx
#'id)]))]) #'id)]))])
(let-values ([(super-info super-info-checked?) (let-values ([(super-info super-autos super-info-checked?)
(if super-id (if super-id
(let ([v (syntax-local-value super-id (lambda () #f))]) (let ([v (syntax-local-value super-id (lambda () #f))])
(if (struct-info? v) (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 (raise-syntax-error
#f #f
(format "parent struct type not defined~a" (format "parent struct type not defined~a"
@ -350,7 +367,7 @@
stx stx
super-id))) super-id)))
;; if there's no super type, it's like it was checked ;; if there's no super type, it's like it was checked
(values #f #t))]) (values #f #f #t))])
(when (and super-info (when (and super-info
(not (car super-info))) (not (car super-info)))
(raise-syntax-error (raise-syntax-error
@ -411,7 +428,9 @@
(let ([struct: (build-name id "struct:" id)] (let ([struct: (build-name id "struct:" id)]
[make- (if ctor-name [make- (if ctor-name
(if self-ctor? (if self-ctor?
(car (generate-temporaries (list id))) (if omit-define-syntaxes?
ctor-name
(car (generate-temporaries (list id))))
ctor-name) ctor-name)
(build-name id "make-" id))] (build-name id "make-" id))]
[? (build-name id id "?")] [? (build-name id id "?")]
@ -498,18 +517,26 @@
(loop (add1 i) (cdr fields)))))))))))] (loop (add1 i) (cdr fields)))))))))))]
[compile-time-defns [compile-time-defns
(lambda () (lambda ()
(let ([protect (lambda (sel) (let* ([protect (lambda (sel)
(and sel (and sel
(if (syntax-e sel) (if (syntax-e sel)
#`(quote-syntax #,(prune sel)) #`(quote-syntax #,(prune sel))
sel)))] sel)))]
[mk-info (if super-info-checked? [include-autos? (or super-info-checked?
(if name-as-ctor? name-as-ctor?
#'make-self-ctor-checked-struct-info (and super-autos
#'make-checked-struct-info) (or (pair? (car super-autos))
(if name-as-ctor? (pair? (cadr super-autos))))
#'make-self-ctor-struct-info (positive? auto-count))]
#'make-struct-info))]) [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 (quasisyntax/loc stx
(define-syntaxes (#,id) (define-syntaxes (#,id)
(#,mk-info (#,mk-info
@ -547,6 +574,18 @@
(if super-expr (if super-expr
#f #f
#t)))) #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? #,@(if name-as-ctor?
(list #`(lambda () (quote-syntax #,make-))) (list #`(lambda () (quote-syntax #,make-)))
null))))))]) null))))))])

35
collects/racket/private/struct-info.rkt
View File

@ -9,7 +9,11 @@
struct-info? struct-info?
extract-struct-info extract-struct-info
struct: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) (define-values (prop:struct-info has-struct-info-prop? struct-info-prop-ref)
(make-struct-type-property 'struct-info (make-struct-type-property 'struct-info
@ -99,4 +103,31 @@
(identifier/#f? (caddr x)) (identifier/#f? (caddr x))
(id/#f-list? identifier? (list-ref x 3)) (id/#f-list? identifier? (list-ref x 3))
(id/#f-list? identifier/#f? (list-ref x 4)) (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))))

28
collects/scribblings/reference/struct.scrbl
View File

@ -620,7 +620,8 @@ Finally, the representation can be an instance of a structure type
derived from @racket[struct:struct-info] or with the derived from @racket[struct:struct-info] or with the
@racket[prop:struct-info] property that also implements @racket[prop:struct-info] property that also implements
@racket[prop:procedure], and where the instance is further is wrapped @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 Use @racket[struct-info?] to recognize all allowed forms of the
information, and use @racket[extract-struct-info] to obtain a list 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 of one argument that takes an instance structure and returns
structure-type information in list form.} 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] @close-eval[struct-eval]

16
collects/tests/racket/shared.rktl
View File

@ -15,4 +15,20 @@
(require (only-in mzscheme define-struct)) (require (only-in mzscheme define-struct))
(load-relative "shared-tests.rktl") (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) (report-errs)