diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index d0ad9a3fe6..19ff62c7f9 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -44,7 +44,8 @@ v4 todo: contracted-function-proc contracted-function-ctc make-contracted-function - matches-arity-exactly?) + matches-arity-exactly? + bad-number-of-results) (define-syntax-parameter making-a-method #f) (define-for-syntax (make-this-parameters id) diff --git a/collects/racket/contract/private/basic-opters.rkt b/collects/racket/contract/private/basic-opters.rkt index 5842c9683d..9779636bee 100644 --- a/collects/racket/contract/private/basic-opters.rkt +++ b/collects/racket/contract/private/basic-opters.rkt @@ -30,7 +30,8 @@ null (syntax (pred val)) #f - null))) + null + #t))) ;; ;; built-in predicate opters @@ -41,6 +42,9 @@ (define/opter (boolean? opt/i opt/info stx) (syntax-case stx (boolean?) [boolean? (opt/pred opt/info #'boolean?)])) +(define/opter (string? opt/i opt/info stx) + (syntax-case stx (string?) + [string? (opt/pred opt/info #'string?)])) (define/opter (integer? opt/i opt/info stx) (syntax-case stx (integer?) [integer? (opt/pred opt/info #'integer?)])) @@ -69,7 +73,8 @@ null #'#t #f - null)])) + null + #t)])) ;; ;; false/c @@ -82,12 +87,13 @@ ;; flat-contract helper ;; (define-for-syntax (opt/flat-ctc opt/info pred checker) - (syntax-case pred (null? number? integer? boolean? pair? not) + (syntax-case pred (null? number? integer? boolean? string? pair? not) ;; Better way of doing this? [null? (opt/pred opt/info pred)] [number? (opt/pred opt/info pred)] [integer? (opt/pred opt/info pred)] [boolean? (opt/pred opt/info pred)] + [string? (opt/pred opt/info pred)] [pair? (opt/pred opt/info pred)] [pred (let* ((lift-vars (generate-temporaries (syntax (pred error-check)))) @@ -113,7 +119,8 @@ null (syntax (lift-pred val)) #f - null)))])) + null + #t)))])) ;; ;; flat-contract and friends diff --git a/collects/racket/contract/private/ds-helpers.rkt b/collects/racket/contract/private/ds-helpers.rkt index 09d445823d..875b26bd34 100644 --- a/collects/racket/contract/private/ds-helpers.rkt +++ b/collects/racket/contract/private/ds-helpers.rkt @@ -148,7 +148,8 @@ which are then called when the contract's fields are explored null #f #f - null)] + null + #f)] [else (opt/i (opt/info-change-val id opt/info) stx)])) @@ -186,7 +187,7 @@ which are then called when the contract's fields are explored [(id (x ...) ctc-exp) (and (identifier? (syntax id)) (andmap identifier? (syntax->list (syntax (x ...))))) - (let*-values ([(next lifts superlifts partials _ _2 _3) + (let*-values ([(next lifts superlifts partials _ _2 _3 chaperone?) (opt/enforcer-clause let-var (syntax ctc-exp))] [(maker-arg) (with-syntax ([val (opt/info-val opt/info)] @@ -220,7 +221,7 @@ which are then called when the contract's fields are explored (syntax->list (syntax (x ...)))))] [(id ctc-exp) (identifier? (syntax id)) - (let*-values ([(next lifts superlifts partials _ __ stronger-ribs) + (let*-values ([(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/enforcer-clause let-var (syntax ctc-exp))] [(maker-arg) (with-syntax ((val (opt/info-val opt/info))) diff --git a/collects/racket/contract/private/ds.rkt b/collects/racket/contract/private/ds.rkt index 2fdaeed961..30f242a1be 100644 --- a/collects/racket/contract/private/ds.rkt +++ b/collects/racket/contract/private/ds.rkt @@ -460,7 +460,9 @@ it around flattened out. partials #f #f - stronger-ribs)))))))])) + stronger-ribs + ;; opt'd struct contracts don't use chaperones yet + #f)))))))])) ))))) (define-syntax (define-contract-struct stx) diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt index d381c6e1f9..c7f0949471 100644 --- a/collects/racket/contract/private/opt-guts.rkt +++ b/collects/racket/contract/private/opt-guts.rkt @@ -181,4 +181,5 @@ [partial-flat-var partial-flat-var]) #'(partial-flat-var val)) lift-var - null))) + null + #f))) diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 5487af7239..bd8df429a8 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -107,7 +107,8 @@ null #f #f - null)] + null + #t)] [else (opt/unknown opt/i opt/info stx)])) @@ -150,7 +151,7 @@ #f #'this #'that)] - [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) + [(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)]) (with-syntax ([next next]) (bind-superlifts superlifts diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt index 93c3bee551..a1d4ee8c8e 100644 --- a/collects/racket/contract/private/opters.rkt +++ b/collects/racket/contract/private/opters.rkt @@ -5,6 +5,7 @@ "arrow.rkt" "blame.rkt" "misc.rkt" + "arrow.rkt" (for-syntax racket/base syntax/stx "opt-guts.rkt")) @@ -39,7 +40,7 @@ (let ((lift-from-hos null) (superlift-from-hos null) (partial-from-hos null)) - (let-values ([(opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc) + (let-values ([(opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc chaperone?) (let loop ([ps ps] [next-ps null] [lift-ps null] @@ -47,7 +48,8 @@ [partial-ps null] [stronger-ribs null] [hos null] - [ho-ctc #f]) + [ho-ctc #f] + [chaperone? #t]) (cond [(null? ps) (values next-ps lift-ps @@ -55,9 +57,10 @@ partial-ps stronger-ribs (reverse hos) - ho-ctc)] + ho-ctc + chaperone?)] [else - (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?) (opt/i opt/info (car ps))]) (if flat (loop (cdr ps) @@ -67,7 +70,8 @@ (append partial-ps partial) (append this-stronger-ribs stronger-ribs) hos - ho-ctc) + ho-ctc + (and chaperone? this-chaperone?)) (if (< (length hos) 1) (loop (cdr ps) next-ps @@ -76,7 +80,8 @@ (append partial-ps partial) (append this-stronger-ribs stronger-ribs) (cons (car ps) hos) - next) + next + (and chaperone? this-chaperone?)) (loop (cdr ps) next-ps lift-ps @@ -84,7 +89,8 @@ partial-ps stronger-ribs (cons (car ps) hos) - ho-ctc))))]))]) + ho-ctc + (and chaperone? this-chaperone?)))))]))]) (with-syntax ((next-ps (with-syntax (((opt-p ...) (reverse opt-ps))) (syntax (or opt-p ...))))) @@ -99,9 +105,10 @@ (raise-blame-error blame val "none of the branches of the or/c matched"))))] - [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) - (syntax - (if next-ps val ho-ctc)))] + [(= (length hos) 1) + (with-syntax ((ho-ctc ho-ctc)) + (syntax + (if next-ps val ho-ctc)))] ;; FIXME something's not right with this case. [(> (length hos) 1) (let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos) @@ -117,7 +124,8 @@ (append partial-ps partial-from-hos) (if (null? hos) (syntax next-ps) #f) #f - stronger-ribs))))) + stronger-ribs + chaperone?))))) (syntax-case stx (or/c) [(or/c p ...) @@ -167,7 +175,8 @@ (λ (this that) (with-syntax ([this this] [that that]) - (syntax (<= this that)))))))))))])) + (syntax (<= this that)))))) + #t)))))])) (define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg) (with-syntax ([comparison comparison]) @@ -199,7 +208,8 @@ (λ (this that) (with-syntax ([this this] [that that]) - (syntax (comparison this that))))))))))))) + (syntax (comparison this that)))))) + #t))))))) (define/opter (>=/c opt/i opt/info stx) (syntax-case stx (>=/c) @@ -245,64 +255,6 @@ #'< #'high)])) -(define/opter (cons/c opt/i opt/info stx) - (define (opt/cons-ctc hdp tlp) - (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) - (opt/i opt/info hdp)] - [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) - (opt/i opt/info tlp)] - [(error-check) (car (generate-temporaries (syntax (error-check))))]) - (with-syntax ((next (with-syntax ((flat-hdp flat-hdp) - (flat-tlp flat-tlp) - (val (opt/info-val opt/info))) - (syntax - (and (pair? val) - (let ((val (car val))) flat-hdp) - (let ((val (cdr val))) flat-tlp)))))) - (values - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (blame (opt/info-blame opt/info))) - (syntax (if next - val - (raise-blame-error - blame - val - "expected: ~s, given: ~e" - (contract-name ctc) - val)))) - (append - lifts-hdp lifts-tlp - (list (cons error-check - (with-syntax ((hdp hdp) - (tlp tlp) - (check (with-syntax ((flat-hdp - (cond - [unknown-hdp - (with-syntax ((ctc unknown-hdp)) - (syntax (flat-contract/predicate? ctc)))] - [else (if flat-hdp #'#t #'#f)])) - (flat-tlp - (cond - [unknown-tlp - (with-syntax ((ctc unknown-tlp)) - (syntax (flat-contract/predicate? ctc)))] - [else (if flat-tlp #'#t #'#f)]))) - (syntax (and flat-hdp flat-tlp))))) - (syntax - (unless check - (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" - hdp tlp))))))) - (append superlifts-hdp superlifts-tlp) - (append partials-hdp partials-tlp) - (syntax (if next #t #f)) - #f - (append stronger-ribs-hd stronger-ribs-tl))))) - - (syntax-case stx (cons/c) - [(cons/c hdp tlp) - (opt/cons-ctc #'hdp #'tlp)])) - ;; only used by the opters (define (flat-contract/predicate? pred) (or (flat-contract? pred) @@ -311,9 +263,9 @@ (define/opter (cons/c opt/i opt/info stx) (define (opt/cons-ctc hdp tlp) - (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) + (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd hd-chaperone?) (opt/i opt/info hdp)] - [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) + [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl tl-chaperone?) (opt/i opt/info tlp)]) (with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) (syntax (pair? val))))) @@ -344,7 +296,8 @@ (let ((val (cdr val))) flat-tlp)) #t #f))) #f) #f - (append stronger-ribs-hd stronger-ribs-tl))))) + (append stronger-ribs-hd stronger-ribs-tl) + (and hd-chaperone? tl-chaperone?))))) (syntax-case stx (cons/c) [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) @@ -357,22 +310,24 @@ (define (opt/arrow-ctc doms rngs) (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) (generate-temporaries rngs))] - [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone?) (let loop ([vars dom-vars] [doms doms] [next-doms null] [lifts-doms null] [superlifts-doms null] [partials-doms null] - [stronger-ribs null]) + [stronger-ribs null] + [chaperone? #t]) (cond [(null? doms) (values (reverse next-doms) lifts-doms superlifts-doms partials-doms - stronger-ribs)] + stronger-ribs + chaperone?)] [else - (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?) (opt/i (opt/info-swap-blame opt/info) (car doms))]) (loop (cdr vars) (cdr doms) @@ -383,23 +338,26 @@ (append lifts-doms lift) (append superlifts-doms superlift) (append partials-doms partial) - (append this-stronger-ribs stronger-ribs)))]))] - [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) + (append this-stronger-ribs stronger-ribs) + (and chaperone? this-chaperone?)))]))] + [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?) (let loop ([vars rng-vars] [rngs rngs] [next-rngs null] [lifts-rngs null] [superlifts-rngs null] [partials-rngs null] - [stronger-ribs null]) + [stronger-ribs null] + [chaperone? #t]) (cond [(null? rngs) (values (reverse next-rngs) lifts-rngs superlifts-rngs partials-rngs - stronger-ribs)] + stronger-ribs + chaperone?)] [else - (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?) (opt/i opt/info (car rngs))]) (loop (cdr vars) (cdr rngs) @@ -410,44 +368,56 @@ (append lifts-rngs lift) (append superlifts-rngs superlift) (append partials-rngs partial) - (append this-stronger-ribs stronger-ribs)))]))]) + (append this-stronger-ribs stronger-ribs) + (and chaperone? this-chaperone?)))]))]) (values (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars)) + (rng-len (length rng-vars)) ((next-rng ...) next-rngs)) (syntax (begin (check-procedure val #f dom-len 0 '() '() #| keywords |# blame) - (λ (dom-arg ...) - (let-values ([(rng-arg ...) (val next-dom ...)]) - (values next-rng ...)))))) + (chaperone-procedure + val + (λ (dom-arg ...) + (values + (case-lambda + [(rng-arg ...) + (values next-rng ...)] + [args + (bad-number-of-results blame val rng-len args)]) + next-dom ...)))))) (append lifts-doms lifts-rngs) (append superlifts-doms superlifts-rngs) (append partials-doms partials-rngs) #f #f - (append stronger-ribs-dom stronger-ribs-rng)))) + (append stronger-ribs-dom stronger-ribs-rng) + (and dom-chaperone? rng-chaperone?)))) (define (opt/arrow-any-ctc doms) (let*-values ([(dom-vars) (generate-temporaries doms)] - [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone?) (let loop ([vars dom-vars] [doms doms] [next-doms null] [lifts-doms null] [superlifts-doms null] [partials-doms null] - [stronger-ribs null]) + [stronger-ribs null] + [chaperone? #t]) (cond [(null? doms) (values (reverse next-doms) lifts-doms superlifts-doms partials-doms - stronger-ribs)] + stronger-ribs + chaperone?)] [else - (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?) (opt/i (opt/info-swap-blame opt/info) (car doms))]) (loop (cdr vars) (cdr doms) @@ -458,7 +428,8 @@ (append lifts-doms lift) (append superlifts-doms superlift) (append partials-doms partial) - (append this-stronger-ribs stronger-ribs)))]))]) + (append this-stronger-ribs stronger-ribs) + (and chaperone? this-chaperone?)))]))]) (values (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) @@ -466,28 +437,43 @@ (dom-len (length dom-vars))) (syntax (begin (check-procedure val #f dom-len 0 '() '() #|keywords|# blame) - (λ (dom-arg ...) - (val next-dom ...))))) + (chaperone-procedure + val + (λ (dom-arg ...) + (values next-dom ...)))))) lifts-doms superlifts-doms partials-doms #f #f - stronger-ribs-dom))) + stronger-ribs-dom + dom-chaperone?))) (syntax-case* stx (-> values any) module-or-top-identifier=? [(-> dom ... (values rng ...)) (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword - (opt/arrow-ctc (syntax->list (syntax (dom ...))) - (syntax->list (syntax (rng ...)))))] + (let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?) + (opt/arrow-ctc (syntax->list (syntax (dom ...))) + (syntax->list (syntax (rng ...))))]) + (if chaperone? + (values next lift superlift partial flat _ stronger-ribs chaperone?) + (opt/unknown opt/i opt/info stx))))] [(-> dom ... any) (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword - (opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))] + (let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?) + (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]) + (if chaperone? + (values next lift superlift partial flat _ stronger-ribs chaperone?) + (opt/unknown opt/i opt/info stx))))] [(-> dom ... rng) (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword - (opt/arrow-ctc (syntax->list (syntax (dom ...))) - (list #'rng)))])) + (let-values ([(next lift superlift partial flat _ stronger-ribs chaperone?) + (opt/arrow-ctc (syntax->list (syntax (dom ...))) + (list #'rng))]) + (if chaperone? + (values next lift superlift partial flat _ stronger-ribs chaperone?) + (opt/unknown opt/i opt/info stx))))]))