diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt index 8a08b8e833..8b7c9a370c 100644 --- a/collects/drracket/private/syncheck/contract-traversal.rkt +++ b/collects/drracket/private/syncheck/contract-traversal.rkt @@ -26,7 +26,7 @@ (add-to-map stx 'racket/contract:function-contract arrow-map) (syntax-case stx () [(a . b) (loop #'a) (loop #'b)] - [else (void)])) + [_ (void)])) ;; fill in the coloring-plans table for boundary contracts (for ([(start-k start-val) (in-hash boundary-start-map)]) @@ -128,6 +128,14 @@ (for ((rhs (in-list (module-identifier-mapping-get binding-inits binder)))) (ploop rhs polarity)))) (call-give-up))))] + [const + (let ([val (syntax-e #'const)]) + (or (boolean? val) + (number? val) + (string? val) + (char? val) + (regexp? val))) + (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)] [(#%plain-lambda (id) expr ...) (identifier? #'id) (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)] @@ -165,7 +173,7 @@ [(set! a b) (call-give-up)] [(quote stuff) - (call-give-up)] + (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)] [(quote-syntax stuff) (call-give-up)] [(with-continuation-mark a b c) @@ -175,7 +183,12 @@ [(#%top . id) (call-give-up)] [(#%variable-reference ignored ...) - (call-give-up)])])))) + (call-give-up)] + [_ + (begin + #;(error 'contract-traversal.rkt "unknown thing: ~s\n" stx) + (call-give-up)) + ])])))) ;; add-to-map : syntax any hash[any -> (listof stx)] ;; looks at stx's property prop and updates map, diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt index 88fa0fbd29..c324487a6f 100644 --- a/collects/racket/contract/private/guts.rkt +++ b/collects/racket/contract/private/guts.rkt @@ -143,6 +143,72 @@ [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)] [else #f])) +(define-syntax (define/final-prop stx) + (syntax-case stx () + [(_ header bodies ...) + (with-syntax ([ctc (if (identifier? #'header) + #'header + (car (syntax-e #'header)))]) + (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) + #'(begin + (define ctc/proc + (let () + (define header bodies ...) + ctc)) + (define-syntax (ctc stx) + (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + #'ctc/proc + 'racket/contract:contract + (vector (gensym 'ctc) + (list stx) + '()))] + [(_ margs (... ...)) + (with-syntax ([app (datum->syntax stx '#%app)]) + (syntax-property + #'(app ctc/proc margs (... ...)) + 'racket/contract:contract + (vector (gensym 'ctc) + (list (car (syntax-e stx))) + '())))])))))])) + +(define-syntax (define/subexpression-pos-prop stx) + (syntax-case stx () + [(_ header bodies ...) + (with-syntax ([ctc (if (identifier? #'header) + #'header + (car (syntax-e #'header)))]) + (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) + #'(begin + (define ctc/proc + (let () + (define header bodies ...) + ctc)) + (define-syntax (ctc stx) + (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + #'ctc/proc + 'racket/contract:contract + (vector (gensym 'ctc) + (list stx) + '()))] + [(_ margs (... ...)) + (let ([this-one (gensym 'ctc)]) + (with-syntax ([(margs (... ...)) + (map (λ (x) (syntax-property x 'racket/contract:positive-position this-one)) + (syntax->list #'(margs (... ...))))] + [app (datum->syntax stx '#%app)]) + (syntax-property + #'(app ctc/proc margs (... ...)) + 'racket/contract:contract + (vector this-one + (list (car (syntax-e stx))) + '()))))])))))])) + ; ; ; @@ -239,7 +305,7 @@ this-ctcs that-ctcs))))))) -(define (and/c . raw-fs) +(define/subexpression-pos-prop (and/c . raw-fs) (let ([contracts (coerce-contracts 'and/c raw-fs)]) (cond [(null? contracts) any/c] @@ -273,7 +339,7 @@ #:name (λ (ctc) 'any/c) #:first-order get-any?)) -(define any/c (make-any/c)) +(define/final-prop any/c (make-any/c)) (define (none-curried-proj ctc) (λ (blame) @@ -294,7 +360,7 @@ #:name (λ (ctc) (none/c-name ctc)) #:first-order (λ (ctc) (λ (val) #f)))) -(define none/c (make-none/c 'none/c)) +(define/final-prop none/c (make-none/c 'none/c)) @@ -379,66 +445,3 @@ (define (build-flat-contract name pred) (make-predicate-contract name pred)) -(define-syntax (define/final-prop stx) - (syntax-case stx () - [(_ header bodies ...) - (with-syntax ([ctc (if (identifier? #'header) - #'header - (car (syntax-e #'header)))]) - (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) - #'(begin - (define ctc/proc - (let () - (define header bodies ...) - ctc)) - (define-syntax (ctc stx) - (syntax-case stx () - [x - (identifier? #'x) - (syntax-property - #'x - 'racket/contract:contract - (vector (gensym 'ctc) - (list stx) - '()))] - [(_ margs (... ...)) - (syntax-property - #'(ctc/proc margs (... ...)) - 'racket/contract:contract - (vector (gensym 'ctc) - (list (car (syntax-e stx))) - '()))])))))])) - -(define-syntax (define/subexpression-pos-prop stx) - (syntax-case stx () - [(_ header bodies ...) - (with-syntax ([ctc (if (identifier? #'header) - #'header - (car (syntax-e #'header)))]) - (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) - #'(begin - (define ctc/proc - (let () - (define header bodies ...) - ctc)) - (define-syntax (ctc stx) - (syntax-case stx () - [x - (identifier? #'x) - (syntax-property - #'ctc/proc - 'racket/contract:contract - (vector (gensym 'ctc) - (list stx) - '()))] - [(_ margs (... ...)) - (let ([this-one (gensym 'ctc)]) - (with-syntax ([(margs (... ...)) - (map (λ (x) (syntax-property x 'racket/contract:positive-position this-one)) - (syntax->list #'(margs (... ...))))]) - (syntax-property - #'(ctc/proc margs (... ...)) - 'racket/contract:contract - (vector this-one - (list (car (syntax-e stx))) - '()))))])))))]))