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

Quick fix to get the right struct info out of define-struct/contract.

Browse Source 
Closes PR 10526.  Closes PR 10561.
This commit is contained in:
Stevie Strickland 2010-05-18 11:37:49 -04:00
parent ed1c74108f
commit 4336f29273
2 changed files with 127 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

149
collects/racket/contract/regions.rkt
View File

@ -112,6 +112,9 @@
(syntax-case name () (syntax-case name ()
[id (identifier? #'id) #'id] [id (identifier? #'id) #'id]
[(sub super) #'sub]) [(sub super) #'sub])
(syntax-case name ()
[id (identifier? #'id) #'#f]
[(sub super) #'super])
(datum->syntax (datum->syntax
name name
(string->symbol (string->symbol
@ -256,16 +259,26 @@
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))] (let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)] [sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
[names (build-struct-names #'name field-infos)] [names (build-struct-names #'name field-infos)]
[pred (cadddr names)] [pred (car (cddddr names))]
[ctcs (build-contracts stx pred field-infos)] [ctcs (build-contracts stx pred field-infos)]
[super-fields (syntax-case #'name () [super-refs (let ([super (cadr names)])
[(child parent) (if (identifier? super)
(let ([v (syntax-local-value #'parent (lambda () #f))]) (let ([v (syntax-local-value super (lambda () #f))])
(unless (struct-info? v) (unless (struct-info? v)
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'parent)) (raise-syntax-error #f "identifier is not bound to a structure type"
(let ([v (extract-struct-info v)]) stx super))
(cadddr v)))] (let ([v (extract-struct-info v)])
[else '()])]) (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-values ([(non-auto-fields auto-fields)
(let loop ([fields field-infos] (let loop ([fields field-infos]
[nautos null] [nautos null]
@ -285,66 +298,120 @@
(field-info-stx (car fields)))))))]) (field-info-stx (car fields)))))))])
(with-syntax ([ctc-bindings (with-syntax ([ctc-bindings
(if (s-info-def-vals? sinfo) (if (s-info-def-vals? sinfo)
(map list (cddr names) (map list (cdddr names)
ctcs) ctcs)
null)] null)]
[orig stx] [orig stx]
[struct-name (syntax-case #'name () [struct-name (car names)]
[id (identifier? #'id) #'id]
[(id1 super) #'id1])]
[(auto-check ...) [(auto-check ...)
(let* ([av-stx (if (s-info-auto-value-stx sinfo) (let* ([av-stx (if (s-info-auto-value-stx sinfo)
(s-info-auto-value-stx sinfo) (s-info-auto-value-stx sinfo)
#'#f)] #'#f)]
[av-id (datum->syntax av-stx [av-id (datum->syntax av-stx
(string->symbol (string->symbol
(string-append (syntax-case #'name () (string-append (symbol->string (syntax-e (car names)))
[id (identifier? #'id)
(symbol->string (syntax-e #'id))]
[(id1 super)
(symbol->string (syntax-e #'id1))])
":auto-value")) ":auto-value"))
av-stx)]) av-stx)])
(for/list ([finfo auto-fields]) (for/list ([finfo auto-fields])
#`(let ([#,av-id #,av-stx]) #`(let ([#,av-id #,av-stx])
(contract #,(field-info-ctc finfo) (contract #,(field-info-ctc finfo)
#,av-id #,av-id
'(struct name) '(struct #,(car names))
'cant-happen 'cant-happen
(quote #,av-id) (quote #,av-id)
(quote-srcloc #,av-id)))))] (quote-srcloc #,av-id)))))]
;; a list of variables, one for each super field ;; 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 ;; the contract for a super field is any/c becuase the
;; super constructor will have its own contract ;; super constructor will have its own contract
[(super-contracts ...) (for/list ([i (in-list super-fields)]) [(super-contract ...) (for/list ([i (in-list super-refs)])
(datum->syntax stx 'any/c))] (datum->syntax stx 'any/c))]
[(non-auto-contracts ...) [(non-auto-contracts ...)
(map field-info-ctc (map field-info-ctc
(filter (lambda (f) (filter (lambda (f)
(not (field-info-auto? f))) (not (field-info-auto? f)))
field-infos))] field-infos))]
;; the make-foo function. this is used to make the contract [(struct: maker pred (ref ...) (mut ...) super)
;; print the right name in the blame (let-values ([(refs muts)
[maker (caddr names)] (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 ...) [(non-auto-name ...)
(map field-info-stx non-auto-fields)]) (map field-info-stx non-auto-fields)])
(syntax/loc stx (with-syntax ([(stx-def ...)
(begin (let ([quoter
(define-values () (begin auto-check ... (values))) (λ (s)
(define (guard super-fields ... non-auto-name ... struct-name) (if (identifier? s)
(values super-fields ... non-auto-name ...)) #`(quote-syntax #,s)
(define blame-id #'#f))])
(current-contract-region)) (cond
(with-contract #:region struct struct-name [(not (s-info-def-stxs? sinfo))
ctc-bindings null]
(define-struct/derived orig name (field ...) [(s-info-def-vals? sinfo)
kwds ... (list
#:guard (contract (-> super-contracts ... non-auto-contracts ... symbol? any) #`(define-syntax struct-name
guard (make-struct-info
(current-contract-region) blame-id (λ ()
(quote maker) (list #,(quoter #'struct:)
(quote-srcloc maker))))))))))] #,(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) [(_ name . bad-fields)
(identifier? #'name) (identifier? #'name)
(syntax-error "expected a list of field name/contract pairs" (syntax-error "expected a list of field name/contract pairs"

20
collects/tests/racket/contract-test.rktl
View File

@ -13,7 +13,8 @@
(namespace-require 'scheme/contract) (namespace-require 'scheme/contract)
(namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?)) (namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?))
(namespace-require 'scheme/class) (namespace-require 'scheme/class)
(namespace-require 'scheme/promise)) (namespace-require 'scheme/promise)
(namespace-require 'scheme/match))
n)) n))
(define (contract-eval x) (define (contract-eval x)
@ -2859,6 +2860,23 @@
#:mutable #:transparent #:mutable #:transparent
#:property prop:custom-write #:property prop:custom-write
(lambda (a b c) (void)))) (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))
; ;
; ;
; ;