diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt index 5bcd36f156..b52aaf9dae 100644 --- a/collects/racket/contract/private/box.rkt +++ b/collects/racket/contract/private/box.rkt @@ -4,7 +4,7 @@ "guts.rkt") (provide box-immutable/c - (rename-out [build-box/c box/c])) + (rename-out [wrap-box/c box/c])) (define-syntax (*-immutable/c stx) (syntax-case stx () @@ -175,6 +175,41 @@ #:first-order box/c-first-order #:projection (ho-projection proxy-box))) +(define-syntax (wrap-box/c stx) + (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + (syntax/loc stx build-box/c) + 'racket/contract:contract + (vector (gensym 'ctc) (list #'x) null))] + [(b/c arg ...) + (let ([args (syntax->list #'(arg ...))] + [this-one (gensym 'ctc)]) + (define (convert-args args) + (let loop ([args args] + [new-args null]) + (cond + [(null? args) (reverse new-args)] + [(keyword? (syntax-e (car args))) + (if (null? (cdr args)) + (reverse (cons (car args) new-args)) + (loop (cddr args) + (list* (cadr args) (car args) new-args)))] + [else (append (reverse new-args) + (cons (syntax-property + (car args) + 'racket/contract:positive-position + this-one) + (cdr args)))]))) + (with-syntax ([(new-arg ...) (convert-args args)] + [app (datum->syntax stx '#%app)]) + (syntax-property + (syntax/loc stx + (app build-box/c new-arg ...)) + 'racket/contract:contract + (vector this-one (list #'b/c) null))))])) + (define (build-box/c elem #:immutable [immutable 'dont-care] #:flat? [flat? #f]) (let ([ctc (if flat? (coerce-flat-contract 'box/c elem) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 0008bc6beb..fedd38fdcc 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -10019,6 +10019,9 @@ so that propagation occurs. '((racket/contract:contract (hash/c) ()) (racket/contract:negative-position a) (racket/contract:positive-position b))) + (test-obligations '(box/c a) + '((racket/contract:contract (box/c) ()) + (racket/contract:positive-position a))) ;