fix shared' for #:auto' fields and constructors without `make-'
Closes PR 11588 Closes PR 11591
This commit is contained in:
Matthew Flatt
parent
b32287fa2d
commit
655f6045a2
|
|
@ -3,6 +3,7 @@
|
|||
(require syntax/stx
|
||||
syntax/kerncase
|
||||
syntax/struct
|
||||
racket/struct-info
|
||||
scheme/include)
|
||||
|
||||
(provide shared/proc)
|
||||
|
|
|
|||
|
|
@ -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 ...)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
syntax/stx
|
||||
syntax/kerncase
|
||||
syntax/struct
|
||||
racket/struct-info
|
||||
scheme/include))
|
||||
|
||||
(provide shared)
|
||||
|
|
|
|||
|
|
@ -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 <id> for structure-type name or (<id> <id>) 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))))))])
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user