diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt index 6dee8e0e6d..674de51604 100644 --- a/collects/racket/contract/private/opt-guts.rkt +++ b/collects/racket/contract/private/opt-guts.rkt @@ -23,6 +23,7 @@ opt/info-change-val opt/unknown + opt-error-name optres-exp optres-lifts @@ -262,7 +263,7 @@ (build-optres #:exp #'(partial-var val) #:lifts (list (cons #'lift-var - #'(coerce-contract 'opt/c uctc))) + #`(coerce-contract '#,(opt-error-name) uctc))) #:superlifts null #:partials (list (cons @@ -281,6 +282,9 @@ #:chaperone #'(chaperone-contract? lift-var) #:name #'(contract-name lift-var)))) + +(define opt-error-name (make-parameter 'opt/c)) + ;; 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?) (cond diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 7667466be4..6f147d69c0 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -171,26 +171,33 @@ ;; contract combinators and attempts to "unroll" those combinators to save ;; on things such as closure allocation time. (define-syntax (opt/c stx) - (syntax-case stx () - [(_ e) - (let () - (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that)) - (define an-optres (opt/i info #'e)) - (bind-superlifts - (optres-superlifts an-optres) - (bind-lifts - (optres-lifts an-optres) - #`(make-opt-contract - (λ (ctc) - (λ (blame) - #,(bind-superlifts - (optres-partials an-optres) - #`(λ (val) #,(optres-exp an-optres))))) - #,(optres-name an-optres) - (λ (this that) #f) - (vector) - (begin-lifted (box #f)) - #,(optres-chaperone an-optres)))))])) + (define-values (exp error-name-sym) + (syntax-case stx () + [(_ e) (values #'e 'opt/c)] + [(_ e #:error-name x) + (begin + (unless (identifier? #'x) + (raise-syntax-error 'opt/c "expected a name" stx #'x)) + (values #'e (syntax-e #'x)))])) + + (parameterize ([opt-error-name error-name-sym]) + (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that)) + (define an-optres (opt/i info exp)) + (bind-superlifts + (optres-superlifts an-optres) + (bind-lifts + (optres-lifts an-optres) + #`(make-opt-contract + (λ (ctc) + (λ (blame) + #,(bind-superlifts + (optres-partials an-optres) + #`(λ (val) #,(optres-exp an-optres))))) + #,(optres-name an-optres) + (λ (this that) #f) + (vector) + (begin-lifted (box #f)) + #,(optres-chaperone an-optres)))))) ;; this macro optimizes 'e' as a contract, ;; using otherwise-id if it does not recognize 'e'. diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index b086ea4528..46348ec057 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -2247,14 +2247,31 @@ describes the expected type of contract and must be one of the keywords @racket[type] is not given, an impersonator contract is created.} -@defform[(opt/c contract-expr)]{ +@defform/subs[(opt/c contract-expr maybe-name) + ([maybe-name (code:line) + (code:line #:error-name id)])]{ This optimizes its argument contract expression by traversing its syntax and, for known contract combinators, fuses them into a single contract combinator that avoids as much allocation overhead as possible. The result is a contract that should behave identically to its argument, -except faster (due to less allocation).} +except faster. + +If the @racket[#:error-name] argument is present, and +@racket[contract-expr] evaluates to a non-contract +expression, then @racket[opt/c] raises an error using +@racket[id] as the name of the primitive, instead of using +the name @racket[opt/c]. + +@examples[#:eval (contract-eval) + (define/contract (f x) + (opt/c '(not-a-contract)) + x) + (define/contract (f x) + (opt/c '(not-a-contract) #:error-name define/contract) + x)] +} @defform[(define-opt/c (id id ...) expr)]{