diff --git a/collects/drracket/syncheck.rkt b/collects/drracket/syncheck.rkt index ea773df640..4d99943b61 100644 --- a/collects/drracket/syncheck.rkt +++ b/collects/drracket/syncheck.rkt @@ -2108,6 +2108,30 @@ If the namespace does not, they are colored the unbound color. (color-unused requires unused-requires) (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) + (define (annotate-contracts stx) + (define start-map (make-hash)) + (define arrow-map (make-hash)) + (define domain-map (make-hash)) + (define range-map (make-hash)) + (define (add-to-map stx prop map) + (let loop ([val (syntax-property stx prop)]) + (cond + [(symbol? val) + (hash-set! map val (cons stx (hash-ref map val '())))] + [(pair? val) + (loop (car val)) + (loop (cdr val))]))) + + (let loop ([stx stx]) + (add-to-map stx 'racket/contract:contract-on-boundary start-map) + (add-to-map stx 'racket/contract:domain-of domain-map) + (add-to-map stx 'racket/contract:rng-of range-map) + (add-to-map stx 'racket/contract:function-contract arrow-map) + (syntax-case stx () + [(a . b) (loop #'a) (loop #'b)] + [else (void)]))) + +#| (define (annotate-contracts stx) (let loop ([stx stx]) (let sloop ([prop (syntax-property stx 'provide/contract-original-contract)]) @@ -2141,7 +2165,7 @@ If the namespace does not, they are colored the unbound color. (base-color stx polarity)] [else (color stx unk-obligation-style-name 'contract-mode)]))) - +|# ;; returns #t if the result is known to be a predicate that shoudl correspond to a ;; complete obligation for the contract. If it is some unknown variable, this variable ;; may refer to some other contract with nested obligations, so we have to return #f here. diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 1b8863cee4..b9be4f982f 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -350,14 +350,18 @@ v4 todo: ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) (define-for-syntax (->/proc/main stx) - (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)]) + (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)] + [(this->) (gensym 'this->)]) (with-syntax ([(args body) inner-args/body]) (with-syntax ([(dom-names ...) dom-names] [(rng-names ...) rng-names] [(kwd-names ...) kwd-names] - [(dom-ctcs ...) dom-ctcs] - [(rng-ctcs ...) rng-ctcs] - [(kwd-ctcs ...) kwd-ctcs] + [(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->)) + (syntax->list dom-ctcs))] + [(rng-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:rng-of this->)) + (syntax->list rng-ctcs))] + [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->)) + (syntax->list kwd-ctcs))] [(kwds ...) kwds] [inner-lambda (maybe-a-method/name @@ -371,12 +375,15 @@ v4 todo: (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (make-contracted-function inner-lambda ctc)))]) (values - (syntax - (build--> '-> - (list dom-ctcs ...) '() #f - (list kwd-ctcs ...) '(kwds ...) '() '() - (list rng-ctcs ...) use-any? - outer-lambda)) + (syntax-property + (syntax + (build--> '-> + (list dom-ctcs ...) '() #f + (list kwd-ctcs ...) '(kwds ...) '() '() + (list rng-ctcs ...) use-any? + outer-lambda)) + 'racket/contract:function-contract + this->) inner-args/body (syntax (dom-names ... rng-names ...)))))))) diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index 578bbe6b83..9fb5ebabf1 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -663,9 +663,12 @@ (code-for-one-id/new-name stx id reflect-id ctrct user-rename-id #f #t)] [(stx id reflect-id ctrct user-rename-id mangle-for-maker?) (code-for-one-id/new-name id reflect-id ctrct user-rename-id mangle-for-maker? #t)] - [(stx id reflect-id ctrct user-rename-id mangle-for-maker? provide?) - (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)] - [ex-id (or reflect-id id)]) + [(stx id reflect-id ctrct/no-prop user-rename-id mangle-for-maker? provide?) + (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)] + [ex-id (or reflect-id id)] + [ctrct (syntax-property ctrct/no-prop + 'racket/contract:contract-on-boundary + (gensym 'provide/contract-boundary))]) (with-syntax ([id-rename ((if mangle-for-maker? a:mangle-id-for-maker a:mangle-id)