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

adjust the plus-one arity functions to exploit procedure-return-arity

Browse Source
This commit is contained in:
Robby Findler 2016-01-23 21:30:44 -06:00
parent 9e69f341b3
commit b0d9653cbe
2 changed files with 108 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -539,6 +539,8 @@
arrow-higher-order:lnp)] arrow-higher-order:lnp)]
[else [else
(define (arrow-higher-order:vfp val) (define (arrow-higher-order:vfp val)
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))
(wrapped-extra-arg-arrow (wrapped-extra-arg-arrow
(cond (cond
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos) [(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
@ -547,14 +549,18 @@
[else [else
(λ (neg-party) (λ (neg-party)
(successfully-got-the-right-kind-of-function val neg-party))]) (successfully-got-the-right-kind-of-function val neg-party))])
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))) (if (equal? (procedure-result-arity val) expected-number-of-results)
proc-with-no-result-checking
normal-proc)))
(if okay-to-do-only-arity-check? (if okay-to-do-only-arity-check?
(λ (val) (λ (val)
(cond (cond
[(procedure-arity-exactly/no-kwds val min-arity) [(procedure-arity-exactly/no-kwds val min-arity)
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))
(wrapped-extra-arg-arrow (wrapped-extra-arg-arrow
(λ (neg-party) val) (λ (neg-party) val)
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))] normal-proc)]
[else (arrow-higher-order:vfp val)])) [else (arrow-higher-order:vfp val)]))
arrow-higher-order:vfp)]))) arrow-higher-order:vfp)])))

