From 44fe632da5171acf7ce96a73249bdf633d8c6092 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 9 Sep 2010 21:39:38 -0500 Subject: [PATCH] fixed two bugs in ->i: - when optional arguments didn't also have rest args, it generated the wrong wrapper function - the object-contract interaction was broken; it was not adding the this argument in Also removed the hack added earlier this eve. closes PR 11180 --- .../private/language-object-contract.rkt | 3 +- collects/racket/contract/private/arr-i.rkt | 137 ++++++++++-------- collects/tests/racket/contract-test.rktl | 70 +++++++++ 3 files changed, 150 insertions(+), 60 deletions(-) diff --git a/collects/drracket/private/language-object-contract.rkt b/collects/drracket/private/language-object-contract.rkt index e63b892f1f..ba650c66dc 100644 --- a/collects/drracket/private/language-object-contract.rkt +++ b/collects/drracket/private/language-object-contract.rkt @@ -77,8 +77,7 @@ (unmarshall-settings (-> printable/c any)) (capability-value - (->i ([this any/c] ;; this is a workaround for a bug in ->i and object-contract's interaction! - [s (and/c symbol? + (->i ([s (and/c symbol? drracket:language:capability-registered?)]) [res (s) (drracket:language:get-capability-contract s)]))))]) #`(begin diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 9269407701..fbbf1722ee 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -182,32 +182,37 @@ ;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax ;; (vector-length vars) = (length args) ;; builds the parameter list for the wrapper λ -(define-for-syntax (args/vars->arglist an-istx vars) +(define-for-syntax (args/vars->arglist an-istx vars this-param) (let ([args (istx-args an-istx)]) - (let loop ([args args] - [i 0]) - (cond - [(null? args) (if (istx-rst an-istx) - #'rest-args - #'())] - [else - (let* ([arg (car args)] - [kwd (arg-kwd arg)] - [opt? (arg-optional? arg)] - [arg-exp - (cond - [(and kwd opt?) - #`(#,kwd [#,(vector-ref vars i) the-unsupplied-arg])] - [kwd - #`(#,kwd #,(vector-ref vars i))] - [opt? - #`([#,(vector-ref vars i) the-unsupplied-arg])] - [else - #`(#,(vector-ref vars i))])]) - - #`(#,@arg-exp - . - #,(loop (cdr args) (+ i 1))))])))) + #`(#,@(if this-param + (list this-param) + '()) + . + #, + (let loop ([args args] + [i 0]) + (cond + [(null? args) (if (istx-rst an-istx) + #'rest-args + #'())] + [else + (let* ([arg (car args)] + [kwd (arg-kwd arg)] + [opt? (arg-optional? arg)] + [arg-exp + (cond + [(and kwd opt?) + #`(#,kwd [#,(vector-ref vars i) the-unsupplied-arg])] + [kwd + #`(#,kwd #,(vector-ref vars i))] + [opt? + #`([#,(vector-ref vars i) the-unsupplied-arg])] + [else + #`(#,(vector-ref vars i))])]) + + #`(#,@arg-exp + . + #,(loop (cdr args) (+ i 1))))]))))) (define-for-syntax (all-but-last lst) (reverse (cdr (reverse lst)))) @@ -215,8 +220,9 @@ ;; vars : (listof identifier) ;; vars will contain one identifier for each arg, plus one more for rst, ;; unless rst is #f, in which case it just contains one identifier for each arg. -(define-for-syntax (args/vars->callsite fn args rst vars) - (let ([opts? (ormap arg-optional? args)]) +(define-for-syntax (args/vars->callsite fn args rst vars this-param) + (let ([opts? (ormap arg-optional? args)] + [this-params (if this-param (list this-param) '())]) (cond [(and opts? (ormap arg-kwd args)) (let* ([arg->var (make-hash)] @@ -239,14 +245,16 @@ (list #,@(map cdr sorted-kwd/arg-pairs)) #,(if rst #'rest-args - #'#f) + #''()) + #,@this-params #,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args))))] [opts? ;; has optional args, but no keyword args #`(apply/no-unsupplied #,fn #,(if rst #'rest-args - #'#f) + #''()) + #,@this-params #,@(if rst (all-but-last (vector->list vars)) (vector->list vars)))] @@ -264,8 +272,8 @@ . #,(loop (cdr args) (+ i 1))))]))]) (if rst - #`(apply #,fn #,@middle-arguments rest-args) - #`(#,fn #,@middle-arguments)))]))) + #`(apply #,fn #,@this-params #,@middle-arguments rest-args) + #`(#,fn #,@this-params #,@middle-arguments)))]))) (define (apply/no-unsupplied fn rest-args . args) (apply fn (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) @@ -429,6 +437,16 @@ body))] [else stx])) +(define-for-syntax (maybe-a-method/name stx) + (if (syntax-parameter-value #'making-a-method) + (syntax-property stx 'method-arity-error #t) + stx)) + +(define-for-syntax (maybe-make-contracted-function fn ctc) + (if (syntax-parameter-value #'making-a-method) + fn + #`(make-contracted-function #,fn #,ctc))) + (define-for-syntax (mk-wrapper-func an-istx used-indy-vars) (let ([args+rst (append (istx-args an-istx) (if (istx-rst an-istx) @@ -485,6 +503,9 @@ [(free-identifier=? var arg) iarg] [else (loop (cdr iargs) (cdr args))]))]))) + (define this-param (and (syntax-parameter-value #'making-a-method) + (car (generate-temporaries '(this))))) + #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc ;; the pre- and post-condition procs @@ -520,35 +541,35 @@ (λ (val) (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) - (make-contracted-function - #,(syntax-property - #`(λ #,(args/vars->arglist an-istx wrapper-args) - #,(add-wrapper-let - (add-pre-cond - an-istx - arg/res-to-indy-var - (add-eres-lets - an-istx - res-proj-vars - arg/res-to-indy-var - (add-result-checks - an-istx - ordered-ress res-indicies - res-proj-vars indy-res-proj-vars - wrapper-ress indy-res-vars - arg/res-to-indy-var - (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args)))) - #t - ordered-args arg-indicies - arg-proj-vars indy-arg-proj-vars - wrapper-args indy-arg-vars - arg/res-to-indy-var)) - 'inferred-name - (syntax-local-name)) - ctc))))))) + #,(maybe-make-contracted-function + (maybe-a-method/name + (syntax-property + #`(λ #,(args/vars->arglist an-istx wrapper-args this-param) + #,(add-wrapper-let + (add-pre-cond + an-istx + arg/res-to-indy-var + (add-eres-lets + an-istx + res-proj-vars + arg/res-to-indy-var + (add-result-checks + an-istx + ordered-ress res-indicies + res-proj-vars indy-res-proj-vars + wrapper-ress indy-res-vars + arg/res-to-indy-var + (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args this-param)))) + #t + ordered-args arg-indicies + arg-proj-vars indy-arg-proj-vars + wrapper-args indy-arg-vars + arg/res-to-indy-var)) + 'inferred-name + (syntax-local-name))) + #'ctc))))))) (define (un-dep ctc obj blame) - ;; WRONG (well, maybe just need to avoid calling coerce-contract if 'ctc' is something simple) (let ([ctc (coerce-contract '->i ctc)]) (((contract-projection ctc) blame) obj))) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 5e1fbd9044..71feaaa452 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -2092,6 +2092,76 @@ '->i22 '((contract (->i () () #:rest [rst (listof number?)] [r any/c]) (lambda w 1) 'pos 'neg) #f)) + (test/spec-passed/result + '->i22 + '(send (contract (object-contract + [m (->i ([x any/c] #:y [y any/c]) ([z any/c]) any)]) + (new (class object% + (define/public (m x #:y y [z 1]) x) + (super-new))) + 'pos + 'neg) + m 1 #:y 2) + 1) + + (test/spec-passed/result + '->i23 + '((contract (->i ([x any/c] #:y [y any/c]) ([z any/c]) any) + (let () + (define (m x #:y y [z 1]) x) + m) + 'pos + 'neg) + 1 #:y 2) + 1) + + (test/spec-passed/result + '->i24 + '((contract (->i ([x any/c]) ([y any/c]) any) + (let () + (define (m x [y 1]) x) + m) + 'pos + 'neg) + 1) + 1) + + (test/spec-passed/result + '->i25 + '(send (contract (object-contract + [m (->i ([x any/c]) ([y any/c]) any)]) + (new (class object% + (define/public (m x [y 1]) x) + (super-new))) + 'pos + 'neg) + m 1) + 1) + + (test/spec-passed/result + '->i26 + '(send (contract (object-contract + [m (->i ([x any/c]) #:rest [rest any/c] any)]) + (new (class object% + (define/public (m x . y) x) + (super-new))) + 'pos + 'neg) + m 1) + 1) + + (test/spec-passed/result + '->i27 + '(send (contract (object-contract + [m (->i ([x any/c]) any)]) + (new (class object% + (define/public (m x) x) + (super-new))) + 'pos + 'neg) + m 1) + 1) + (test/spec-passed '->i-any1 '((contract (->i () () any) (lambda () 1) 'pos 'neg)))