From 4336f292731d7a2f3e3566a3d3aa08c5117143f0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 18 May 2010 11:37:49 -0400 Subject: [PATCH] Quick fix to get the right struct info out of define-struct/contract. Closes PR 10526. Closes PR 10561. --- collects/racket/contract/regions.rkt | 149 ++++++++++++++++------- collects/tests/racket/contract-test.rktl | 20 ++- 2 files changed, 127 insertions(+), 42 deletions(-) diff --git a/collects/racket/contract/regions.rkt b/collects/racket/contract/regions.rkt index 28f6e63b8c..d958333dad 100644 --- a/collects/racket/contract/regions.rkt +++ b/collects/racket/contract/regions.rkt @@ -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" diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 74b89909a6..abeb89be57 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -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)) ; ; ;