Quick fix to get the right struct info out of define-struct/contract.
Closes PR 10526. Closes PR 10561.
This commit is contained in:
Stevie Strickland
parent
ed1c74108f
commit
4336f29273
|
|
@ -112,6 +112,9 @@
|
|||
(syntax-case name ()
|
||||
[id (identifier? #'id) #'id]
|
||||
[(sub super) #'sub])
|
||||
(syntax-case name ()
|
||||
[id (identifier? #'id) #'#f]
|
||||
[(sub super) #'super])
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
|
|
@ -256,16 +259,26 @@
|
|||
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
|
||||
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
|
||||
[names (build-struct-names #'name field-infos)]
|
||||
[pred (cadddr names)]
|
||||
[pred (car (cddddr names))]
|
||||
[ctcs (build-contracts stx pred field-infos)]
|
||||
[super-fields (syntax-case #'name ()
|
||||
[(child parent)
|
||||
(let ([v (syntax-local-value #'parent (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'parent))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(cadddr v)))]
|
||||
[else '()])])
|
||||
[super-refs (let ([super (cadr names)])
|
||||
(if (identifier? super)
|
||||
(let ([v (syntax-local-value super (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type"
|
||||
stx super))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(cadddr v)))
|
||||
null))]
|
||||
[super-muts (let ([super (cadr names)])
|
||||
(if (identifier? super)
|
||||
(let ([v (syntax-local-value super (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type"
|
||||
stx super))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(car (cddddr v))))
|
||||
null))])
|
||||
(let-values ([(non-auto-fields auto-fields)
|
||||
(let loop ([fields field-infos]
|
||||
[nautos null]
|
||||
|
|
@ -285,66 +298,120 @@
|
|||
(field-info-stx (car fields)))))))])
|
||||
(with-syntax ([ctc-bindings
|
||||
(if (s-info-def-vals? sinfo)
|
||||
(map list (cddr names)
|
||||
(map list (cdddr names)
|
||||
ctcs)
|
||||
null)]
|
||||
[orig stx]
|
||||
[struct-name (syntax-case #'name ()
|
||||
[id (identifier? #'id) #'id]
|
||||
[(id1 super) #'id1])]
|
||||
[struct-name (car names)]
|
||||
[(auto-check ...)
|
||||
(let* ([av-stx (if (s-info-auto-value-stx sinfo)
|
||||
(s-info-auto-value-stx sinfo)
|
||||
#'#f)]
|
||||
[av-id (datum->syntax av-stx
|
||||
(string->symbol
|
||||
(string-append (syntax-case #'name ()
|
||||
[id (identifier? #'id)
|
||||
(symbol->string (syntax-e #'id))]
|
||||
[(id1 super)
|
||||
(symbol->string (syntax-e #'id1))])
|
||||
(string-append (symbol->string (syntax-e (car names)))
|
||||
":auto-value"))
|
||||
av-stx)])
|
||||
(for/list ([finfo auto-fields])
|
||||
#`(let ([#,av-id #,av-stx])
|
||||
(contract #,(field-info-ctc finfo)
|
||||
#,av-id
|
||||
'(struct name)
|
||||
'(struct #,(car names))
|
||||
'cant-happen
|
||||
(quote #,av-id)
|
||||
(quote-srcloc #,av-id)))))]
|
||||
;; a list of variables, one for each super field
|
||||
[(super-fields ...) (generate-temporaries super-fields)]
|
||||
[(super-field ...) (generate-temporaries super-refs)]
|
||||
;; the contract for a super field is any/c becuase the
|
||||
;; super constructor will have its own contract
|
||||
[(super-contracts ...) (for/list ([i (in-list super-fields)])
|
||||
(datum->syntax stx 'any/c))]
|
||||
[(super-contract ...) (for/list ([i (in-list super-refs)])
|
||||
(datum->syntax stx 'any/c))]
|
||||
[(non-auto-contracts ...)
|
||||
(map field-info-ctc
|
||||
(filter (lambda (f)
|
||||
(not (field-info-auto? f)))
|
||||
field-infos))]
|
||||
;; the make-foo function. this is used to make the contract
|
||||
;; print the right name in the blame
|
||||
[maker (caddr names)]
|
||||
[(struct: maker pred (ref ...) (mut ...) super)
|
||||
(let-values ([(refs muts)
|
||||
(let loop ([names (cdr (cddddr names))]
|
||||
[infos field-infos]
|
||||
[refs null]
|
||||
[muts null])
|
||||
(cond
|
||||
[(null? names)
|
||||
;; Don't reverse
|
||||
(values refs muts)]
|
||||
[(field-info-mutable? (car infos))
|
||||
(loop (cddr names)
|
||||
(cdr infos)
|
||||
(cons (car names) refs)
|
||||
(cons (cadr names) muts))]
|
||||
[else
|
||||
(loop (cdr names)
|
||||
(cdr infos)
|
||||
(cons (car names) refs)
|
||||
(cons #f muts))]))])
|
||||
(list (caddr names)
|
||||
(cadddr names)
|
||||
(car (cddddr names))
|
||||
refs
|
||||
muts
|
||||
(cadr names)))]
|
||||
[(non-auto-name ...)
|
||||
(map field-info-stx non-auto-fields)])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values () (begin auto-check ... (values)))
|
||||
(define (guard super-fields ... non-auto-name ... struct-name)
|
||||
(values super-fields ... non-auto-name ...))
|
||||
(define blame-id
|
||||
(current-contract-region))
|
||||
(with-contract #:region struct struct-name
|
||||
ctc-bindings
|
||||
(define-struct/derived orig name (field ...)
|
||||
kwds ...
|
||||
#:guard (contract (-> super-contracts ... non-auto-contracts ... symbol? any)
|
||||
guard
|
||||
(current-contract-region) blame-id
|
||||
(quote maker)
|
||||
(quote-srcloc maker))))))))))]
|
||||
(with-syntax ([(stx-def ...)
|
||||
(let ([quoter
|
||||
(λ (s)
|
||||
(if (identifier? s)
|
||||
#`(quote-syntax #,s)
|
||||
#'#f))])
|
||||
(cond
|
||||
[(not (s-info-def-stxs? sinfo))
|
||||
null]
|
||||
[(s-info-def-vals? sinfo)
|
||||
(list
|
||||
#`(define-syntax struct-name
|
||||
(make-struct-info
|
||||
(λ ()
|
||||
(list #,(quoter #'struct:)
|
||||
#,(quoter #'maker)
|
||||
#,(quoter #'pred)
|
||||
(list* #,@(map quoter (syntax->list #'(ref ...)))
|
||||
(list #,@(map quoter super-refs)))
|
||||
(list* #,@(map quoter (syntax->list #'(mut ...)))
|
||||
(list #,@(map quoter super-muts)))
|
||||
#,(quoter #'super))))))]
|
||||
[else
|
||||
(list
|
||||
#'(define-syntax struct-name
|
||||
(make-struct-info
|
||||
(λ ()
|
||||
(list #f #f #f
|
||||
(list #f) (list #f)
|
||||
#,(quoter #'super))))))]))]
|
||||
[(omit-stx-def ...)
|
||||
(if (s-info-def-stxs? sinfo)
|
||||
(list '#:omit-define-syntaxes)
|
||||
null)])
|
||||
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values () (begin auto-check ... (values)))
|
||||
stx-def ...
|
||||
(define (guard super-field ... non-auto-name ... struct-name)
|
||||
(values super-field ... non-auto-name ...))
|
||||
(define blame-id
|
||||
(current-contract-region))
|
||||
(with-contract #:region struct struct-name
|
||||
ctc-bindings
|
||||
(define-struct/derived orig name (field ...)
|
||||
omit-stx-def ...
|
||||
kwds ...
|
||||
#:guard (contract (-> super-contract ... non-auto-contracts ... symbol? any)
|
||||
guard
|
||||
(current-contract-region) blame-id
|
||||
(quote maker)
|
||||
(quote-srcloc maker)))))))))))]
|
||||
[(_ name . bad-fields)
|
||||
(identifier? #'name)
|
||||
(syntax-error "expected a list of field name/contract pairs"
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@
|
|||
(namespace-require 'scheme/contract)
|
||||
(namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?))
|
||||
(namespace-require 'scheme/class)
|
||||
(namespace-require 'scheme/promise))
|
||||
(namespace-require 'scheme/promise)
|
||||
(namespace-require 'scheme/match))
|
||||
n))
|
||||
|
||||
(define (contract-eval x)
|
||||
|
|
@ -2859,6 +2860,23 @@
|
|||
#:mutable #:transparent
|
||||
#:property prop:custom-write
|
||||
(lambda (a b c) (void))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'define-struct/contract24
|
||||
'(let ()
|
||||
(define-struct/contract point
|
||||
([x number?] [y number?])
|
||||
#:transparent)
|
||||
(define-struct/contract (color-point point)
|
||||
([c symbol?])
|
||||
#:transparent)
|
||||
|
||||
(match (make-color-point 1 2 'red)
|
||||
[(struct color-point [dx dy color])
|
||||
(list dx dy color)]
|
||||
[(struct point [dx dy]) (list dx dy)]
|
||||
[v (box v)]))
|
||||
(list 1 2 'red))
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user