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

152
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,31 +286,47 @@
#`[#,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 ...) #,@
(call-with-values (cond
(λ () (let-values (#,let-values-clause) [range-checking?
#,full-call)) (list
(case-lambda #`(define-values (failed res-x ...)
[(res-x ...) (call-with-values
(values #f res-x ...)] (λ () (let-values (#,let-values-clause)
[args #,full-call))
(values args #,@(map (λ (x) #'#f) (case-lambda
(syntax->list #'(res-x ...))))]))) [(res-x ...)
(with-contract-continuation-mark (values #f res-x ...)]
blame+neg-party [args
(cond (values args #,@(map (λ (x) #'#f)
[failed (syntax->list #'(res-x ...))))])))
(wrong-number-of-results-blame #`(with-contract-continuation-mark
blame neg-party f blame+neg-party
failed (cond
#,(length [failed
(syntax->list (wrong-number-of-results-blame
#'(res-x ...))))] blame neg-party f
[else failed
post-check ... #,(length
(values (syntax->list
(rb res-x neg-party) #'(res-x ...))))]
...)])))] [else
post-check ...
(values
(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) '()))
(procedure-specialize (values
#,body-proc)))))) (procedure-specialize
#,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)
(make-keyword-procedure (define f
(λ (kwds kwd-args . regular-args) (make-keyword-procedure
(error 'plus-one-arity-function "not implemented for dynamic->*")))) (λ (kwds kwd-args . regular-args)
(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,39 +1301,54 @@
(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)
(λ (neg-party) (values
(call-with-values (λ (neg-party)
(λ () (f)) (call-with-values
(case-lambda (λ () (f))
[(rng) (case-lambda
(if (void? rng) [(rng)
rng (if (void? rng)
(raise-blame-error blame #:missing-party neg-party rng rng
'(expected: "void?" given: "~e") (raise-blame-error blame #:missing-party neg-party rng
rng))] '(expected: "void?" given: "~e")
[args rng))]
(wrong-number-of-results-blame blame neg-party f args 1)])))) [args
(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 (check-result blame neg-party rng)
(if (boolean? rng)
rng
(raise-blame-error blame #:missing-party neg-party rng
'(expected: "boolean?" given: "~e")
rng)))
(define (rng-checker f blame neg-party) (define (rng-checker f blame neg-party)
(case-lambda (case-lambda
[(rng) [(rng)
(if (boolean? rng) (check-result blame neg-party rng)]
rng
(raise-blame-error blame #:missing-party neg-party rng
'(expected: "boolean?" given: "~e")
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)
(λ (neg-party argument) (values
(call-with-values (λ (neg-party argument)
(λ () (f argument)) (call-with-values
(rng-checker f blame neg-party)))) (λ () (f argument))
(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