diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt index 6e7bdac63b..12c32ead32 100644 --- a/collects/racket/contract/private/opt-guts.rkt +++ b/collects/racket/contract/private/opt-guts.rkt @@ -158,37 +158,30 @@ ;; opt/unknown : opt/i id id syntax ;; (define (opt/unknown opt/i opt/info uctc) - (let* ((lift-var (car (generate-temporaries (syntax (lift))))) - (partial-var (car (generate-temporaries (syntax (partial))))) - (partial-flat-var (car (generate-temporaries (syntax (partial-flat)))))) + (with-syntax ([(lift-var partial-var partial-flat-var) + (generate-temporaries '(lift partial partial-flat))] + [val (opt/info-val opt/info)] + [uctc uctc] + [blame (opt/info-blame opt/info)]) (values - (with-syntax ((partial-var partial-var) - (lift-var lift-var) - (uctc uctc) - (val (opt/info-val opt/info))) - (syntax (partial-var val))) - (list (cons lift-var - ;; FIXME needs to get the contract name somehow - (with-syntax ((uctc uctc)) - (syntax (coerce-contract 'opt/c uctc))))) + #'(partial-var val) + (list (cons #'lift-var + #'(coerce-contract 'opt/c uctc))) null (list (cons - partial-var - (with-syntax ((lift-var lift-var) - (blame (opt/info-blame opt/info))) - (syntax ((contract-projection lift-var) blame)))) + #'partial-var + #'((contract-projection lift-var) blame)) (cons - partial-flat-var - (with-syntax ((lift-var lift-var)) - (syntax (if (flat-contract? lift-var) - (flat-contract-predicate lift-var) - (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s" - lift-var - x))))))) + #'partial-flat-var + #'(if (flat-contract? lift-var) + (flat-contract-predicate lift-var) + (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s" + lift-var + x))))) #f - lift-var + #'lift-var null - #`(chaperone-contract? #,lift-var)))) + #'(chaperone-contract? lift-var)))) ;; combine-two-chaperone?s : (or/c boolean? syntax?) (or/c boolean? syntax?) -> (or/c boolean? syntax?) (define (combine-two-chaperone?s chaperone-a? chaperone-b?) diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 4b63f0ca94..39684e0259 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -7,7 +7,7 @@ (for-syntax "opt-guts.rkt") (for-syntax racket/stxparam)) -(provide opt/c define-opt/c define/opter opt-stronger-vars-ref +(provide opt/c define-opt/c define/opter opt/direct begin-lifted) @@ -338,6 +338,9 @@ (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) (make-struct-type-property 'original-contract)) +;; the stronger-vars don't seem to be used anymore for stronger; probably +;; they should be folded into the lifts and then there should be a separate +;; setup for consolidating stronger checks (define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp chaperone?) #:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))) #:property prop:opt-chaperone-contract (λ (ctc) (opt-contract-chaperone? ctc)) @@ -350,8 +353,3 @@ (and (opt-contract? that) (eq? (opt-contract-stamp this) (opt-contract-stamp that)) ((opt-contract-stronger this) this that))))) - -;; opt-stronger-vars-ref : int opt-contract -> any -(define (opt-stronger-vars-ref i ctc) - (let ((v (opt-contract-stronger-vars ctc))) - (vector-ref v i))) diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt index 62af36d27d..dcdfe63d6f 100644 --- a/collects/racket/contract/private/opters.rkt +++ b/collects/racket/contract/private/opters.rkt @@ -63,7 +63,6 @@ [else (let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?) (opt/i opt/info (car ps))]) - (define next-chaperone? (combine-two-chaperone?s chaperone? this-chaperone?)) (if flat (loop (cdr ps) (cons flat next-ps) @@ -73,7 +72,7 @@ (append this-stronger-ribs stronger-ribs) hos ho-ctc - next-chaperone?) + (combine-two-chaperone?s chaperone? this-chaperone?)) (if (< (length hos) 1) (loop (cdr ps) next-ps @@ -83,7 +82,7 @@ (append this-stronger-ribs stronger-ribs) (cons (car ps) hos) next - next-chaperone?) + (combine-two-chaperone?s chaperone? this-chaperone?)) (loop (cdr ps) next-ps lift-ps @@ -92,7 +91,7 @@ stronger-ribs (cons (car ps) hos) ho-ctc - next-chaperone?))))]))]) + chaperone?))))]))]) (with-syntax ((next-ps (with-syntax (((opt-p ...) (reverse opt-ps))) (syntax (or opt-p ...))))) @@ -409,14 +408,15 @@ (loop (cdr vars) (cdr doms) (cons (with-syntax ((next next) - (car-vars (car vars))) + (car-vars (car vars)) + (val (opt/info-val opt/info))) (syntax (let ((val car-vars)) next))) next-doms) (append lifts-doms lift) (append superlifts-doms superlift) (append partials-doms partial) (append this-stronger-ribs stronger-ribs) - (and chaperone? this-chaperone?)))]))] + (combine-two-chaperone?s chaperone? this-chaperone?)))]))] [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?) (let loop ([vars rng-vars] [rngs rngs] @@ -439,16 +439,18 @@ (loop (cdr vars) (cdr rngs) (cons (with-syntax ((next next) - (car-vars (car vars))) + (car-vars (car vars)) + (val (opt/info-val opt/info))) (syntax (let ((val car-vars)) next))) next-rngs) (append lifts-rngs lift) (append superlifts-rngs superlift) (append partials-rngs partial) (append this-stronger-ribs stronger-ribs) - (and chaperone? this-chaperone?)))]))]) + (combine-two-chaperone?s chaperone? this-chaperone?)))]))]) (values - (with-syntax ((blame (opt/info-blame opt/info)) + (with-syntax ((val (opt/info-val opt/info)) + (blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) ((next-dom ...) next-doms) @@ -476,7 +478,7 @@ #f #f (append stronger-ribs-dom stronger-ribs-rng) - (and dom-chaperone? rng-chaperone?)))) + (combine-two-chaperone?s dom-chaperone? rng-chaperone?)))) (define (opt/arrow-any-ctc doms) (let*-values ([(dom-vars) (generate-temporaries doms)] @@ -509,7 +511,7 @@ (append superlifts-doms superlift) (append partials-doms partial) (append this-stronger-ribs stronger-ribs) - (and chaperone? this-chaperone?)))]))]) + (combine-two-chaperone?s chaperone? this-chaperone?)))]))]) (values (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index 003aed802e..7a7e814855 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -58,75 +58,86 @@ (struct subcontract (field-name ref depended-on?) #:transparent) (struct indep subcontract (ctc) #:transparent) -(struct dep subcontract (dep-proc flat?) #:transparent) +(struct dep subcontract (dep-proc dep-names type) #:transparent) -(struct immutable indep () #:transparent) -(struct lazy-immutable indep () #:transparent) -(struct mutable indep (set) #:transparent) +(struct immutable indep () #:transparent) +(struct lazy-immutable indep () #:transparent) +(struct mutable indep (set) #:transparent) -(struct dep-immutable dep () #:transparent) -(struct dep-lazy-immutable dep () #:transparent) -(struct dep-mutable dep (set) #:transparent) +(struct dep-immutable dep () #:transparent) +(struct dep-lazy-immutable dep () #:transparent) +(struct dep-mutable dep (set) #:transparent) +(struct dep-on-state-immutable dep () #:transparent) +(struct dep-on-state-mutable dep (set) #:transparent) + +(define (subcontract-mutable-field? x) + (or (mutable? x) + (dep-mutable? x) + (dep-on-state-mutable? x))) ;; these are the compile-time structures, representing ;; parsed clauses of a struct/dc expression (begin-for-syntax ;; exp : syntax ;; lazy? : boolean - ;; type : (or/c '#:chaperone '#:flat) ;; sel-id : identifier? + ;; type : (or/c '#:flat '#:chaperone '#:impersonator) + ;; depends-on-state? : boolean? -- only set if the keyword #:depends-on-state is passed ;; deps : (listof identifier?) - (struct clause (exp lazy? sel-id)) - (struct dep-clause clause (type deps)) - (struct indep-clause clause ())) + (struct clause (exp lazy? sel-id) #:transparent) + (struct dep-clause clause (type depends-on-state? deps) #:transparent) + (struct indep-clause clause () #:transparent)) (define-syntax-rule (cache-λ (id ...) e) (let ([cached unique]) - (λ (id ...) + (λ (id ...) (cond [(eq? cached unique) (set! cached e) cached] [else cached])))) - (define unique (box #f)) -(define (un-dep ctc obj blame immutable-field) - (let ([ctc (coerce-contract 'struct/dc ctc)]) - (when immutable-field - (check-chaperone-contract immutable-field ctc)) - (((contract-projection ctc) blame) obj))) (define (struct/dc-name ctc) - (define info (base-struct/dc-name-info ctc)) - `(struct/dc ,(vector-ref info 0) - #; - ,@(for/list ([x (in-list (vector-ref info 1))] - [subctc (in-list (struct/dc-procs/ctcs ctc))]) - `[,@(vector-ref x 1) - ,(if (vector-ref x 0) - (contract-name subctc) - '...)]))) + `(struct/dc ,(base-struct/dc-name-info ctc) + ,@(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) + (cond + [(indep? subcontract) + `[,(subcontract-field-name subcontract) + ,@(if (lazy-immutable? subcontract) + '(#:lazy) + '()) + ,(contract-name (indep-ctc subcontract))]] + [else + `[,(subcontract-field-name subcontract) + ,(dep-dep-names subcontract) + ,@(if (dep-lazy-immutable? subcontract) + '(#:lazy) + '()) + ,@(if (eq? '#:chaperone (dep-type subcontract)) + '() + (list (dep-type subcontract))) + ...]])))) (define (struct/dc-first-order ctc) (base-struct/dc-pred ctc)) - (define (struct/dc-proj ctc) (define pred? (base-struct/dc-pred ctc)) (λ (blame) - (define blames + (define orig-blames (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) (blame-add-context blame (format "the ~a field of" (subcontract-field-name subcontract))))) - (define mut-blames + (define orig-mut-blames (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) (blame-add-context blame (format "the ~a field of" (subcontract-field-name subcontract)) #:swap? #t))) - (define indy-blames + (define orig-indy-blames (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) (blame-replace-negative (blame-add-context blame (format "the ~a field of" (subcontract-field-name subcontract))) (base-struct/dc-here ctc)))) - (define mut-indy-blames + (define orig-mut-indy-blames (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) (blame-replace-negative (blame-add-context blame (format "the ~a field of" (subcontract-field-name subcontract)) @@ -134,7 +145,7 @@ (base-struct/dc-here ctc)))) (define projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] - [blame+ctxt (in-list blames)]) + [blame+ctxt (in-list orig-blames)]) (cond [(indep? subcontract) (define sub-ctc (indep-ctc subcontract)) @@ -142,23 +153,23 @@ [else #f]))) (define mut-projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] - [blame+ctxt (in-list mut-blames)]) + [blame+ctxt (in-list orig-mut-blames)]) (cond [(and (indep? subcontract) (mutable? subcontract)) (define sub-ctc (indep-ctc subcontract)) ((contract-projection sub-ctc) blame+ctxt)] [else #f]))) - (define indy-projs + (define orig-indy-projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] - [blame+ctxt (in-list indy-blames)]) + [blame+ctxt (in-list orig-indy-blames)]) (cond [(indep? subcontract) (define sub-ctc (indep-ctc subcontract)) ((contract-projection sub-ctc) blame+ctxt)] [else #f]))) - (define mut-indy-projs + (define orig-mut-indy-projs (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] - [blame+ctxt (in-list mut-indy-blames)]) + [blame+ctxt (in-list orig-mut-indy-blames)]) (cond [(and (indep? subcontract) (mutable? subcontract)) (define sub-ctc (indep-ctc subcontract)) @@ -176,17 +187,22 @@ (let loop ([subcontracts (base-struct/dc-subcontracts ctc)] [projs projs] [mut-projs mut-projs] - [indy-projs indy-projs] - [mut-indy-projs mut-indy-projs] - [blames blames] - [mut-blames mut-blames] - [indy-blames indy-blames] - [mut-indy-blames mut-indy-blames] + [indy-projs orig-indy-projs] + [mut-indy-projs orig-mut-indy-projs] + [blames orig-blames] + [mut-blames orig-mut-blames] + [indy-blames orig-indy-blames] + [mut-indy-blames orig-mut-indy-blames] [chaperone-args '()] + [impersonate-args '()] [dep-args '()]) (cond [(null? subcontracts) - (apply chaperone-struct v chaperone-args)] + (apply chaperone-struct + (apply impersonate-struct + v + impersonate-args) + chaperone-args)] [else (define subcontract (car subcontracts)) (define proj (car projs)) @@ -199,82 +215,167 @@ (define indy-blame (car indy-blames)) (define mut-indy-blame (car mut-indy-blames)) (define dep-ctc - (and (dep? subcontract) + (and (dep? subcontract) (coerce-contract 'struct/dc (apply (dep-dep-proc subcontract) dep-args)))) - (when dep-ctc - (unless (chaperone-contract? dep-ctc) - (error 'struct/dc "expected a chaperone contract for the immutable field ~a, got ~e" - (subcontract-field-name subcontract) - dep-ctc))) + (when dep-ctc (check-flat/chaperone dep-ctc subcontract)) (define dep-ctc-blame-proj (and dep-ctc (contract-projection dep-ctc))) - (define new-chaperone-args + (define-values (new-chaperone-args new-impersonate-args) (cond [(immutable? subcontract) - (list* sel - (let ([projd (proj (sel v))]) - (λ (fld v) projd)) - chaperone-args)] + (define projd (proj (sel v))) + (values (if (flat-contract? (indep-ctc subcontract)) + chaperone-args + (list* sel + (λ (fld v) projd) + chaperone-args)) + impersonate-args)] [(lazy-immutable? subcontract) - (list* sel - (cache-λ (fld v) (proj v)) - chaperone-args)] + (values (list* sel + (cache-λ (fld v) (proj v)) + chaperone-args) + impersonate-args)] [(mutable? subcontract) - (list* sel - (λ (fld v) (proj v)) - (mutable-set subcontract) - (λ (fld v) (mut-proj v)) - chaperone-args)] + (if (impersonator-contract? (indep-ctc subcontract)) + (values chaperone-args + (list* sel + (λ (fld v) (proj v)) + (mutable-set subcontract) + (λ (fld v) (mut-proj v)) + impersonate-args)) + (values (list* sel + (λ (fld v) (proj v)) + (mutable-set subcontract) + (λ (fld v) (mut-proj v)) + chaperone-args) + impersonate-args))] [else (define proj (dep-ctc-blame-proj blame)) (cond [(dep-immutable? subcontract) - (list* sel - (let ([projd (proj (sel v))]) - (λ (fld v) projd)) - chaperone-args)] + (define projd (proj (sel v))) + (values (if (flat-contract? dep-ctc) + chaperone-args + (list* sel + (λ (fld v) projd) + chaperone-args)) + impersonate-args)] [(dep-lazy-immutable? subcontract) - (list* sel - (cache-λ (fld v) (proj v)) - chaperone-args)] + (values (list* sel + (cache-λ (fld v) (proj v)) + chaperone-args) + impersonate-args)] [(dep-mutable? subcontract) (define mut-proj (dep-ctc-blame-proj mut-blame)) - (list* sel - (λ (fld v) (proj v)) - (mutable-set subcontract) - (λ (fld v) (mut-proj v)) - chaperone-args)])])) + (if (eq? (dep-type subcontract) '#:impersonator) + (values (list* sel + (λ (fld v) (proj v)) + (dep-mutable-set subcontract) + (λ (fld v) (mut-proj v)) + chaperone-args) + impersonate-args) + (values chaperone-args + (list* sel + (λ (fld v) (proj v)) + (dep-mutable-set subcontract) + (λ (fld v) (mut-proj v)) + impersonate-args)))] + [(dep-on-state-immutable? subcontract) + (proj (sel v)) + (values (list* sel + (λ (strct val) (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct + orig-indy-projs orig-indy-blames blame val)) + chaperone-args) + impersonate-args)] + [(dep-on-state-mutable? subcontract) + (proj (sel v)) + (define (get-chap-proc strct val) + (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct + orig-indy-projs orig-indy-blames blame val)) + (define (set-chap-proc strct val) + (build-dep-on-state-proj (base-struct/dc-subcontracts ctc) subcontract strct + orig-mut-indy-projs orig-mut-indy-blames mut-blame val)) + (if (eq? (dep-type subcontract) '#:impersonator) + (values chaperone-args + (list* sel + get-chap-proc + (dep-on-state-mutable-set subcontract) + set-chap-proc + impersonate-args)) + (values (list* sel + get-chap-proc + (dep-on-state-mutable-set subcontract) + set-chap-proc + chaperone-args) + impersonate-args))])])) (loop (cdr subcontracts) (cdr projs) (cdr mut-projs) (cdr indy-projs) (cdr mut-indy-projs) (cdr blames) (cdr mut-blames) (cdr indy-blames) (cdr mut-indy-blames) new-chaperone-args + new-impersonate-args (if (subcontract-depended-on? subcontract) (cons (if dep-ctc-blame-proj ((dep-ctc-blame-proj indy-blame) ((subcontract-ref subcontract) v)) (indy-proj ((subcontract-ref subcontract) v))) dep-args) - dep-args))]))]))) - - #; - (begin - (define pred? (base-struct/dc-pred ctc)) - (define mk-proj ((base-struct/dc-apply-proj ctc) ctc)) - (λ (blame) - (define proj (mk-proj blame)) - (λ (v) - (cond - [(and (struct/c-imp-prop-pred? v) - (contract-stronger? (struct/c-imp-prop-get v) ctc)) - v] - [else - (unless (pred? v) - (raise-blame-error blame v "expected a ~a" - (base-struct/dc-struct-name ctc))) - (proj v)]))))) + dep-args))]))])))) + +(define (build-dep-on-state-proj orig-subcontracts this-subcontract strct projs blames blame val) + (let loop ([subcontracts orig-subcontracts] + [blames blames] + [projs projs] + [dep-args '()]) + (cond + [(null? subcontracts) + (error 'build-dep-on-state-proj "ran out of subcontracts ~s ~s ~s" orig-subcontracts this-subcontract strct)] + [else + (define subcontract (car subcontracts)) + (cond + [(eq? subcontract this-subcontract) + (define the-ctc (coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args))) + (check-flat/chaperone the-ctc subcontract) + (((contract-projection the-ctc) blame) val)] + [else + (define indy-blame (car blames)) + (define proj (car projs)) + (define dep-ctc + (and (dep? subcontract) + (coerce-contract + 'struct/dc + (apply (dep-dep-proc subcontract) dep-args)))) + (define dep-ctc-blame-proj (and dep-ctc (contract-projection dep-ctc))) + + (when (dep? subcontract) + (check-flat/chaperone dep-ctc subcontract)) + + (define new-dep-args + (if (subcontract-depended-on? subcontract) + (cons (if dep-ctc-blame-proj + ((dep-ctc-blame-proj indy-blame) ((subcontract-ref subcontract) strct)) + (proj ((subcontract-ref subcontract) strct))) + dep-args) + dep-args)) + (loop (cdr subcontracts) + (cdr blames) + (cdr projs) + new-dep-args)])]))) + +(define (check-flat/chaperone dep-ctc subcontract) + (case (dep-type subcontract) + [(#:flat) + (unless (flat-contract? dep-ctc) + (error 'struct/dc "expected a flat contract for the field: ~a, got ~s" + (subcontract-field-name subcontract) + (contract-name dep-ctc)))] + [(#:chaperone) + (unless (chaperone-contract? dep-ctc) + (error 'struct/dc "expected a chaperone contract for the field: ~a, got ~s" + (subcontract-field-name subcontract) + (contract-name dep-ctc)))])) (define (struct/dc-stronger? this that) - (and (struct/dc? that) + (and (base-struct/dc? that) (eq? (base-struct/dc-pred this) (base-struct/dc-pred that)) (for/and ([this-subcontract (in-list (base-struct/dc-subcontracts this))] [that-subcontract (in-list (base-struct/dc-subcontracts that))]) @@ -320,9 +421,19 @@ #:projection struct/dc-proj #:stronger struct/dc-stronger?))) +(define-struct (impersonator-struct/dc base-struct/dc) () + #:property prop:flat-contract + (parameterize ([skip-projection-wrapper? #t]) + (build-flat-contract-property + #:name struct/dc-name + #:first-order struct/dc-first-order + #:projection struct/dc-proj + #:stronger struct/dc-stronger?))) + (define (build-struct/dc subcontracts pred struct-name here name-info) (for ([subcontract (in-list subcontracts)]) - (when (indep? subcontract) + (when (and (indep? subcontract) + (not (mutable? subcontract))) (unless (chaperone-contract? (indep-ctc subcontract)) (error 'struct/dc "expected chaperone contracts, but field ~a has ~e" (subcontract-field-name subcontract) @@ -330,10 +441,18 @@ (define (flat-subcontract? subcontract) (cond [(indep? subcontract) (flat-contract? (indep-ctc subcontract))] - [(dep? subcontract) (dep-flat? subcontract)])) - ((if (andmap flat-subcontract? subcontracts) - make-flat-struct/dc - make-struct/dc) + [(dep? subcontract) (eq? '#:flat (dep-type subcontract))])) + (define (impersonator-subcontract? subcontract) + (cond + [(indep? subcontract) (impersonator-contract? (indep-ctc subcontract))] + [(dep? subcontract) (eq? '#:impersonator (dep-type subcontract))])) + ((cond + [(andmap flat-subcontract? subcontracts) + make-flat-struct/dc] + [(ormap impersonator-subcontract? subcontracts) + make-impersonator-struct/dc] + [else + make-struct/dc]) subcontracts pred struct-name here name-info)) @@ -361,151 +480,131 @@ [(_ id clauses ...) (let () (define info (get-struct-info #'id stx)) - (values - info - #'id - (for/list ([clause (in-list (syntax->list #'(clauses ...)))]) - (syntax-case clause () - [(sel-id (id ...) stuff1 . stuff) ;; need stuff1 here so that things like [a (>=/c x)] do not fall into this case - (let () - (unless (identifier? #'sel-id) - (raise-syntax-error #f "expected an identifier (naming a field)" stx #'sel-id)) - (for ([id (in-list (syntax->list #'(id ...)))]) - (unless (identifier? id) - (raise-syntax-error #f "expected an identifier (naming a field)" stx id))) - (define-values (ctc-exp lazy? type) - (let loop ([stuff #'(stuff1 . stuff)] - [lazy? #f] - [type #f]) - (syntax-case stuff () - [(exp) (values #'exp - lazy? - (string->symbol - (keyword->string - (if type (syntax-e type) '#:chaperone))))] - [(#:lazy . stuff) (loop #'stuff #t type)] - [(#:flat . more-stuff) - (when type (raise-syntax-error #f (format "found both #:flat and ~a" (syntax-e type)) - stx - #f - (list type (stx-car stuff)))) - (loop #'stuff lazy? (stx-car stuff))] - [(#:impersonator . more-stuff) - (when type (raise-syntax-error #f (format "found both #:impersonator and ~a" (syntax-e type)) - stx - #f - (list type (stx-car stuff)))) - (loop #'more-stuff lazy? (stx-car stuff))] - [(#:depends-on-state . more-stuff) - (raise-syntax-error #f "#:depends-on-state not yet implemented" stx (stx-car stuff))] - [_ (raise-syntax-error #f "could not parse clause" stx clause)]))) - (dep-clause ctc-exp lazy? #'sel-id type (syntax->list #'(id ...))))] - [(sel-id . rest) - (let () - (unless (identifier? #'sel-id) - (raise-syntax-error #f "expected an identifier (naming a field)" stx #'sel-id)) - (define-values (lazy? exp) - (syntax-case #'rest () - [(#:lazy exp) (values #t #'exp)] - [(exp) (values #f #'exp)] - [else (raise-syntax-error #f "could not parse clause" stx clause)])) - (indep-clause exp lazy? #'sel-id))] - [_ (raise-syntax-error #f "could not parse clause" stx #'clause)]))))])) - + (define (ensure-valid-field sel-id) + (define selector-candidate (id->sel-id #'id sel-id)) + (unless (for/or ([selector (in-list (list-ref info 3))]) + (and selector (free-identifier=? selector-candidate selector))) + (raise-syntax-error #f + "expected an identifier that names a field" + stx + sel-id))) + + (define (check-not-both this that) + (when (and this that) + (raise-syntax-error #f + (format "found both ~a and ~a on the same field" + (syntax-e this) + (syntax-e that)) + stx + that + (list this)))) + + (define parsed-clauses + (for/list ([clause (in-list (syntax->list #'(clauses ...)))]) + (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 + (let () + (unless (identifier? #'sel-id) + (raise-syntax-error #f "expected an identifier (naming a field)" stx #'sel-id)) + (for ([id (in-list (syntax->list #'(dep-id ...)))]) + (unless (identifier? id) + (raise-syntax-error #f "expected an identifier (naming a field)" stx id))) + (ensure-valid-field #'sel-id) + (define-values (ctc-exp lazy? type depends-on-state?) + (let loop ([stuff #'(stuff1 . stuff)] + [lazy? #f] + [type #f] + [depends-on-state? #f]) + (syntax-case stuff () + [(exp) (values #'exp lazy? type depends-on-state?)] + [(flat/impersonator-kwd . more-stuff) + (memq (syntax-e #'flat/impersonator-kwd) '(#:flat #:impersonator)) + (begin + (check-not-both type (stx-car stuff)) + (loop #'more-stuff lazy? (stx-car stuff) depends-on-state?))] + [(#:depends-on-state . more-stuff) (loop #'more-stuff lazy? type #t)] + [(#:lazy . more-stuff) (loop #'more-stuff #t type depends-on-state?)] + [_ (raise-syntax-error #f "could not parse clause" stx clause)]))) + (dep-clause ctc-exp lazy? + #'sel-id + (if type (syntax-e type) '#:chaperone) + depends-on-state? + (syntax->list #'(dep-id ...))))] + [(sel-id . rest) + (let () + (unless (identifier? #'sel-id) + (raise-syntax-error #f "expected an identifier (naming a field)" stx #'sel-id)) + (ensure-valid-field #'sel-id) + (define-values (lazy? exp) + (syntax-case #'rest () + [(#:lazy exp) (values #t #'exp)] + [(exp) (values #f #'exp)] + [else (raise-syntax-error #f "could not parse clause" stx clause)])) + (indep-clause exp lazy? #'sel-id))] + [_ (raise-syntax-error #f "could not parse clause" stx #'clause)]))) + + + (let () + (define lazy-mapping (make-free-identifier-mapping)) + (for ([clause (in-list parsed-clauses)]) + (free-identifier-mapping-put! lazy-mapping + (clause-sel-id clause) + (clause-lazy? clause))) + + ;; check that non-lazy don't depend on lazy + (for ([clause (in-list parsed-clauses)]) + (when (dep-clause? clause) + (unless (clause-lazy? clause) + (for ([dep-id (in-list (dep-clause-deps clause))]) + (when (free-identifier-mapping-get lazy-mapping dep-id) + (raise-syntax-error + #f + (format "the dependent clause for ~a is not lazy, but depends on ~a" + (syntax-e (clause-sel-id clause)) + (syntax-e dep-id)) + stx + dep-id)))))) + + (for ([clause (in-list parsed-clauses)]) + (define this-sel (id->sel-id #'id (clause-sel-id clause))) + (for ([sel (in-list (list-ref info 3))] + [mut (in-list (list-ref info 4))]) + (when (and sel + (free-identifier=? sel this-sel)) + + + ;; check that fields depended on actually exist + (when (dep-clause? clause) + (for ([id (in-list (dep-clause-deps clause))]) + (free-identifier-mapping-get + lazy-mapping + id + (λ () (raise-syntax-error #f + (format "the field: ~a is depended on (by the contract on the field: ~a), but it has no contract" + (syntax-e id) + (syntax-e (clause-sel-id clause))) + stx + (clause-sel-id clause)))))) + + ;; check that impersonator fields are mutable + (when (and (dep-clause? clause) + (eq? (dep-clause-type clause) '#:impersonator)) + (unless mut + (raise-syntax-error #f + (format "the ~a field is immutable, so the contract cannot be an impersonator contract" + (syntax-e (clause-sel-id clause))) + stx + (clause-sel-id clause)))) -(define-for-syntax (clause->chap-proc struct-id info stx clause-stx) - (define sel-id (syntax-case clause-stx () - [(sel-id . rest) #'sel-id])) - (define (add-prefix id) - (datum->syntax id - (string->symbol (format "~a-~a" - (syntax-e sel-id) - (syntax-e id))))) - (define immutable-field - (for/or ([mutator (in-list (list-ref info 4))] - [selector (in-list (list-ref info 3))]) - (cond - [(and (not mutator) (not selector)) - ;; end, with some hidden info - ;; just assume not immutable - #f] - [else - (and (not mutator) - (let ([id (id->sel-id struct-id sel-id)]) - (and (free-identifier=? id selector) - id)))]))) - (define (add-immutable-check ctc-id stx) - (if immutable-field - (list stx - #`(check-chaperone-contract '#,immutable-field #,ctc-id)) - (list stx))) - - (syntax-case clause-stx () - ;; with caching - [(sel-id #:lazy (id ...) exp) - (with-syntax ([(dep-sel-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))]) - (with-syntax ([dep-proc (add-prefix #'dep-proc)]) - #`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp)))) - (begin) - (begin) - (begin) - (let ([cached unique]) - (λ (strct fld) - (if (eq? cached unique) - (begin - (set! cached (un-dep (dep-proc (dep-sel-id strct) ...) fld blame '#,immutable-field)) - cached) - cached))) - #(#f (sel-id #:lazy (id ...))) - )))] - [(sel-id (id ...) exp) - (with-syntax ([(dep-sel-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))]) - (with-syntax ([dep-proc (add-prefix #'dep-proc)]) - #`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp)))) - (begin) - (begin) - (un-dep (dep-proc (dep-sel-id v) ...) (#,(id->sel-id struct-id #'sel-id) v) blame '#,immutable-field) - (λ (strct fld) - (un-dep (dep-proc (dep-sel-id strct) ...) fld blame '#,immutable-field)) - #(#f (sel-id (id ...))) - )))] - [(sel-id #:lazy exp) - (with-syntax ([ctc (add-prefix #'ctc)] - [blame-to-proj (add-prefix #'blame-to-proj)] - [proj (add-prefix #'proj)]) - #`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp))) - (define blame-to-proj (contract-struct-projection ctc)) - (define proj (blame-to-proj blame)) - (begin) - (let ([cached unique]) - (λ (strct fld) - (if (eq? cached unique) - (begin - (set! cached (proj fld)) - cached) - cached))) - #(#t (sel-id #:lazy))))] - [(sel-id exp) - (with-syntax ([ctc (add-prefix #'ctc)] - [blame-to-proj (add-prefix #'blame-to-proj)] - [proj (add-prefix #'proj)]) - #`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp))) - (define blame-to-proj (contract-struct-projection ctc)) - (define proj (blame-to-proj blame)) - (proj (#,(id->sel-id struct-id #'sel-id) v)) - (if (flat-contract? ctc) - (λ (strct fld) fld) - (λ (strct fld) (proj fld))) - #(#t (sel-id))))] - [_ (raise-syntax-error #f "malformed clause" stx clause-stx)])) - -(define (check-chaperone-contract immutable-field ctc) - (unless (chaperone-contract? ctc) - (error 'struct/dc "expected a chaperone contract for the immutable field ~a, got ~e" - (if (number? immutable-field) - (format "number ~a (counting from 0)" immutable-field) - immutable-field) - ctc))) + ;; check that mutable fields aren't lazy + (when (and (clause-lazy? clause) mut) + (raise-syntax-error #f + (format "the ~a field is mutable, so the contract cannot be lazy" + (syntax-e (clause-sel-id clause))) + stx + (clause-sel-id clause))))))) + + (values info #'id parsed-clauses))])) (define-for-syntax (id->sel-id struct-id id) (datum->syntax @@ -526,10 +625,15 @@ (cond [(dep-clause? x) (for/list ([id (in-list (dep-clause-deps x))]) - (free-identifier-mapping-get id->children id))] + (free-identifier-mapping-get id->children id + (λ () + (raise-syntax-error #f "unknown clause" stx id))))] [else '()])) - (top-sort clauses neighbors)) + (top-sort clauses neighbors + (λ (leftovers) + (raise-syntax-error #f "found cyclic dependencies" + stx)))) (define-syntax (-struct/dc stx) (define-values (info struct-id clauses) (parse-struct/dc stx)) @@ -537,12 +641,20 @@ ;; maps the sel-ids to #t when they are depended on (define depended-on-clauses (make-free-identifier-mapping)) - (for ([clause (in-list sorted-clauses)]) - (when (dep-clause? clause) - (for ([var (in-list (dep-clause-deps clause))]) - (free-identifier-mapping-put! depended-on-clauses var #t)))) + ;; map the sel-id/dep field identifiers to the corresponding clauses + (define sel-id->clause (make-free-identifier-mapping)) + ;; track which clauses correspond to mutable fields + (define mutable-clauses (make-free-identifier-mapping)) + + ;; track which clauses (transitively) depend on mutable state + ;; (either by directly depending on a mutable field or by having + ;; the #:depends-on-state? keyword + (define dep-on-mutable-clauses (make-free-identifier-mapping)) + + + ;; find-selector/mutator : clause -> (values identifier? identifier?) (define (find-selector/mutator clause) (define fld-name (clause-sel-id clause)) (define this-selector @@ -558,6 +670,33 @@ mutator))) (values this-selector mutator)) + ;; init the first three mappings above + (for ([clause (in-list sorted-clauses)]) + (define-values (sel mut) (find-selector/mutator clause)) + (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) + (when (dep-clause? clause) + (for ([var (in-list (dep-clause-deps clause))]) + (free-identifier-mapping-put! depended-on-clauses var #t)))) + + ;; init the dep-on-mutable-clauses mapping + (for ([clause (in-list clauses)]) + (let loop ([clause clause]) + (define sel-id (clause-sel-id clause)) + (define current (free-identifier-mapping-get dep-on-mutable-clauses sel-id (λ () 'unknown))) + (cond + [(eq? current 'unknown) + (define ans + (or (free-identifier-mapping-get mutable-clauses sel-id) + (and (dep-clause? clause) + (or (dep-clause-depends-on-state? clause) + (for/or ([dep (in-list (dep-clause-deps clause))]) + (loop (free-identifier-mapping-get sel-id->clause dep))))))) + (free-identifier-mapping-put! dep-on-mutable-clauses sel-id ans) + ans] + [else + current]))) + (define structs (let loop ([dep-args '()] [clauses sorted-clauses]) @@ -568,11 +707,21 @@ (define-values (selector mutator) (find-selector/mutator clause)) (define subcontract-constructor (if (dep-clause? clause) - (if (clause-lazy? clause) - #'dep-lazy-immutable - (if mutator - #'dep-immutable - #'dep-immutable)) + (if (free-identifier-mapping-get dep-on-mutable-clauses (clause-sel-id clause)) + (if (clause-lazy? clause) + (raise-syntax-error + #f + (format "the contract on field ~a depends on mutable state (possibly indirectly), so cannot be lazy" + (syntax-e (clause-sel-id clause))) + stx (clause-sel-id clause)) + (if mutator + #'dep-on-state-mutable + #'dep-on-state-immutable)) + (if (clause-lazy? clause) + #'dep-lazy-immutable + (if mutator + #'dep-mutable + #'dep-immutable))) (if (clause-lazy? clause) #'lazy-immutable (if mutator @@ -587,7 +736,8 @@ (define indep/dep-args (if (dep-clause? clause) (list #`(λ (#,@dep-args) #,(clause-exp clause)) - (eq? (dep-clause-type clause) '#:flat)) + #`'(#,@(reverse dep-args)) + #`'#,(dep-clause-type clause)) (list #`(coerce-contract 'struct/dc #,(clause-exp clause))))) (cons #`(#,subcontract-constructor #,@subcontract-args #,@indep/dep-args @@ -596,84 +746,40 @@ '())) (loop (if depended-on? (cons (clause-sel-id clause) dep-args) - '()) + dep-args) (cdr clauses)))]))) #`(build-struct/dc (list #,@structs) #,(list-ref info 2) 'struct-id (quote-module-name) - '#(struct-id 'missing-name-information-in-struct/dc)) - - - #; - (syntax-case stx () - [(_ struct-id clause ...) - (let () - (define info (get-struct-info #'struct-id stx)) - (with-syntax ([(((before-ctc-bound ...) after-ctc-bound after-blame-bound first-order-check chap-proc name-info) ...) - (for/list ([clause (in-list (syntax->list #'(clause ...)))]) - (clause->chap-proc #'struct-id info stx clause))]) - (with-syntax ([(id ...) (syntax-case #'((before-ctc-bound ...) ...) () - [(((define id exp) . whatever) ...) #'(id ...)])] - [(selectors+chap-procs ...) - (apply - append - (for/list ([clause (in-list (syntax->list #'(clause ...)))] - [chap-proc (in-list (syntax->list #'(chap-proc ...)))]) - (list (id->sel-id - #'struct-id - (syntax-case clause () - [(x . rest) #'x])) - chap-proc)))]) - #`(let () - before-ctc-bound ... ... - (letrec ([me - (make-struct/dc - (λ (ctc) - after-ctc-bound ... - (λ (blame) - after-blame-bound ... - (λ (v) - first-order-check ... - (chaperone-struct - v - selectors+chap-procs ... - struct/c-imp-prop-desc - me)))) - (list id ...) - #,(list-ref info 2) - 'struct-id - (quote-module-name) - '#(struct-id (name-info ...)) - )]) - me)))))])) + '#,struct-id)) (define/opter (-struct/dc opt/i opt/info stx) (syntax-case stx () [(_ struct-id clause ...) (let/ec k - (define info (get-struct-info #'struct-id stx)) + (define-values (info _1 _2) (parse-struct/dc stx)) (define (give-up) (call-with-values (λ () (opt/unknown opt/i opt/info stx)) k)) (cond [(ormap values (list-ref info 4)) - ;; any mutable struct, just give up + ;; any mutable fields, just give up (give-up)] [else (define depended-on-fields (make-free-identifier-mapping)) (define flat-fields (make-free-identifier-mapping)) - (define-values (s-chap-code s-flat-code s-lifts s-super-lifts s-partially-applied can-be-optimized? stronger-ribs chaperone?) - (for/fold ([s-chap-code '()] - [s-flat-code '()] + (define-values (s-fo-code s-chap-code s-lifts s-super-lifts s-partially-applied can-be-optimized? stronger-ribs chaperone?) + (for/fold ([s-fo-code '()] + [s-chap-code '()] [s-lifts '()] [s-super-lifts '()] [s-partially-applied '()] [can-be-optimized? #t] [stronger-ribs '()] [chaperone? #t]) - ([clause (in-list (syntax->list #'(clause ...)))]) + ([clause (in-list (syntax->list #'(clause ...)))]) (define-values (sel-id lazy? dep-vars exp) (syntax-case clause () @@ -687,94 +793,76 @@ (values #'sel-id #f #'(dep-id ...) #'exp)] [other (give-up)])) + (define sub-val (car (generate-temporaries '(struct/dc)))) + (define-values (this-code this-lifts this-super-lifts this-partially-applied this-flat? this-can-be-optimized? this-stronger-ribs this-chaperone?) - (opt/i opt/info exp)) + (opt/i (opt/info-change-val sub-val opt/info) + exp)) (when dep-vars (for ([dep-var (in-list (syntax->list dep-vars))]) (free-identifier-mapping-put! depended-on-fields dep-var #t))) (free-identifier-mapping-put! flat-fields sel-id this-flat?) - (values (cond - [(and this-flat? (not lazy?) (not dep-vars)) - s-chap-code] - [else - (with-syntax ([(strct cache) (generate-temporaries '(struct cache))] - [proc-name (string->symbol - (format "~a-~a-chap/dep" - (syntax-e #'struct-id) - (syntax-e sel-id)))]) - (list* (cond - [dep-vars - (with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var)) - (syntax->list dep-vars))] - [(dep-var ...) dep-vars]) - (with-syntax ([this-code+lifts - #`(let ([dep-var (sel strct)] ...) - #,(bind-superlifts - this-super-lifts - (bind-lifts - this-lifts - (bind-lifts - this-partially-applied - this-code))))]) - (if lazy? - #`(let ([cache unique]) - (let ([proc-name - (λ (strct #,(opt/info-val opt/info)) - (cond - [(eq? cache unique) - (set! cache this-code+lifts) - cache] - [else cache]))]) - proc-name)) - #`(let ([proc-name - (λ (strct #,(opt/info-val opt/info)) - this-code+lifts)]) - proc-name))))] - [else - (if lazy? - #`(let ([cache unique]) - (let ([proc-name - (λ (strct #,(opt/info-val opt/info)) - (cond - [(eq? cache unique) - (set! cache #,this-code) - cache] - [else cache]))]) - proc-name)) - #`(let ([proc-name - (λ (strct #,(opt/info-val opt/info)) - #,this-code)]) - proc-name))]) - (id->sel-id #'struct-id sel-id) - s-chap-code))]) - (cond - [lazy? - s-flat-code] - [dep-vars - (with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var)) - (syntax->list dep-vars))] - [(dep-var ...) dep-vars]) - (cons #` (let ([dep-var (sel #,(opt/info-val opt/info))] ...) - (let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id) - #,(opt/info-val opt/info))]) - #,this-code)) - s-flat-code))] - [else - (cons #`(let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id) - #,(opt/info-val opt/info))]) - #,this-code) - s-flat-code)]) + (define this-body-code + (cond + [dep-vars + (with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var)) + (syntax->list dep-vars))] + [(dep-var ...) dep-vars]) + #`(let ([dep-var (sel #,(opt/info-val opt/info))] ...) + #,(bind-superlifts + this-super-lifts + (bind-lifts + this-lifts + (bind-lifts + this-partially-applied + this-code)))))] + [else this-code])) + + + (define this-chap-code + (and (or (not this-flat?) + lazy?) + (with-syntax ([proc-name (string->symbol + (format "~a-~a-chap" + (syntax-e #'struct-id) + (syntax-e sel-id)))]) + (if lazy? + #`(let ([proc-name + (cache-λ (strct #,sub-val) + #,this-body-code)]) + proc-name) + #`(let ([answer (let ([#,sub-val + (#,(id->sel-id #'struct-id sel-id) + #,(opt/info-val opt/info))]) + #,this-body-code)]) + (let ([proc-name (λ (strct fld) answer)]) + proc-name)))))) + + (define this-fo-code + (and (and this-flat? + (not lazy?)) + #`(let ([#,sub-val + (#,(id->sel-id #'struct-id sel-id) + #,(opt/info-val opt/info))]) + #,this-body-code))) + + (values (if this-fo-code + (cons this-fo-code s-fo-code) + s-fo-code) + (if this-chap-code + (list* this-chap-code (id->sel-id #'struct-id sel-id) s-chap-code) + s-chap-code) (if dep-vars s-lifts (append this-lifts s-lifts)) (if dep-vars s-super-lifts (append this-super-lifts s-super-lifts)) (if dep-vars s-partially-applied (append this-partially-applied s-partially-applied)) (and this-can-be-optimized? can-be-optimized?) - (append this-stronger-ribs stronger-ribs) - (and this-chaperone? chaperone?)))) + (if dep-vars stronger-ribs (append this-stronger-ribs stronger-ribs)) + (combine-two-chaperone?s chaperone? this-chaperone?)))) ;; to avoid having to deal with indy-ness, just give up if any ;; of the fields that are depended on aren't flat @@ -791,19 +879,25 @@ [(free-var ...) (opt/info-free-vars opt/info)] [(index ...) (build-list (length (opt/info-free-vars opt/info)) values)] [pred? (list-ref info 2)]) - (values #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) - (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) - (and (eq? (vector-ref v index) free-var) ...))) - #,(opt/info-val opt/info) - (if (pred? #,(opt/info-val opt/info)) + (values (if (null? s-chap-code) ;; if this is #t, when we have to avoid putting the property on here. + #`(if (pred? #,(opt/info-val opt/info)) (begin - #,@(reverse s-flat-code) ;; built the last backwards, so reverse it here - (chaperone-struct - #,(opt/info-val opt/info) - #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here - stronger-prop-desc - (vector free-var ...))) - (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name))) + #,@s-fo-code + #,(opt/info-val opt/info)) + (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)) + #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info)) + (let ([v (stronger-prop-get #,(opt/info-val opt/info))]) + (and (eq? (vector-ref v index) free-var) ...))) + #,(opt/info-val opt/info) + (if (pred? #,(opt/info-val opt/info)) + (begin + #,@s-fo-code + (chaperone-struct + #,(opt/info-val opt/info) + #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here + stronger-prop-desc + (vector free-var ...))) + (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))) s-lifts s-super-lifts s-partially-applied diff --git a/collects/racket/contract/private/top-sort.rkt b/collects/racket/contract/private/top-sort.rkt index 58b5e241f3..e0f8058294 100644 --- a/collects/racket/contract/private/top-sort.rkt +++ b/collects/racket/contract/private/top-sort.rkt @@ -3,7 +3,7 @@ ;; top-sort : (listof α) (α -> (listof α)) -> (listof α) or #f ;; returns #f if there is a cycle in the graph ;; (α needs hashing) -(define (top-sort elements neighbors) +(define (top-sort elements neighbors fail) (define parents (make-hash)) (define children (make-hash)) (define ids (make-hash)) @@ -54,6 +54,6 @@ (cons best (loop))]))) (cond - [(zero? (hash-count pending)) sorted] - [else #f])) + [(= (length sorted) (length elements)) sorted] + [else (fail (remove* sorted elements))])) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index df5f549ccf..d778011633 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -393,35 +393,39 @@ produced. Otherwise, an impersonator contract is produced. ([field-spec [field-id maybe-lazy contract-expr] [field-id (dep-field-id ...) maybe-lazy - maybe-flat + maybe-flat-or-impersonator maybe-dep-state contract-expr]] [maybe-lazy (code:line) #:lazy] - [maybe-flat (code:line) #:flat] + [maybe-flat-or-impersonator (code:line) #:flat #:impersonator] [maybe-dep-state (code:line) #:depends-on-state])]{ Produces a contract that recognizes instances of the structure type named by @racket[struct-id], and whose field values match the contracts produced by the @racket[field-spec]s. -Each @racket[field-spec] can specify if the field is check lazily -(only when a selector is applied) or not via the @racket[#:lazy] -keyword. - 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] 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. If the field is a dependent field, then it is assumed that the contract is -always a chaperone contract. If this is not the case, and the contract is -always flat, or sometimes not a chaperone, then the field must be annotated with -the @racket[#:flat] or @racket[#:impersonator]. +a chaperone, but not always a flat contract (and theus the entire @racket[struct/dc] +contract is not a flat contract). +If this is not the case, and the contract is +always flat then the field must be annotated with +the @racket[#:flat], or the field must be annotated with +@racket[#:chaperone] (in which case, it must be a mutable field). + +If the @racket[#:lazy] keyword appears, then the contract +on the field is check lazily (only when a selector is applied); +@racket[#:lazy] contracts cannot be put on mutable fields. If a dependent contract depends on some mutable state, then use the @racket[#:depends-on-state] keyword argument (if a field's dependent contract depends on a mutable field, this keyword is automatically inferred). The presence of this keyword means that the contract expression is evaluated each time the corresponding field is accessed (or mutated, if it is a mutable -field). +field). Otherwise, the contract expression for a dependent field contract +is evaluated when the contract is applied to a value. Contracts for immutable fields must be either flat or chaperone contracts. Contracts for mutable fields may be impersonator contracts. @@ -433,14 +437,17 @@ produced. Otherwise, an impersonator contract is produced. As an example, the function @racket[bst/c] below returns a contract for binary search trees whose values are all between @racket[lo] and @racket[hi]. +The lazy annotations ensure that this contract does not +change the running time of operations that do not +inspect the entire tree. @racketblock[(struct bt (val left right)) (define (bst/c lo hi) (or/c #f (struct/dc bt [val (between/c lo hi)] - [left (val) (bst lo val)] - [right (val) (bst val hi)])))] + [left (val) #:lazy (bst lo val)] + [right (val) #:lazy (bst val hi)])))] } diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index f360cba621..2af37db0ae 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9402,7 +9402,7 @@ 'struct/dc-new3 '(let () (struct s (a)) - (contract (s-a (struct/dc s [a #:lazy integer?])) (s #f) 'pos 'neg))) + (s-a (contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg)))) (test/spec-passed 'struct/dc-new4 @@ -9414,7 +9414,7 @@ 'struct/dc-new5 '(let () (struct s ([a #:mutable])) - (contract (s-a (struct/dc s [a integer?])) (s #f) 'pos 'neg))) + (s-a (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg)))) (test/neg-blame 'struct/dc-new6 @@ -9423,6 +9423,460 @@ (set-s-a! (contract (struct/dc s [a integer?]) (s 1) 'pos 'neg) #f))) + (test/spec-passed + 'struct/dc-new7 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (b) (<=/c (car b))]) + (s 3 '(2) 1) + 'pos + 'neg)))) + + + (test/spec-passed + 'struct/dc-new8 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (a b) (and/c (<=/c a) (<=/c (car b)))]) + (s 3 '(2) 1) + 'pos + 'neg)))) + + (test/spec-passed + 'struct/dc-new9 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (b a) (and/c (<=/c a) (<=/c (car b)))]) + (s 3 '(2) 1) + 'pos + 'neg)))) + + + (test/spec-passed + 'struct/dc-new10 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a (b) (<=/c (car b))] [b (c) (non-empty-listof real?)] [c real?]) + (s 1 '(2) 3) + 'pos + 'neg)))) + + (test/spec-passed + 'struct/dc-new11 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a (b c) (and/c (<=/c (car b)) (<=/c c))] [b (c) (non-empty-listof real?)] [c real?]) + (s 1 '(2) 3) + 'pos + 'neg)))) + + (test/spec-passed + 'struct/dc-new12 + '(let () + (struct s (a b c)) + (s-c (contract (struct/dc s [a (c b) (and/c (<=/c (car b)) (<=/c c))] [b (c) (non-empty-listof real?)] [c real?]) + (s 1 '(2) 3) + 'pos + 'neg)))) + + + (test/pos-blame + 'struct/dc-new13 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f 1))]) + (s (λ (x) #f) 123) + 'pos + 'neg))) + + (test/spec-failed + 'struct/dc-new14 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f #f))]) + (s (λ (x) 1) 123) + 'pos + 'neg)) + "top-level") + + (test/pos-blame + 'struct/dc-new15 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))]) + (s (λ (x) #f) 123) + 'pos + 'neg))) + + (test/spec-failed + 'struct/dc-new16 + '(let () + (struct s (f b)) + (contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))]) + (s (λ (x) 1) 123) + 'pos + 'neg)) + "top-level") + + (test/pos-blame + 'struct/dc-new17 + '(let () + (struct s (f b)) + (contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))]) + (s (λ (x) #f) 123) + 'pos + 'neg))) + + (test/spec-failed + 'struct/dc-new18 + '(let () + (struct s (f b)) + (contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))]) + (s (λ (x) 1) 123) + 'pos + 'neg)) + "top-level") + + (test/spec-passed + 'struct/dc-new19 + '(let () + (struct s (a b c d)) + (contract (struct/dc s + [a integer?] + [b #:lazy symbol?] + [c (a) boolean?] + [d (a c) integer?]) + (s 1 'x #t 5) + 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new20 + '(let () + (struct s (a [b #:mutable] c [d #:mutable])) + (contract (struct/dc s + [a integer?] + [b symbol?] + [c (a) boolean?] + [d (a c) integer?]) + (s 1 'x #t 5) + 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new21 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a integer?] [b boolean?]) + (s 1 #f) + 'pos 'neg)) + (set-s-a! an-s 2))) + + (test/neg-blame + 'struct/dc-new22 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a integer?] [b boolean?]) + (s 1 #f) + 'pos 'neg)) + (set-s-a! an-s #f))) + + (test/spec-passed + 'struct/dc-new22 + '(let () + (struct s ([a #:mutable] b)) + (contract (struct/dc s [a integer?] [b boolean?]) + (s 'one #f) + 'pos 'neg))) + + (test/pos-blame + 'struct/dc-new23 + '(let () + (struct s ([a #:mutable] b)) + (s-a (contract (struct/dc s [a integer?] [b boolean?]) + (s 'one #f) + 'pos 'neg)))) + + (test/pos-blame + 'struct/dc-new24 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?]) + (s (λ (x) #f) #f) + 'pos 'neg)) + ((s-a an-s) 1))) + + (test/neg-blame + 'struct/dc-new25 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?]) + (s (λ (x) #f) #f) + 'pos 'neg)) + (set-s-a! an-s (λ (x) #f)) + ((s-a an-s) 1))) + + (test/pos-blame + 'struct/dc-new26 + '(let () + (struct s ([a #:mutable] b)) + (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) + (s (λ (x) #f) #f) + 'pos 'neg))) + + (test/pos-blame + 'struct/dc-new27 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -2)) + (s-b an-s))) + + (test/neg-blame + 'struct/dc-new28 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) #f)) + (s-b an-s))) + + (test/pos-blame + 'struct/dc-new29 + '(let () + (struct s ([a #:mutable] b c)) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))] + [c (b) (<=/c b)]) + (s (λ (x) 1) -11 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -2)) + (s-c an-s))) + + (test/pos-blame + 'struct/dc-new30 + '(let () + (struct s ([a #:mutable] b c)) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))] + [c (b) (<=/c b)]) + (s (λ (x) 1) 1 -2) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -2)) + (s-c an-s))) + + (test/neg-blame + 'struct/dc-new31 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-b! an-s 3))) + + (test/pos-blame + 'struct/dc-new32 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b (a) (<=/c (a 1))]) + (s (λ (x) 1) 1) + 'pos 'neg)) + (set-s-a! an-s (λ (x) -1)) + (s-b an-s))) + + (test/spec-failed + 'struct/dc-new33 + '(let () + (struct s (a [b #:mutable] [c #:mutable])) + (define an-s (contract (struct/dc s + [a (-> integer? integer?)] + [b any/c] + [c (a b) (<=/c (a b))]) + (s (λ (x) 1) 1 1) + 'pos 'neg)) + (set-s-b! an-s #f) + (s-c an-s)) + "top-level") + + (contract-error-test + 'struct/dc-new-34 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (contract (struct/dc s + [a boolean?] + [b (a) + #:flat + (if a + (<=/c 1) + (-> integer? integer?))]) + (s #f 1) + 'pos + 'neg)) + (λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-35 + '(let () + (struct s ([a #:mutable] [b #:mutable])) + (define an-s (contract (struct/dc s + [a boolean?] + [b (a) + #:flat + (if a + (<=/c 1) + (-> integer? integer?))]) + (s #t 1) + 'pos + 'neg)) + (set-s-a! an-s #f) + (s-b an-s)) + (λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-36 + '(let () + (struct s ([a #:mutable] b)) + (contract (struct/dc s + [a boolean?] + [b (a) + (if a + (<=/c 1) + (new-∃/c 'α))]) + (s #f 1) + 'pos + 'neg)) + (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-37 + '(let () + (struct s ([a #:mutable] b)) + (define an-s (contract (struct/dc s + [a boolean?] + [b (a) + (if a + (<=/c 1) + (new-∃/c 'α))]) + (s #t 1) + 'pos + 'neg)) + (set-s-a! an-s #f) + (s-b an-s)) + (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) + + (contract-error-test + 'struct/dc-new-38 + '(let () + (struct s ([a #:mutable] b [c #:mutable])) + (define an-s (contract (struct/dc s + [a boolean?] + [b (a) + (if a + (<=/c 1) + (new-∃/c 'α))] + [c (b) integer?]) + (s #t 1 1) + 'pos + 'neg)) + (set-s-a! an-s #f) + (s-c an-s)) + (λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x)))) + + (test/spec-passed + 'struct/dc-new-39 + '(let () + (struct s (a b)) + (contract (struct/dc s [a integer?] [b integer?]) (s 1 2) 'pos 'neg))) + + (test/spec-passed + 'struct/dc-new40 + '(let () + (struct s (a b)) + (contract (struct/dc s [a (-> integer? integer?)] [b (-> integer? integer?)]) + (s (λ (x) x) (λ (y) y)) + 'pos + 'neg))) + + (test/spec-passed/result + 'struct/dc-new41 + '(let () + (struct s (a [b #:mutable])) + (define α (new-∀/c 'α)) + (s-b ((contract (-> α (struct/dc s [b α])) + (λ (x) (s 11 x)) + 'pos + 'neg) 1))) + 1) + + (test/spec-passed/result + 'struct/dc-new42 + '(let () + (struct s (a [b #:mutable])) + (define α (new-∀/c 'α)) + (s-b ((contract (-> α (struct/dc s [a integer?] [b (a) #:impersonator α])) + (λ (x) (s 11 x)) + 'pos + 'neg) 1))) + 1) + + (test/spec-passed + 'struct/dc-new42 + '(let () + (struct s (a [b #:mutable])) + (contract (struct/dc s [a (-> integer? integer?)] [b (new-∀/c 'α)]) + (s (λ (x) x) 1) + 'pos + 'neg))) + + (contract-error-test + 'struct/dc-not-a-field + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a integer?] [y integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-circular-dependecies1 + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a (a) integer?] [b (a) integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-circular-dependecies2 + #'(eval '(let () + (struct s (a b c)) + (struct/dc s [a (b) integer?] [b (a) integer?] [c integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-dep-on-lazy + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a #:lazy integer?] [b (a) integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-lazy-mutable + #'(eval '(let () + (struct s (a [b #:mutable])) + (struct/dc s [a integer?] [b #:lazy integer?]))) + exn:fail:syntax?) + + (contract-error-test + 'struct/dc-immutable-impersonator + #'(eval '(let () + (struct s (a b)) + (struct/dc s [a integer?] [b (a) #:impersonator (<=/c a)]))) + (λ (x) (and (exn:fail:syntax? x) (regexp-match #rx"immutable" (exn-message x))))) + ; ; @@ -10485,9 +10939,11 @@ so that propagation occurs. (define alpha (new-∃/c 'alpha)) (struct/c s alpha))) - (ctest #t (chaperone-contract? - (let ([x (struct/dc s [a integer?] [b integer?])]) - (opt/c x)))) + (ctest #t chaperone-contract? + (let () + (struct s (a b)) + (let ([x (struct/dc s [a integer?] [b integer?])]) + (opt/c x)))) (ctest #t flat-contract? (set/c integer?)) (ctest #f flat-contract? (set/c (-> integer? integer?))) @@ -10618,7 +11074,16 @@ so that propagation occurs. (struct/dc s [a integer?] [b integer?]))) (ctest #t flat-contract? (let () (struct s (a b)) - (struct/dc s [a integer?] [b (a) (>=/c a)]))) + (struct/dc s [a integer?] [b (a) #:flat (>=/c a)]))) + (contract-error-test + 'struct/dc-not-really-flat-dep-field + #'(let () + (struct s (a b)) + (contract (struct/dc s [a integer?] [b (a) #:flat (-> integer? integer?)]) + (s 1 (λ (x) x)) + 'pos + 'neg)) + exn:fail?) (ctest #t chaperone-contract? (let () (struct s (a b)) (struct/dc s [a integer?] [b (a) (>=/c a)]))) @@ -11086,17 +11551,30 @@ so that propagation occurs. (test-name '(struct/dc s [a integer?] - [b #:lazy symbol?] + [b symbol?] [c (a b) ...] [d (a b c) ...]) (let () (struct s (a b c d)) (struct/dc s [a integer?] - [b #:lazy symbol?] + [b symbol?] [c (a b) boolean?] [d (a b c) integer?]))) + (test-name '(struct/dc s + [a integer?] + [b #:lazy symbol?] + [c (a) ...] + [d (a c) ...]) + (let () + (struct s (a b c d)) + (struct/dc s + [a integer?] + [b #:lazy symbol?] + [c (a) boolean?] + [d (a c) integer?]))) + ;; NOT YET RELEASED #; (test-name '(pr/dc [x integer?]