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

add the ability to specify #:parent to struct/dc (and fix struct/c to use it)

Browse Source 
closes PR 13049
This commit is contained in:
Robby Findler 2012-08-23 18:12:47 -05:00
parent 0233c5a14f
commit 1ad2c75531
3 changed files with 220 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

231
collects/racket/contract/private/struct-dc.rkt
View File

@ -85,9 +85,10 @@
;; sel-id : identifier? ;; sel-id : identifier?
;; type : (or/c '#:flat '#:chaperone '#:impersonator) ;; type : (or/c '#:flat '#:chaperone '#:impersonator)
;; depends-on-state? : boolean? -- only set if the keyword #:depends-on-state is passed ;; depends-on-state? : boolean? -- only set if the keyword #:depends-on-state is passed
;; deps : (listof identifier?) ;; dep-ids : (listof identifier?) -- the dependened on selector
(struct clause (exp lazy? sel-id) #:transparent) ;; dep-name : (listof syntax?) -- the user's notation for the depended-on fields
(struct dep-clause clause (type depends-on-state? deps) #:transparent) (struct clause (exp lazy? sel-name sel-id) #:transparent)
(struct dep-clause clause (type depends-on-state? dep-names dep-ids) #:transparent)
(struct indep-clause clause () #:transparent)) (struct indep-clause clause () #:transparent))
(define-syntax-rule (define-syntax-rule
@ -490,14 +491,14 @@
[(_ id clauses ...) [(_ id clauses ...)
(let () (let ()
(define info (get-struct-info #'id stx)) (define info (get-struct-info #'id stx))
(define (ensure-valid-field sel-id) (define (ensure-valid-field sel-name)
(define selector-candidate (id->sel-id #'id sel-id)) (define selector-candidate (name->sel-id #'id sel-name))
(unless (for/or ([selector (in-list (list-ref info 3))]) (unless (for/or ([selector (in-list (list-ref info 3))])
(and selector (free-identifier=? selector-candidate selector))) (and selector (free-identifier=? selector-candidate selector)))
(raise-syntax-error #f (raise-syntax-error #f
"expected an identifier that names a field" "expected an identifier that names a field or a sequence with a field name, the #:parent keyword, and the parent struct"
stx stx
sel-id))) sel-name)))
(define (check-not-both this that) (define (check-not-both this that)
(when (and this that) (when (and this that)
@ -509,17 +510,31 @@
that that
(list this)))) (list this))))
(define (sel-name? stx)
(syntax-case stx ()
[sel-id
(identifier? #'sel-id)
#t]
[(sel-id #:parent struct-id)
(and (identifier? #'sel-id)
(identifier? #'struct-id))
#t]
[_else #f]))
(define not-field-name-str "expected a field-name (either an identifier or a sequence: (selector-id #:parent struct-id))")
(define parsed-clauses (define parsed-clauses
(for/list ([clause (in-list (syntax->list #'(clauses ...)))]) (for/list ([clause (in-list (syntax->list #'(clauses ...)))])
(syntax-case clause () (syntax-case clause ()
[(sel-id (dep-id ...) stuff1 . stuff) ;; need stuff1 here so that things like [a (>=/c x)] do not fall into this case [(sel-name (dep-name ...) stuff1 . stuff) ;; need stuff1 here so that things like [a (>=/c x)] do not fall into this case
(sel-name? #'sel-name)
(let () (let ()
(unless (identifier? #'sel-id) (unless (sel-name? #'sel-name)
(raise-syntax-error #f "expected an identifier (naming a field)" stx #'sel-id)) (raise-syntax-error #f not-field-name-str stx #'sel-name))
(for ([id (in-list (syntax->list #'(dep-id ...)))]) (for ([name (in-list (syntax->list #'(dep-name ...)))])
(unless (identifier? id) (unless (sel-name? name)
(raise-syntax-error #f "expected an identifier (naming a field)" stx id))) (raise-syntax-error #f not-field-name-str stx name)))
(ensure-valid-field #'sel-id) (ensure-valid-field #'sel-name)
(define-values (ctc-exp lazy? type depends-on-state?) (define-values (ctc-exp lazy? type depends-on-state?)
(let loop ([stuff #'(stuff1 . stuff)] (let loop ([stuff #'(stuff1 . stuff)]
[lazy? #f] [lazy? #f]
@ -536,21 +551,23 @@
[(#:lazy . more-stuff) (loop #'more-stuff #t type depends-on-state?)] [(#:lazy . more-stuff) (loop #'more-stuff #t type depends-on-state?)]
[_ (raise-syntax-error #f "could not parse clause" stx clause)]))) [_ (raise-syntax-error #f "could not parse clause" stx clause)])))
(dep-clause ctc-exp lazy? (dep-clause ctc-exp lazy?
#'sel-id #'sel-name (name->sel-id #'id #'sel-name)
(if type (syntax-e type) '#:chaperone) (if type (syntax-e type) '#:chaperone)
depends-on-state? depends-on-state?
(syntax->list #'(dep-id ...))))] (syntax->list #'(dep-name ...))
[(sel-id . rest) (map (λ (name) (name->sel-id #'id name))
(syntax->list #'(dep-name ...)))))]
[(sel-name . rest)
(let () (let ()
(unless (identifier? #'sel-id) (unless (sel-name? #'sel-name)
(raise-syntax-error #f "expected an identifier (naming a field)" stx #'sel-id)) (raise-syntax-error #f not-field-name-str stx #'sel-name))
(ensure-valid-field #'sel-id) (ensure-valid-field #'sel-name)
(define-values (lazy? exp) (define-values (lazy? exp)
(syntax-case #'rest () (syntax-case #'rest ()
[(#:lazy exp) (values #t #'exp)] [(#:lazy exp) (values #t #'exp)]
[(exp) (values #f #'exp)] [(exp) (values #f #'exp)]
[else (raise-syntax-error #f "could not parse clause" stx clause)])) [else (raise-syntax-error #f "could not parse clause" stx clause)]))
(indep-clause exp lazy? #'sel-id))] (indep-clause exp lazy? #'sel-name (name->sel-id #'id #'sel-name)))]
[_ (raise-syntax-error #f "could not parse clause" stx #'clause)]))) [_ (raise-syntax-error #f "could not parse clause" stx #'clause)])))
@ -565,36 +582,37 @@
(for ([clause (in-list parsed-clauses)]) (for ([clause (in-list parsed-clauses)])
(when (dep-clause? clause) (when (dep-clause? clause)
(unless (clause-lazy? clause) (unless (clause-lazy? clause)
(for ([dep-id (in-list (dep-clause-deps clause))]) (for ([dep-id (in-list (dep-clause-dep-ids clause))]
[dep-name (in-list (dep-clause-dep-names clause))])
(when (free-identifier-mapping-get lazy-mapping dep-id) (when (free-identifier-mapping-get lazy-mapping dep-id)
(raise-syntax-error (raise-syntax-error
#f #f
(format "the dependent clause for ~a is not lazy, but depends on ~a" (format "the dependent clause for ~a is not lazy, but depends on ~a"
(syntax-e (clause-sel-id clause)) (syntax->datum (clause-sel-name clause))
(syntax-e dep-id)) (syntax->datum dep-name))
stx stx
dep-id)))))) dep-id))))))
(for ([clause (in-list parsed-clauses)]) (for ([clause (in-list parsed-clauses)])
(define this-sel (id->sel-id #'id (clause-sel-id clause))) (define this-sel (clause-sel-id clause))
(for ([sel (in-list (list-ref info 3))] (for ([sel (in-list (list-ref info 3))]
[mut (in-list (list-ref info 4))]) [mut (in-list (list-ref info 4))])
(when (and sel (when (and sel
(free-identifier=? sel this-sel)) (free-identifier=? sel this-sel))
;; check that fields depended on actually exist ;; check that fields depended on actually exist
(when (dep-clause? clause) (when (dep-clause? clause)
(for ([id (in-list (dep-clause-deps clause))]) (for ([id (in-list (dep-clause-dep-ids clause))]
[dep-name (in-list (dep-clause-dep-names clause))])
(free-identifier-mapping-get (free-identifier-mapping-get
lazy-mapping lazy-mapping
id id
(λ () (raise-syntax-error #f (λ () (raise-syntax-error #f
(format "the field: ~a is depended on (by the contract on the field: ~a), but it has no contract" (format "the field: ~s is depended on (by the contract on the field: ~s), but it has no contract"
(syntax-e id) (syntax->datum dep-name)
(syntax-e (clause-sel-id clause))) (syntax->datum (clause-sel-name clause)))
stx stx
(clause-sel-id clause)))))) (clause-sel-name clause))))))
;; check that impersonator fields are mutable ;; check that impersonator fields are mutable
(when (and (dep-clause? clause) (when (and (dep-clause? clause)
@ -602,27 +620,38 @@
(unless mut (unless mut
(raise-syntax-error #f (raise-syntax-error #f
(format "the ~a field is immutable, so the contract cannot be an impersonator contract" (format "the ~a field is immutable, so the contract cannot be an impersonator contract"
(syntax-e (clause-sel-id clause))) (syntax-e (clause-sel-name clause)))
stx stx
(clause-sel-id clause)))) (clause-sel-name clause))))
;; check that mutable fields aren't lazy ;; check that mutable fields aren't lazy
(when (and (clause-lazy? clause) mut) (when (and (clause-lazy? clause) mut)
(raise-syntax-error #f (raise-syntax-error #f
(format "the ~a field is mutable, so the contract cannot be lazy" (format "the ~s field is mutable, so the contract cannot be lazy"
(syntax-e (clause-sel-id clause))) (syntax->datum (clause-sel-name clause)))
stx stx
(clause-sel-id clause))))))) (clause-sel-name clause)))))))
(values info #'id parsed-clauses))])) (values info #'id parsed-clauses))]))
(define-for-syntax (id->sel-id struct-id id) ;; name->sel-id : identifier syntax -> identifier
(datum->syntax ;; returns the identifier for the selector, where the 'id'
id ;; argument is either an identifier or a #'(id #:parent id)
(string->symbol ;; configuration (something else must check this is a valid id)
(format "~a-~a" (define-for-syntax (name->sel-id struct-id id)
(syntax-e struct-id) (define (combine struct-id id)
(syntax-e id))))) (datum->syntax
id
(string->symbol
(format "~a-~a"
(syntax-e struct-id)
(syntax-e id)))))
(syntax-case id ()
[x
(identifier? #'x)
(combine struct-id id)]
[(sel-id #:parent parent-id)
(combine #'parent-id #'sel-id)]))
(define-for-syntax (top-sort/clauses stx clauses) (define-for-syntax (top-sort/clauses stx clauses)
(define id->children (make-free-identifier-mapping)) (define id->children (make-free-identifier-mapping))
@ -634,7 +663,7 @@
(define (neighbors x) (define (neighbors x)
(cond (cond
[(dep-clause? x) [(dep-clause? x)
(for/list ([id (in-list (dep-clause-deps x))]) (for/list ([id (in-list (dep-clause-dep-ids x))])
(free-identifier-mapping-get id->children id (free-identifier-mapping-get id->children id
(λ () (λ ()
(raise-syntax-error #f "unknown clause" stx id))))] (raise-syntax-error #f "unknown clause" stx id))))]
@ -665,15 +694,9 @@
;; find-selector/mutator : clause -> (values identifier? identifier?) ;; find-selector/mutator : clause -> (values identifier? identifier?)
;; this probably goes away
(define (find-selector/mutator clause) (define (find-selector/mutator clause)
(define fld-name (clause-sel-id clause)) (define this-selector (clause-sel-id clause))
(define this-selector
(datum->syntax fld-name
(string->symbol
(string-append
(symbol->string (syntax-e struct-id))
"-"
(symbol->string (syntax-e fld-name))))))
(define mutator (for/or ([selector (in-list (list-ref info 3))] (define mutator (for/or ([selector (in-list (list-ref info 3))]
[mutator (in-list (list-ref info 4))]) [mutator (in-list (list-ref info 4))])
(and (free-identifier=? this-selector selector) (and (free-identifier=? this-selector selector)
@ -686,7 +709,7 @@
(free-identifier-mapping-put! mutable-clauses (clause-sel-id clause) (and mut #t)) (free-identifier-mapping-put! mutable-clauses (clause-sel-id clause) (and mut #t))
(free-identifier-mapping-put! sel-id->clause (clause-sel-id clause) clause) (free-identifier-mapping-put! sel-id->clause (clause-sel-id clause) clause)
(when (dep-clause? clause) (when (dep-clause? clause)
(for ([var (in-list (dep-clause-deps clause))]) (for ([var (in-list (dep-clause-dep-ids clause))])
(free-identifier-mapping-put! depended-on-clauses var #t)))) (free-identifier-mapping-put! depended-on-clauses var #t))))
;; init the dep-on-mutable-clauses mapping ;; init the dep-on-mutable-clauses mapping
@ -700,7 +723,7 @@
(or (free-identifier-mapping-get mutable-clauses sel-id) (or (free-identifier-mapping-get mutable-clauses sel-id)
(and (dep-clause? clause) (and (dep-clause? clause)
(or (dep-clause-depends-on-state? clause) (or (dep-clause-depends-on-state? clause)
(for/or ([dep (in-list (dep-clause-deps clause))]) (for/or ([dep (in-list (dep-clause-dep-ids clause))])
(loop (free-identifier-mapping-get sel-id->clause dep))))))) (loop (free-identifier-mapping-get sel-id->clause dep)))))))
(free-identifier-mapping-put! dep-on-mutable-clauses sel-id ans) (free-identifier-mapping-put! dep-on-mutable-clauses sel-id ans)
ans] ans]
@ -722,8 +745,9 @@
(raise-syntax-error (raise-syntax-error
#f #f
(format "the contract on field ~a depends on mutable state (possibly indirectly), so cannot be lazy" (format "the contract on field ~a depends on mutable state (possibly indirectly), so cannot be lazy"
(syntax-e (clause-sel-id clause))) (syntax->datum (clause-sel-name clause)))
stx (clause-sel-id clause)) stx
(clause-sel-name clause))
(if mutator (if mutator
#'dep-on-state-mutable #'dep-on-state-mutable
#'dep-on-state-immutable)) #'dep-on-state-immutable))
@ -742,20 +766,27 @@
(clause-sel-id clause) (clause-sel-id clause)
(λ () #f))) (λ () #f)))
(define subcontract-args (define subcontract-args
(list #`'#,(clause-sel-id clause) selector depended-on?)) (list #`'#,(clause-sel-name clause) selector depended-on?))
(define indep/dep-args (define indep/dep-args
(if (dep-clause? clause) (if (dep-clause? clause)
(list #`(λ (#,@dep-args) #,(clause-exp clause)) (list #`(λ (#,@dep-args) #,(clause-exp clause))
#`'(#,@(reverse dep-args)) #`'(#,@(reverse dep-args))
#`'#,(dep-clause-type clause)) #`'#,(dep-clause-type clause))
(list #`(coerce-contract 'struct/dc #,(clause-exp clause))))) (list #`(coerce-contract 'struct/dc #,(clause-exp clause)))))
(define (get-id name)
(syntax-case name ()
[x
(identifier? #'x)
name]
[(x #:parent y)
#'x]))
(cons #`(#,subcontract-constructor #,@subcontract-args (cons #`(#,subcontract-constructor #,@subcontract-args
#,@indep/dep-args #,@indep/dep-args
#,@(if mutator #,@(if mutator
(list mutator) (list mutator)
'())) '()))
(loop (if depended-on? (loop (if depended-on?
(cons (clause-sel-id clause) dep-args) (cons (get-id (clause-sel-name clause)) dep-args)
dep-args) dep-args)
(cdr clauses)))]))) (cdr clauses)))])))
@ -793,7 +824,7 @@
(loop id (cons parent-id path))]))) (loop id (cons parent-id path))])))
(set-box! bx ans) (set-box! bx ans)
ans])))) ans]))))
(define/opter (-struct/dc opt/i opt/info stx) (define/opter (-struct/dc opt/i opt/info stx)
(syntax-case stx () (syntax-case stx ()
[(_ struct-id clause ...) [(_ struct-id clause ...)
@ -820,7 +851,7 @@
[no-negative-blame #t]) [no-negative-blame #t])
([clause (in-list (syntax->list #'(clause ...)))]) ([clause (in-list (syntax->list #'(clause ...)))])
(define-values (sel-id lazy? dep-vars exp) (define-values (sel-name lazy? dep-names exp)
(syntax-case clause () (syntax-case clause ()
[(sel-id #:lazy exp) (values #'sel-id #t #f #'exp)] [(sel-id #:lazy exp) (values #'sel-id #t #f #'exp)]
[(sel-id exp) (values #'sel-id #f #f #'exp)] [(sel-id exp) (values #'sel-id #f #f #'exp)]
@ -836,17 +867,24 @@
(define this-optres (opt/i (opt/info-change-val sub-val opt/info) exp)) (define this-optres (opt/i (opt/info-change-val sub-val opt/info) exp))
(when dep-vars (define sel-id (name->sel-id #'struct-id sel-name))
(for ([dep-var (in-list (syntax->list dep-vars))])
(when dep-names
(for ([dep-name (in-list (syntax->list dep-names))])
(define dep-var (name->sel-id #'struct-id dep-name))
(free-identifier-mapping-put! depended-on-fields dep-var sel-id))) (free-identifier-mapping-put! depended-on-fields dep-var sel-id)))
(free-identifier-mapping-put! no-negative-blame-fields sel-id (optres-no-negative-blame? this-optres)) (free-identifier-mapping-put! no-negative-blame-fields sel-id (optres-no-negative-blame? this-optres))
(define this-body-code (define this-body-code
(cond (cond
[dep-vars [dep-names
(with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var)) (with-syntax ([(sel ...) (map (λ (var) (name->sel-id #'struct-id var))
(syntax->list dep-vars))] (syntax->list dep-names))]
[(dep-var ...) dep-vars]) [(dep-var ...) (map (λ (x)
(syntax-case x ()
[x (identifier? #'x) #'x]
[(x #:parent y) #'x]))
(syntax->list dep-names))])
#`(let ([dep-var (sel #,(opt/info-val opt/info))] ...) #`(let ([dep-var (sel #,(opt/info-val opt/info))] ...)
#,(bind-superlifts #,(bind-superlifts
(optres-superlifts this-optres) (optres-superlifts this-optres)
@ -860,17 +898,14 @@
(define this-chap-code (define this-chap-code
(and (or (not (optres-flat this-optres)) (and (or (not (optres-flat this-optres))
lazy?) lazy?)
(with-syntax ([proc-name (string->symbol (with-syntax ([proc-name (string->symbol (format "~a-chap" sel-id))])
(format "~a-~a-chap"
(syntax-e #'struct-id)
(syntax-e sel-id)))])
(if lazy? (if lazy?
#`(let ([proc-name #`(let ([proc-name
(cache-λ (strct #,sub-val) (cache-λ (strct #,sub-val)
#,this-body-code)]) #,this-body-code)])
proc-name) proc-name)
#`(let ([answer (let ([#,sub-val #`(let ([answer (let ([#,sub-val
(#,(id->sel-id #'struct-id sel-id) (#,sel-id
#,(opt/info-val opt/info))]) #,(opt/info-val opt/info))])
#,this-body-code)]) #,this-body-code)])
(let ([proc-name (λ (strct fld) answer)]) (let ([proc-name (λ (strct fld) answer)])
@ -880,7 +915,7 @@
(and (and (optres-flat this-optres) (and (and (optres-flat this-optres)
(not lazy?)) (not lazy?))
#`(let ([#,sub-val #`(let ([#,sub-val
(#,(id->sel-id #'struct-id sel-id) (#,sel-id
#,(opt/info-val opt/info))]) #,(opt/info-val opt/info))])
#,this-body-code))) #,this-body-code)))
@ -888,13 +923,13 @@
(cons this-fo-code s-fo-code) (cons this-fo-code s-fo-code)
s-fo-code) s-fo-code)
(if this-chap-code (if this-chap-code
(list* this-chap-code (id->sel-id #'struct-id sel-id) s-chap-code) (list* this-chap-code sel-id s-chap-code)
s-chap-code) s-chap-code)
(if dep-vars s-lifts (append (optres-lifts this-optres) s-lifts)) (if dep-names s-lifts (append (optres-lifts this-optres) s-lifts))
(if dep-vars s-super-lifts (append (optres-superlifts this-optres) s-super-lifts)) (if dep-names s-super-lifts (append (optres-superlifts this-optres) s-super-lifts))
(if dep-vars s-partially-applied (append (optres-partials this-optres) s-partially-applied)) (if dep-names s-partially-applied (append (optres-partials this-optres) s-partially-applied))
(and (optres-opt this-optres) can-be-optimized?) (and (optres-opt this-optres) can-be-optimized?)
(if dep-vars stronger-ribs (append (optres-stronger-ribs this-optres) stronger-ribs)) (if dep-names stronger-ribs (append (optres-stronger-ribs this-optres) stronger-ribs))
(combine-two-chaperone?s chaperone? (optres-chaperone this-optres)) (combine-two-chaperone?s chaperone? (optres-chaperone this-optres))
(combine-two-no-negative-blame no-negative-blame (optres-no-negative-blame? this-optres))))) (combine-two-no-negative-blame no-negative-blame (optres-no-negative-blame? this-optres)))))
@ -970,7 +1005,7 @@
[(_ struct-name args ...) [(_ struct-name args ...)
(and (identifier? (syntax struct-name)) (and (identifier? (syntax struct-name))
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f)))) (struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
(let* ([si (extract-struct-info (syntax-local-value (syntax struct-name)))] (let* ([si (extract-struct-info (syntax-local-value #'struct-name))]
[predicate-id (third si)] [predicate-id (third si)]
[selector-ids (reverse (fourth si))] [selector-ids (reverse (fourth si))]
[mutator-ids (reverse (fifth si))] [mutator-ids (reverse (fifth si))]
@ -992,14 +1027,44 @@
(format "could not determine selectors for ~s" (syntax-e #'struct-name)) (format "could not determine selectors for ~s" (syntax-e #'struct-name))
stx)) stx))
(define strip-reg (regexp (format "^~a-" (regexp-quote (symbol->string (syntax-e #'struct-name)))))) (define (selector-id->field sel i)
(define (selector-id->field sel) (define candidate
(datum->syntax sel (let loop ([struct-id #'struct-name])
(string->symbol (regexp-replace strip-reg (symbol->string (syntax-e sel)) "")))) (cond
[(identifier? struct-id)
(define si (extract-struct-info (syntax-local-value struct-id)))
(define si-parent (sixth si))
(cond
[(loop si-parent) => values]
[else
(define si-selectors (fourth si))
(cond
[(ormap (λ (x) (and x (free-identifier=? x sel)))
si-selectors)
(define strip-reg (regexp (format "^~a-" (regexp-quote (symbol->string (syntax-e struct-id))))))
(define field-name
(datum->syntax sel
(string->symbol (regexp-replace strip-reg (symbol->string (syntax-e sel)) ""))))
(cond
[(free-identifier=? #'struct-name struct-id)
field-name]
[else
#`(#,field-name #:parent #,struct-id)])]
[else #f])])]
[else #f])))
(unless candidate
(raise-syntax-error 'struct/c
(format "could not determine selector id for field ~a (counting from 0)"
i)
stx
sel))
candidate)
(do-struct/dc (do-struct/dc
#t #t
(with-syntax ([(fields ...) (map selector-id->field selector-ids)]) (with-syntax ([(fields ...) (for/list ([selector-id (in-list selector-ids)]
[i (in-naturals)])
(selector-id->field selector-id i))])
#`(-struct/dc struct-name [fields args] ...))))] #`(-struct/dc struct-name [fields args] ...))))]
[(_ struct-name anything ...) [(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))

17
collects/scribblings/reference/contracts.scrbl
View File

@ -390,12 +390,14 @@ produced. Otherwise, an impersonator contract is produced.
@defform/subs[(struct/dc struct-id field-spec ...) @defform/subs[(struct/dc struct-id field-spec ...)
([field-spec [field-id maybe-lazy contract-expr] ([field-spec [field-name maybe-lazy contract-expr]
[field-id (dep-field-id ...) [field-name (dep-field-name ...)
maybe-lazy maybe-lazy
maybe-flat-or-impersonator maybe-flat-or-impersonator
maybe-dep-state maybe-dep-state
contract-expr]] contract-expr]]
[field-name field-id
(field-id #:parent struct-id)]
[maybe-lazy (code:line) #:lazy] [maybe-lazy (code:line) #:lazy]
[maybe-flat-or-impersonator (code:line) #:flat #:impersonator] [maybe-flat-or-impersonator (code:line) #:flat #:impersonator]
[maybe-dep-state (code:line) #:depends-on-state])]{ [maybe-dep-state (code:line) #:depends-on-state])]{
@ -406,7 +408,8 @@ contracts produced by the @racket[field-spec]s.
If the @racket[field-spec] lists the names of other fields, If the @racket[field-spec] lists the names of other fields,
then the contract depends on values in those fields, and the @racket[contract-expr] then the contract depends on values in those fields, and the @racket[contract-expr]
expression is evaluated each time a selector is applied, building a new contract expression is evaluated each time a selector is applied, building a new contract
for the fields based on the values of the @racket[dep-field-id] fields. for the fields based on the values of the @racket[dep-field-name] fields (the
@racket[dep-field-name] syntax is the same as the @racket[field-name] syntax).
If the field is a dependent field, then it is assumed that the contract is If the field is a dependent field, then it is assumed that the contract is
a chaperone, but not always a flat contract (and theus the entire @racket[struct/dc] a chaperone, but not always a flat contract (and theus the entire @racket[struct/dc]
contract is not a flat contract). contract is not a flat contract).

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

@ -9441,6 +9441,32 @@
(define v (make-s 3)) (define v (make-s 3))
(let ([v* (contract (struct/c s alpha) v 'pos 'neg)]) (let ([v* (contract (struct/c s alpha) v 'pos 'neg)])
(set-s-a! v* 4)))) (set-s-a! v* 4))))
(test/spec-passed/result
'struct/c14
'(let ()
(struct heap (v))
(struct heap-node heap ())
(heap-v (contract (struct/c heap-node number?)
(heap-node 11)
'pos
'neg)))
11)
(test/spec-passed/result
'struct/c15
'(let ()
(struct a (x))
(struct b a (y))
(struct c b (z))
(struct d c (w))
(b-y (contract (struct/c d number? number? number? number?)
(d 11 22 33 44)
'pos
'neg)))
22)
; ;
@ -10164,6 +10190,42 @@
(s (λ (x) x) 1) (s (λ (x) x) 1)
'pos 'pos
'neg))) 'neg)))
(test/spec-passed/result
'struct/dc-new43
'(let ()
(struct a (x))
(struct b a (y))
(struct c b (z))
(struct d c (w))
(b-y (contract (struct/dc d
[(x #:parent a) boolean?]
[(y #:parent b) char?]
[(z #:parent c) number?]
[w string?])
(d #t #\a 3 "x")
'pos
'neg)))
#\a)
(test/spec-passed/result
'struct/dc-new44
'(let ()
(struct a (x))
(struct b a (y))
(struct c b (z))
(struct d c (w))
(b-y (contract (struct/dc d
[(x #:parent a) (w) boolean?]
[(y #:parent b) ((x #:parent a)) char?]
[(z #:parent c) number?]
[w string?])
(d #t #\a 3 "x")
'pos
'neg)))
#\a)
(contract-error-test (contract-error-test
'struct/dc-imp-nondep-runtime-error 'struct/dc-imp-nondep-runtime-error