suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed two bugs in ->i:

Browse Source 
- 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
This commit is contained in:
Robby Findler 2010-09-09 21:39:38 -05:00
parent 0166ece180
commit 44fe632da5
3 changed files with 150 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drracket/private/language-object-contract.rkt
View File

@ -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

137
collects/racket/contract/private/arr-i.rkt
View File

@ -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)))

70
collects/tests/racket/contract-test.rktl
View File

@ -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)))