68
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -238,7 +238,7 @@
(list #`(check-post-cond #,post blame neg-party f)) (list #`(check-post-cond #,post blame neg-party f))
(list))] (list))]
[(restb) (generate-temporaries '(rest-args))]) [(restb) (generate-temporaries '(rest-args))])
(define body-proc (define (make-body-proc range-checking?)
(cond (cond
[(or (and (null? optional-args) [(or (and (null? optional-args)
(null? optional-kwds)) (null? optional-kwds))
@ -286,7 +286,11 @@
#`[#,the-args #`[#,the-args
(let ([blame+neg-party (cons blame neg-party)]) (let ([blame+neg-party (cons blame neg-party)])
pre-check ... pre-check ...
(define-values (failed res-x ...) #,@
(cond
[range-checking?
(list
#`(define-values (failed res-x ...)
(call-with-values (call-with-values
(λ () (let-values (#,let-values-clause) (λ () (let-values (#,let-values-clause)
#,full-call)) #,full-call))
@ -296,7 +300,7 @@
[args [args
(values args #,@(map (λ (x) #'#f) (values args #,@(map (λ (x) #'#f)
(syntax->list #'(res-x ...))))]))) (syntax->list #'(res-x ...))))])))
(with-contract-continuation-mark #`(with-contract-continuation-mark
blame+neg-party blame+neg-party
(cond (cond
[failed [failed
@ -311,6 +315,18 @@
(values (values
(rb res-x neg-party) (rb res-x neg-party)
...)])))] ...)])))]
[else
(list
#`(define-values (res-x ...)
(let-values (#,let-values-clause)
#,full-call))
#`(with-contract-continuation-mark
blame+neg-party
(begin
post-check ...
(values
(rb res-x neg-party)
...))))]))]
#`[#,the-args #`[#,the-args
pre-check ... pre-check ...
(let ([blame+neg-party (cons blame neg-party)]) (let ([blame+neg-party (cons blame neg-party)])
@ -339,9 +355,24 @@
#,(if rest #'restb #'#f) #,(if rest #'restb #'#f)
#,(if post post #'#f) #,(if post post #'#f)
#,(if rngs #'(list rb ...) #'#f))])) #,(if rngs #'(list rb ...) #'#f))]))
(define body-proc (make-body-proc #t))
(define body-proc/no-range-checking (make-body-proc #f))
(define number-of-rngs (and rngs (with-syntax ([rngs rngs]) (length (syntax->list #'rngs)))))
#`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '())) #`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '()))
(values
(procedure-specialize (procedure-specialize
#,body-proc)))))) #,body-proc)
#,(if rngs
#`(procedure-specialize
#,body-proc/no-range-checking)
#'shouldnt-be-called)
'#,(if rngs number-of-rngs 'there-is-no-range-contract)))))))
(define (shouldnt-be-called . args)
(error 'arrow-val-first.rkt
(string-append
"this function should not ever be called because"
" procedure-result-arity shouldn't return 'there-is-no-range-contract")))
(define (make-checking-proc f blame pre (define (make-checking-proc f blame pre
original-mandatory-kwds kbs original-mandatory-kwds kbs
@ -906,9 +937,11 @@
[else (cons (car _args) (loop (- n 1) (cdr _args)))])))) [else (cons (car _args) (loop (- n 1) (cdr _args)))]))))
(define (plus-one-arity-function blame f . args) (define (plus-one-arity-function blame f . args)
(define f
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . regular-args) (λ (kwds kwd-args . regular-args)
(error 'plus-one-arity-function "not implemented for dynamic->*")))) (error 'plus-one-arity-function "not implemented for dynamic->*"))))
(values f f 'not-a-number-so-it-doesnt-match-any-result-from-procedure-result-arity))
(define min-arity (length mandatory-domain-contracts)) (define min-arity (length mandatory-domain-contracts))
(define optionals (length optional-domain-contracts)) (define optionals (length optional-domain-contracts))
@ -1268,6 +1301,7 @@
(list (coerce-contract 'whatever void?)) (list (coerce-contract 'whatever void?))
#f #f
(λ (blame f _ignored-rng-ctcs _ignored-rng-proj) (λ (blame f _ignored-rng-ctcs _ignored-rng-proj)
(values
(λ (neg-party) (λ (neg-party)
(call-with-values (call-with-values
(λ () (f)) (λ () (f))
@ -1279,28 +1313,42 @@
'(expected: "void?" given: "~e") '(expected: "void?" given: "~e")
rng))] rng))]
[args [args
(wrong-number-of-results-blame blame neg-party f args 1)])))) (wrong-number-of-results-blame blame neg-party f args 1)])))
(λ (neg-party)
(let ([rng (f)])
(if (void? rng)
rng
(raise-blame-error blame #:missing-party neg-party rng
'(expected: "void?" given: "~e")
rng))))
1))
(get-chaperone-constructor)))) (get-chaperone-constructor))))
(define (mk-any/c->boolean-contract constructor) (define (mk-any/c->boolean-contract constructor)
(define (rng-checker f blame neg-party) (define (check-result blame neg-party rng)
(case-lambda
[(rng)
(if (boolean? rng) (if (boolean? rng)
rng rng
(raise-blame-error blame #:missing-party neg-party rng (raise-blame-error blame #:missing-party neg-party rng
'(expected: "boolean?" given: "~e") '(expected: "boolean?" given: "~e")
rng))] rng)))
(define (rng-checker f blame neg-party)
(case-lambda
[(rng)
(check-result blame neg-party rng)]
[args [args
(wrong-number-of-results-blame blame neg-party f args 1)])) (wrong-number-of-results-blame blame neg-party f args 1)]))
(constructor 1 (list any/c) '() #f #f (constructor 1 (list any/c) '() #f #f
(list (coerce-contract 'whatever boolean?)) (list (coerce-contract 'whatever boolean?))
#f #f
(λ (blame f _ignored-dom-contract _ignored-rng-contract) (λ (blame f _ignored-dom-contract _ignored-rng-contract)
(values
(λ (neg-party argument) (λ (neg-party argument)
(call-with-values (call-with-values
(λ () (f argument)) (λ () (f argument))
(rng-checker f blame neg-party)))) (rng-checker f blame neg-party)))
(λ (neg-party argument)
(check-result blame neg-party (f argument)))
1))
(λ (blame f neg-party (λ (blame f neg-party
_ignored-blame-party-info _ignored-blame-party-info
_ignored-rng-ctcs _ignored-rng-ctcs