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

Conversion of -> to impersonators.

Browse Source
This commit is contained in:
Stevie Strickland 2010-12-08 12:34:21 -05:00
parent b342033b7f
commit 0c4658f718
1 changed files with 100 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -231,7 +231,12 @@
;; vars : (listof identifier) ;; vars : (listof identifier)
;; vars will contain one identifier for each arg, plus one more for rst, ;; 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. ;; 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 this-param) ;;
;; FIXME: Currently, none of the resulting argument checkers attempt to preserve tail
;; recursion. If all of the result contracts (which would need to be passed to
;; this function as well as results-checkers) can be evaluated early, then we can
;; preserve tail recursion in the fashion of -> etc.
(define-for-syntax (args/vars->arg-checker result-checkers args rst vars this-param)
(let ([opts? (ormap arg-optional? args)] (let ([opts? (ormap arg-optional? args)]
[this-params (if this-param (list this-param) '())]) [this-params (if this-param (list this-param) '())])
(cond (cond
@ -250,8 +255,8 @@
(λ (x y) (keyword<? (syntax-e (car x)) (syntax-e (car y)))))]) (λ (x y) (keyword<? (syntax-e (car x)) (syntax-e (car y)))))])
;; has both optional and keyword args ;; has both optional and keyword args
#`(keyword-apply/no-unsupplied #`(keyword-return/no-unsupplied
#,fn #,(if (null? result-checkers) #f (car result-checkers))
'#,(map car sorted-kwd/arg-pairs) '#,(map car sorted-kwd/arg-pairs)
(list #,@(map cdr sorted-kwd/arg-pairs)) (list #,@(map cdr sorted-kwd/arg-pairs))
#,(if rst #,(if rst
@ -261,36 +266,42 @@
#,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args))))] #,@(map (λ (arg) (hash-ref arg->var arg)) non-kwd-args))))]
[opts? [opts?
;; has optional args, but no keyword args ;; has optional args, but no keyword args
#`(apply/no-unsupplied #,fn #`(return/no-unsupplied #,(if (null? result-checkers) #f (car result-checkers))
#,(if rst #,(if rst
#'rest-args #'rest-args
#''()) #''())
#,@this-params #,@this-params
#,@(if rst #,@(if rst
(all-but-last (vector->list vars)) (all-but-last (vector->list vars))
(vector->list vars)))] (vector->list vars)))]
[else [else
(let ([middle-arguments (let*-values ([(rev-regs rev-kwds)
(let loop ([args args] (for/fold ([regs null]
[i 0]) [kwds null])
(cond ([arg (in-list args)]
[(null? args) #'()] [i (in-naturals)])
[else (if (arg-kwd arg)
(let ([arg (car args)]) (values regs (cons (vector-ref vars i) kwds))
#`(#,@(if (arg-kwd arg) (values (cons (vector-ref vars i) regs) kwds)))]
#`(#,(arg-kwd arg) #,(vector-ref vars i)) [(regular-arguments keyword-arguments)
#`(#,(vector-ref vars i))) (values (reverse rev-regs) (reverse rev-kwds))])
. (cond
#,(loop (cdr args) (+ i 1))))]))]) [(and (null? keyword-arguments) rst)
(if rst #`(apply values #,@result-checkers #,@this-params #,@regular-arguments rest-args)]
#`(apply #,fn #,@this-params #,@middle-arguments rest-args) [(null? keyword-arguments)
#`(#,fn #,@this-params #,@middle-arguments)))]))) #`(values #,@result-checkers #,@this-params #,@regular-arguments)]
[rst
#`(apply values #,@result-checkers (list #,@keyword-arguments) #,@this-params #,@regular-arguments rest-args)]
[else
#`(values #,@result-checkers (list #,@keyword-arguments) #,@this-params #,@regular-arguments)]))])))
(define (apply/no-unsupplied fn rest-args . args) (define (return/no-unsupplied res-checker rest-args . args)
(apply fn (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) (if res-checker
rest-args))) (apply values res-checker
(append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))
(apply values (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))))
(define (keyword-apply/no-unsupplied fn kwds kwd-args rest-args . args) (define (keyword-return/no-unsupplied res-checker kwds kwd-args rest-args . args)
(let-values ([(supplied-kwds supplied-kwd-args) (let-values ([(supplied-kwds supplied-kwd-args)
(let loop ([kwds kwds] (let loop ([kwds kwds]
[kwd-args kwd-args]) [kwd-args kwd-args])
@ -304,10 +315,18 @@
[else [else
(values (cons (car kwds) kwds-rec) (values (cons (car kwds) kwds-rec)
(cons (car kwd-args) args-rec))]))]))]) (cons (car kwd-args) args-rec))]))]))])
(keyword-apply fn (cond
supplied-kwds supplied-kwd-args [(and res-checker (null? supplied-kwd-args))
(append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) (apply values res-checker
rest-args)))) (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))]
[(null? supplied-kwd-args)
(apply values (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))]
[res-checker
(apply values res-checker supplied-kwd-args
(append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))]
[else
(apply values supplied-kwd-args
(append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))])))
(define-for-syntax (maybe-generate-temporary x) (define-for-syntax (maybe-generate-temporary x)
(and x (car (generate-temporaries (list x))))) (and x (car (generate-temporaries (list x)))))
@ -414,26 +433,27 @@
#`(#,arg-proj-var #,wrapper-arg)]))]) #`(#,arg-proj-var #,wrapper-arg)]))])
#,body))))) #,body)))))
(define-for-syntax (add-result-checks an-istx ;; Returns an empty list if no result contracts and a list of a single syntax value
ordered-ress res-indicies ;; which should be a function from results to projection-applied versions of the same
res-proj-vars indy-res-proj-vars ;; if there are result contracts.
wrapper-ress indy-res-vars (define-for-syntax (result-checkers an-istx
arg/res-to-indy-var ordered-ress res-indicies
arg-call-stx) res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars
arg/res-to-indy-var)
(cond (cond
[(istx-ress an-istx) [(istx-ress an-istx)
;; WRONG! needs to preserve tail recursion? .... well ->d does anyways. (list
#`(let-values ([#,(vector->list wrapper-ress) #,arg-call-stx]) #`(λ #,(vector->list wrapper-ress)
#,(add-wrapper-let
#,(add-wrapper-let (add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress)))
(add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress))) #f
#f ordered-ress res-indicies
ordered-ress res-indicies res-proj-vars indy-res-proj-vars
res-proj-vars indy-res-proj-vars wrapper-ress indy-res-vars
wrapper-ress indy-res-vars arg/res-to-indy-var)))]
arg/res-to-indy-var))]
[else [else
arg-call-stx])) null]))
(define-for-syntax (add-eres-lets an-istx res-proj-vars arg/res-to-indy-var stx) (define-for-syntax (add-eres-lets an-istx res-proj-vars arg/res-to-indy-var stx)
(cond (cond
@ -448,16 +468,6 @@
body))] body))]
[else stx])) [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) (define-for-syntax (mk-wrapper-func an-istx used-indy-vars)
(let ([args+rst (append (istx-args an-istx) (let ([args+rst (append (istx-args an-istx)
(if (istx-rst an-istx) (if (istx-rst an-istx)
@ -552,33 +562,39 @@
(λ (val) (λ (val)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
#,(maybe-make-contracted-function (let ([arg-checker
(maybe-a-method/name (λ #,(args/vars->arglist an-istx wrapper-args this-param)
(syntax-property #,(add-wrapper-let
#`(λ #,(args/vars->arglist an-istx wrapper-args this-param) (add-pre-cond
#,(add-wrapper-let an-istx
(add-pre-cond arg/res-to-indy-var
an-istx (add-eres-lets
arg/res-to-indy-var an-istx
(add-eres-lets res-proj-vars
an-istx arg/res-to-indy-var
res-proj-vars (args/vars->arg-checker
arg/res-to-indy-var (result-checkers
(add-result-checks
an-istx an-istx
ordered-ress res-indicies ordered-ress res-indicies
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
arg/res-to-indy-var arg/res-to-indy-var)
(args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args this-param)))) (istx-args an-istx)
#t (istx-rst an-istx)
ordered-args arg-indicies wrapper-args
arg-proj-vars indy-arg-proj-vars this-param)))
wrapper-args indy-arg-vars #t
arg/res-to-indy-var)) ordered-args arg-indicies
'inferred-name arg-proj-vars indy-arg-proj-vars
(syntax-local-name))) wrapper-args indy-arg-vars
#'ctc))))))) arg/res-to-indy-var))])
(impersonate-procedure
val
(make-keyword-procedure
(λ (kwds kwd-args . args)
(keyword-apply arg-checker kwds kwd-args args))
(λ args (apply arg-checker args)))
impersonator-prop:contracted ctc))))))))
(define (un-dep ctc obj blame) (define (un-dep ctc obj blame)
(let ([ctc (coerce-contract '->i ctc)]) (let ([ctc (coerce-contract '->i ctc)])