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

cleaned up the generated code for -> and friends

Browse Source
This commit is contained in:
Robby Findler 2011-07-14 22:57:11 -06:00
parent 62acb298bd
commit 00bb92816c
2 changed files with 329 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

513
collects/racket/contract/private/arrow.rkt
View File

@ -43,7 +43,8 @@ v4 todo:
contracted-function? contracted-function?
contracted-function-proc contracted-function-proc
contracted-function-ctc contracted-function-ctc
make-contracted-function) make-contracted-function
matches-arity-exactly?)
(define-syntax-parameter making-a-method #f) (define-syntax-parameter making-a-method #f)
(define-for-syntax (make-this-parameters id) (define-for-syntax (make-this-parameters id)
@ -57,17 +58,32 @@ v4 todo:
(define contract-key (gensym 'contract-key)) (define contract-key (gensym 'contract-key))
(define-for-syntax (check-tail-contract num-rng-ctcs rng-ctcs rng-checkers call-gen) (define-for-syntax (check-tail-contract rng-ctcs rng-checkers call-gen)
#`(call-with-immediate-continuation-mark #`(call-with-immediate-continuation-mark
contract-key contract-key
(λ (m) (λ (m)
(cond (cond
[(and m [(tail-marks-match? m . #,rng-ctcs)
(= (length m) #,num-rng-ctcs)
(andmap procedure-closure-contents-eq? m (list . #,rng-ctcs)))
#,(call-gen #'())] #,(call-gen #'())]
[else #,(call-gen rng-checkers)])))) [else #,(call-gen rng-checkers)]))))
(define tail-marks-match?
(case-lambda
[(m) (and m (null? m))]
[(m rng-ctc) (and m
(not (null? m))
(null? (cdr m))
(procedure-closure-contents-eq? (car m) rng-ctc))]
[(m rng-ctc1 rng-ctc2)
(and m
(= (length m) 2)
(procedure-closure-contents-eq? (car m) rng-ctc1)
(procedure-closure-contents-eq? (cadr m) rng-ctc1))]
[(m . rng-ctcs)
(and m
(= (length m) (length rng-ctcs))
(andmap procedure-closure-contents-eq? m rng-ctcs))]))
(define-syntax (unconstrained-domain-> stx) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
@ -90,14 +106,12 @@ v4 todo:
val val
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-vals . args) (λ (kwds kwd-vals . args)
#,(check-tail-contract #,(check-tail-contract
(length (syntax->list #'(rngs ...)))
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args)))) (λ (s) #`(apply values #,@s kwd-vals args))))
(λ args (λ args
#,(check-tail-contract #,(check-tail-contract
(length (syntax->list #'(rngs ...)))
#'(p-app-x ...) #'(p-app-x ...)
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s args))))) (λ (s) #`(apply values #,@s args)))))
@ -131,10 +145,33 @@ v4 todo:
; ;
; ;
(define (matches-arity-exactly? val contract-arity contract-req-kwds contract-opt-kwds) ;; matches-arity-exactly? : procedure number (or/c number #f) (listof keyword?) (listof keyword?) -> boolean
(and (equal? (procedure-arity val) contract-arity) (define (matches-arity-exactly? val min-arity max-arity contract-req-kwds contract-opt-kwds)
(let-values ([(vr va) (procedure-keywords val)]) (define proc-arity (procedure-arity val))
(and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds))))) (and (let-values ([(vr va) (procedure-keywords val)])
(and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds)))
(cond
[(number? proc-arity) (and (number? max-arity)
(= min-arity max-arity)
(= proc-arity min-arity))]
[(arity-at-least? proc-arity) (and (not max-arity)
(= (arity-at-least-value proc-arity)
min-arity))]
[else
(let loop ([arity proc-arity]
[i min-arity])
(cond
[(null? arity)
(= i (+ max-arity 1))]
[else
(let ([fst (car arity)])
(if (arity-at-least? fst)
(and (number? max-arity)
(= (arity-at-least-value fst)
max-arity))
(and (= i fst)
(loop (cdr arity)
(+ i 1)))))]))])))
(define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs) (define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs)
(with-syntax ([blame blame] (with-syntax ([blame blame]
@ -150,52 +187,39 @@ v4 todo:
(raise-blame-error blame val "#:post condition"))) (raise-blame-error blame val "#:post condition")))
null)]) null)])
(with-syntax ([(this-param ...) this-args] (with-syntax ([(this-param ...) this-args]
[([dom-ctc dom-x] ...) [(dom-ctc ...) doms]
(for/list ([d (in-list doms)]) [(dom-x ...) (generate-temporaries doms)]
(list d (gensym 'dom)))] [(opt-dom-ctc ...) opt-doms]
[([opt-dom-ctc opt-dom-x] ...) [(opt-dom-x ...) (generate-temporaries opt-doms)]
(for/list ([d (in-list opt-doms)]) [(rest-ctc (rest-x)) (list dom-rest (generate-temporaries '(rest)))]
(list d (gensym 'opt-dom)))] [(req-kwd ...) (map car req-kwds)]
[(rest-ctc rest-x) (list dom-rest (gensym 'rest))] [(req-kwd-ctc ...) (map cadr req-kwds)]
[([req-kwd req-kwd-ctc req-kwd-x] ...) [(req-kwd-x ...) (generate-temporaries (map car req-kwds))]
(for/list ([d (in-list req-kwds)]) [(opt-kwd ...) (map car opt-kwds)]
(list (car d) (cadr d) (gensym 'req-kwd)))] [(opt-kwd-ctc ...) (map cadr opt-kwds)]
[([opt-kwd opt-kwd-ctc opt-kwd-x] ...) [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
(for/list ([d (in-list opt-kwds)]) [(rng-ctc ...) (if rngs rngs '())]
(list (car d) (cadr d) (gensym 'opt-kwds)))] [(rng-x ...) (if rngs (generate-temporaries rngs) '())])
[([rng-ctc rng-x] ...)
(if rngs
(for/list ([r (in-list rngs)])
(list r (gensym 'rng)))
null)])
(with-syntax ([(rng-checker-name ...) (with-syntax ([(rng-checker-name ...)
(if rngs (if rngs
(list (gensym 'rng-checker)) (list (gensym 'rng-checker))
null)] null)]
[(rng-checker ...) [(rng-checker ...)
(if rngs (if rngs
(with-syntax ([rng-len (length rngs)] (list
[rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")]) (with-syntax ([rng-len (length rngs)])
(with-syntax ([rng-params (with-syntax ([rng-results
(if (null? rngs) (if (and (pair? rngs) (null? (cdr rngs)))
#'rest-x (with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))]
#'([rng-x unspecified-dom] ... . rest-x))] [name (car (syntax->list #'(rng-x ...)))])
[rng-results #'(proj name))
(if (and (pair? rngs) (null? (cdr rngs))) #'(values (rng-ctc rng-x) ...))])
(with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))] #'(case-lambda
[name (car (syntax->list #'(rng-x ...)))]) [(rng-x ...)
#'(proj name)) post ...
#'(values (rng-ctc rng-x) ...))]) rng-results]
(list #'(λ rng-params [args
(when (or (pair? rest-x) (bad-number-of-results blame val rng-len args)]))))
(eq? unspecified-dom rng-x) ...)
(let ([num-values (+ (length rest-x) (if (eq? unspecified-dom rng-x) 0 1) ...)])
(raise-blame-error blame val
"expected ~a value~a, returned ~a value~a"
rng-len rng-pluralize
num-values (if (= num-values 1) "" "s"))))
post ...
rng-results))))
null)]) null)])
(let* ([min-method-arity (length doms)] (let* ([min-method-arity (length doms)]
[max-method-arity (+ min-method-arity (length opt-doms))] [max-method-arity (+ min-method-arity (length opt-doms))]
@ -205,23 +229,7 @@ v4 todo:
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)] [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
[need-apply-values? (or dom-rest (not (null? opt-doms)))] [need-apply-values? (or dom-rest (not (null? opt-doms)))]
[no-rng-checking? (not rngs)]) [no-rng-checking? (not rngs)])
(with-syntax ([args-len (with-syntax ([basic-params
(if (= min-method-arity min-arity)
#'(length args)
#'(sub1 (length args)))]
[arity-string
(if dom-rest
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))
(if (= min-method-arity max-method-arity)
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)))]
[arity-checker
(if dom-rest
#`(>= (length args) #,min-arity)
(if (= min-arity max-arity)
#`(= (length args) #,min-arity)
#`(and (>= (length args) #,min-arity) (<= (length args) #,max-arity))))]
[basic-params
(cond (cond
[dom-rest [dom-rest
#'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... . rest-x)] #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... . rest-x)]
@ -266,7 +274,7 @@ v4 todo:
(λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))]) (λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))])
(if no-rng-checking? (if no-rng-checking?
(inner-stx-gen #'()) (inner-stx-gen #'())
(check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))] (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply-values?
@ -275,83 +283,121 @@ v4 todo:
[outer-stx-gen [outer-stx-gen
(if (null? req-keywords) (if (null? req-keywords)
(λ (s) (λ (s)
#`(let ([kwd-results kwd-stx]) #`(if (null? kwd-results)
(if (null? kwd-results) #,(inner-stx-gen s #'())
#,(inner-stx-gen s #'()) #,(inner-stx-gen s #'(kwd-results))))
#,(inner-stx-gen s #'(kwd-results)))))
(λ (s) (λ (s)
#`(let ([kwd-results kwd-stx]) (inner-stx-gen s #'(kwd-results))))])
#,(inner-stx-gen s #'(kwd-results)))))]) #`(let ([kwd-results kwd-stx])
(if no-rng-checking? #,(if no-rng-checking?
(outer-stx-gen #'()) (outer-stx-gen #'())
(check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen)))]) (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))])
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)] (with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
[basic-lambda #'(λ basic-params pre ... basic-return)] [basic-lambda #'(λ basic-params pre ... basic-return)]
[kwd-lambda-name (gensym 'kwd-lambda)] [kwd-lambda-name (gensym 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params pre ... kwd-return)]) [kwd-lambda #`(λ kwd-lam-params pre ... kwd-return)])
(with-syntax ([basic-checker-name (gensym 'basic-checker)] (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
[basic-checker
(if (null? req-keywords)
#'(λ args
(unless arity-checker
(raise-blame-error blame val
"received ~a argument~a, expected ~a"
args-len (if (= args-len 1) "" "s") arity-string))
(apply basic-lambda-name args))
#`(λ args
(raise-blame-error (blame-swap blame) val
"expected required keyword ~a"
(quote #,(car req-keywords)))))]
[kwd-checker
(if (and (null? req-keywords) (null? opt-keywords))
#'(λ (kwds kwd-args . args)
(raise-blame-error (blame-swap blame) val
"expected no keywords"))
#'(λ (kwds kwd-args . args)
(unless arity-checker
(raise-blame-error blame val
"received ~a argument~a, expected ~a"
args-len (if (= args-len 1) "" "s") arity-string))
(unless (memq (quote req-kwd) kwds)
(raise-blame-error blame val
"expected keyword argument ~a"
(quote req-kwd))) ...
(let ([all-kwds (list (quote req-kwd) ... (quote opt-kwd) ...)])
(for/list ([k (in-list kwds)])
(unless (memq k all-kwds)
(raise-blame-error blame val
"received unexpected keyword argument ~a"
k))))
(keyword-apply kwd-lambda-name kwds kwd-args args)))]
[contract-arity
(cond
[dom-rest #`(make-arity-at-least #,min-arity)]
[(= min-arity max-arity) min-arity]
[else (cons #'list (build-list (add1 (- max-arity min-arity)) (λ (n) (+ min-arity n))))])])
(cond (cond
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(if (matches-arity-exactly? val contract-arity null null) (arity-checking-wrapper val blame
basic-lambda-name basic-lambda-name
(let-values ([(vr va) (procedure-keywords val)] void
[(basic-checker-name) basic-checker]) #,min-method-arity
(if (or (not va) (pair? vr) (pair? va)) #,max-method-arity
(make-keyword-procedure kwd-checker basic-checker-name) #,min-arity
basic-checker-name)))))] #,(if dom-rest #f max-arity)
'(req-kwd ...)
'(opt-kwd ...))))]
[(pair? req-keywords) [(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...)) (arity-checking-wrapper val blame
kwd-lambda-name void
(make-keyword-procedure kwd-checker basic-checker))))] kwd-lambda-name
#,min-method-arity
#,max-method-arity
#,min-arity
#,(if dom-rest #f max-arity)
'(req-kwd ...)
'(opt-kwd ...))))]
[else [else
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([basic-lambda-name basic-lambda] (let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...)) (arity-checking-wrapper val blame
kwd-lambda-name basic-lambda-name
(make-keyword-procedure kwd-checker basic-checker))))]))))))))))) kwd-lambda-name
#,min-method-arity
#,max-method-arity
#,min-arity
#,(if dom-rest #f max-arity)
'(req-kwd ...)
'(opt-kwd ...))))])))))))))))
;; should we pass both the basic-lambda and the kwd-lambda?
(define (arity-checking-wrapper val blame basic-lambda kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all
(cond
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd))
basic-lambda
kwd-lambda)]
[else
(define arity-string
(if max-arity
(if (= min-method-arity max-method-arity)
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity))
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
(define-values (vr va) (procedure-keywords val))
(define all-kwds (append req-kwd opt-kwd))
(define (valid-number-of-args? args)
(if max-arity
(<= min-arity (length args) max-arity)
(<= min-arity (length args))))
(define kwd-checker
(if (and (null? req-kwd) (null? opt-kwd))
(λ (kwds kwd-args . args)
(raise-blame-error (blame-swap blame) val
"expected no keywords"))
(λ (kwds kwd-args . args)
(define args-len (length args))
(unless (valid-number-of-args? args)
(raise-blame-error blame val
"received ~a argument~a, expected ~a"
args-len (if (= args-len 1) "" "s") arity-string))
;; these two for loops are doing O(n^2) work that could be linear
;; (since the keyword lists are sorted)
(for ([req-kwd (in-list req-kwd)])
(unless (memq req-kwd kwds)
(raise-blame-error blame val
"expected keyword argument ~a"
(quote req-kwd))))
(for ([k (in-list kwds)])
(unless (memq k all-kwds)
(raise-blame-error blame val
"received unexpected keyword argument ~a"
k)))
(keyword-apply kwd-lambda kwds kwd-args args))))
(define basic-checker-name
(if (null? req-kwd)
(λ args
(unless (<= min-arity (length args) max-arity)
(define args-len (length args))
(raise-blame-error blame val
"received ~a argument~a, expected ~a"
args-len (if (= args-len 1) "" "s") arity-string))
(apply basic-lambda args))
(λ args
(raise-blame-error (blame-swap blame) val
"expected required keyword ~a"
(car req-kwd)))))
(if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name)]))
;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one. ;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one.
;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one. ;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one.
@ -367,7 +413,7 @@ v4 todo:
;; func : the wrapper function maker. It accepts a procedure for ;; func : the wrapper function maker. It accepts a procedure for
;; checking the first-order properties and the contracts ;; checking the first-order properties and the contracts
;; and it produces a wrapper-making function. ;; and it produces a wrapper-making function.
(define-struct base-> (pre post doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)) (define-struct base-> (pre post doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? mtd? func))
(define ((->-proj wrapper) ctc) (define ((->-proj wrapper) ctc)
(let* ([doms-proj (map contract-projection (let* ([doms-proj (map contract-projection
@ -385,7 +431,8 @@ v4 todo:
[optionals-length (length (base->-optional-doms/c ctc))] [optionals-length (length (base->-optional-doms/c ctc))]
[has-rest? (and (base->-dom-rest/c ctc) #t)] [has-rest? (and (base->-dom-rest/c ctc) #t)]
[pre (base->-pre ctc)] [pre (base->-pre ctc)]
[post (base->-post ctc)]) [post (base->-post ctc)]
[mtd? (base->-mtd? ctc)])
(λ (blame) (λ (blame)
(let ([swapped (blame-swap blame)]) (let ([swapped (blame-swap blame)])
(let ([partial-doms (map (λ (dom) (dom swapped)) doms-proj)] (let ([partial-doms (map (λ (dom) (dom swapped)) doms-proj)]
@ -393,17 +440,29 @@ v4 todo:
[partial-ranges (map (λ (rng) (rng blame)) rngs-proj)] [partial-ranges (map (λ (rng) (rng blame)) rngs-proj)]
[partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)] [partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)]
[partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)]) [partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)])
(apply func (λ (val)
wrapper (if has-rest?
blame (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame)
(λ (val mtd?) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame))
(if has-rest? (define chap/imp-func
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame) (apply func
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame))) blame
ctc val
(append partial-doms partial-optional-doms (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds partial-mandatory-kwds partial-optional-kwds
partial-ranges))))))) partial-ranges)))
(if post
(wrapper
val
chap/imp-func
impersonator-prop:contracted ctc)
(wrapper
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:application-mark (cons contract-key
;; is this right?
partial-ranges)))))))))
(define (->-name ctc) (define (->-name ctc)
(single-arrow-name-maker (single-arrow-name-maker
@ -464,7 +523,7 @@ v4 todo:
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
rngs/c-or-p rngs/c-or-p
rng-any? func) rng-any? mtd? func)
(let ([cc (λ (c-or-p) (coerce-contract name c-or-p))]) (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
(let ([doms/c (map cc doms/c-or-p)] (let ([doms/c (map cc doms/c-or-p)]
[opt-doms/c (map cc optional-doms/c-or-p)] [opt-doms/c (map cc optional-doms/c-or-p)]
@ -480,10 +539,10 @@ v4 todo:
(or rng-any? (andmap chaperone-contract? rngs/c))) (or rng-any? (andmap chaperone-contract? rngs/c)))
(make-chaperone-> pre post doms/c opt-doms/c rest/c (make-chaperone-> pre post doms/c opt-doms/c rest/c
kwds/c mandatory-kwds opt-kwds/c optional-kwds kwds/c mandatory-kwds opt-kwds/c optional-kwds
rngs/c rng-any? func) rngs/c rng-any? mtd? func)
(make-impersonator-> pre post doms/c opt-doms/c rest/c (make-impersonator-> pre post doms/c opt-doms/c rest/c
kwds/c mandatory-kwds opt-kwds/c optional-kwds kwds/c mandatory-kwds opt-kwds/c optional-kwds
rngs/c rng-any? func))))) rngs/c rng-any? mtd? func)))))
(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post) (define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post)
(cond (cond
@ -602,22 +661,17 @@ v4 todo:
(syntax->list kwd-ctcs))] (syntax->list kwd-ctcs))]
[(kwds ...) kwds] [(kwds ...) kwds]
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([outer-lambda (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
#`(lambda (wrapper blame chk ctc dom-names ... kwd-names ... rng-names ...) [outer-lambda
(lambda (val) #`(lambda (blame val dom-names ... kwd-names ... rng-names ...)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) #,(create-chaperone
(wrapper #'blame #'val #f #f
val (syntax->list #'(this-params ...))
#,(create-chaperone (syntax->list #'(dom-names ...)) null #f
#'blame #'val #f #f (map list (syntax->list #'(kwds ...))
(syntax->list #'(this-params ...)) (syntax->list #'(kwd-names ...)))
(syntax->list #'(dom-names ...)) null #f null
(map list (syntax->list #'(kwds ...)) (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))))])
(syntax->list #'(kwd-names ...)))
null
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))))
impersonator-prop:contracted ctc
impersonator-prop:application-mark (cons contract-key (list rng-names ...)))))])
(syntax-property (syntax-property
(syntax (syntax
(build--> '-> (build--> '->
@ -625,6 +679,7 @@ v4 todo:
(list dom-ctcs ...) '() #f (list dom-ctcs ...) '() #f
(list kwd-ctcs ...) '(kwds ...) '() '() (list kwd-ctcs ...) '(kwds ...) '() '()
(list rng-ctcs ...) use-any? (list rng-ctcs ...) use-any?
mtd?
outer-lambda)) outer-lambda))
'racket/contract:contract 'racket/contract:contract
(vector this-> (vector this->
@ -753,7 +808,8 @@ v4 todo:
[(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))]) [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
(with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))] (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
[(rng ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))]
[(this-parameter ...) [(this-parameter ...)
(make-this-parameters (car (generate-temporaries '(this))))]) (make-this-parameters (car (generate-temporaries '(this))))])
@ -773,10 +829,8 @@ v4 todo:
#'(list rng-ctc ...)) #'(list rng-ctc ...))
#''()) #''())
#,(if rng-ctc #f #t) #,(if rng-ctc #f #t)
(λ (wrapper mtd?
blame (λ (blame f
chk
ctc
mandatory-dom-proj ... mandatory-dom-proj ...
#,@(if rest-ctc #,@(if rest-ctc
#'(rest-proj) #'(rest-proj)
@ -785,23 +839,17 @@ v4 todo:
mandatory-dom-kwd-proj ... mandatory-dom-kwd-proj ...
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
(λ (f) #,(create-chaperone
(chk f #,(and (syntax-parameter-value #'making-a-method) #t)) #'blame #'f pre post
(wrapper (syntax->list #'(this-parameter ...))
f (syntax->list #'(mandatory-dom-proj ...))
#,(create-chaperone (syntax->list #'(optional-dom-proj ...))
#'blame #'f pre post (if rest-ctc #'rest-proj #f)
(syntax->list #'(this-parameter ...)) (map list (syntax->list #'(mandatory-dom-kwd ...))
(syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(mandatory-dom-kwd-proj ...)))
(syntax->list #'(optional-dom-proj ...)) (map list (syntax->list #'(optional-dom-kwd ...))
(if rest-ctc #'rest-proj #f) (syntax->list #'(optional-dom-kwd-proj ...)))
(map list (syntax->list #'(mandatory-dom-kwd ...)) (if rng-ctc (syntax->list #'(rng-proj ...)) #f))))))))))]))
(syntax->list #'(mandatory-dom-kwd-proj ...)))
(map list (syntax->list #'(optional-dom-kwd ...))
(syntax->list #'(optional-dom-kwd-proj ...)))
(if rng-ctc (syntax->list #'(rng-proj ...)) #f))
impersonator-prop:contracted ctc
impersonator-prop:application-mark (cons contract-key (list rng-proj ...))))))))))))]))
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx))) (define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
@ -1404,12 +1452,12 @@ v4 todo:
(let ([rng-checkers (list #'(λ (rng-id ...) (values (rng-proj-x rng-id) ...)))] (let ([rng-checkers (list #'(λ (rng-id ...) (values (rng-proj-x rng-id) ...)))]
[rng-length (length (syntax->list rng))]) [rng-length (length (syntax->list rng))])
(if rst (if rst
(check-tail-contract rng-length #'(rng-proj-x ...) rng-checkers (check-tail-contract #'(rng-proj-x ...) rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(apply values #,@rng-checks this-parameter ... #`(apply values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals) ... (dom-proj-x dom-formals) ...
(rst-proj-x rst-formal)))) (rst-proj-x rst-formal))))
(check-tail-contract rng-length #'(rng-proj-x ...) rng-checkers (check-tail-contract #'(rng-proj-x ...) rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(values #,@rng-checks this-parameter ... #`(values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals) ...)))))] (dom-proj-x dom-formals) ...)))))]
@ -1699,24 +1747,32 @@ v4 todo:
(let-values ([(mandatory optional) (procedure-keywords f)]) (let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory))) (null? mandatory)))
;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched
;; (for use in arity checking)
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) (define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
(or (and (procedure? val) (define passes?
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) (and (procedure? val)
(keywords-match mandatory-kwds optional-keywords val)) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(and blame (keywords-match mandatory-kwds optional-keywords val)))
(raise-blame-error (cond
blame [blame
val (unless passes?
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" (raise-blame-error
(if mtd? "method" "procedure") blame
(if (zero? dom-length) "no" dom-length) val
(if (null? optionals) "" " mandatory") "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if (null? mandatory-kwds) "" " ordinary") (if mtd? "method" "procedure")
(if (= 1 dom-length) "" "s") (if (zero? dom-length) "no" dom-length)
(if (zero? optionals) "" (if (null? optionals) "" " mandatory")
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s"))) (if (null? mandatory-kwds) "" " ordinary")
(keyword-error-text mandatory-kwds optional-keywords) (if (= 1 dom-length) "" "s")
val)))) (if (zero? optionals) ""
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
(keyword-error-text mandatory-kwds optional-keywords)
val))]
[else
passes?]))
(define (procedure-arity-includes?/optionals f base optionals) (define (procedure-arity-includes?/optionals f base optionals)
(cond (cond
@ -1765,23 +1821,38 @@ v4 todo:
(format-keywords-error 'mandatory mandatory-keywords) (format-keywords-error 'mandatory mandatory-keywords)
", and " ", and "
(format-keywords-error 'optional optional-keywords))])) (format-keywords-error 'optional optional-keywords))]))
;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched
;; (for use in arity checking)
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame) (define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
(or (and (procedure? val) (define passes?
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) (and (procedure? val)
(keywords-match mandatory-kwds optional-kwds val)) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(and blame (keywords-match mandatory-kwds optional-kwds val)))
(raise-blame-error (cond
blame [blame
val (unless passes?
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e" (raise-blame-error
(if mtd? "method" "procedure") blame
(cond val
[(zero? dom-length) "no"] "expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
[else dom-length]) (if mtd? "method" "procedure")
(if (= 1 dom-length) "" "s") (cond
(keyword-error-text mandatory-kwds optional-kwds) [(zero? dom-length) "no"]
val)))) [else dom-length])
(if (= 1 dom-length) "" "s")
(keyword-error-text mandatory-kwds optional-kwds)
val))]
[else
passes?]))
(define (bad-number-of-results blame val rng-len)
(let ([num-values (length rng-len)])
(raise-blame-error blame val
"expected ~a value~a, returned ~a value~a"
rng-len (if (= rng-len 1) "" "s")
num-values (if (= num-values 1) "" "s"))))
;; timing & size tests ;; timing & size tests

37
collects/tests/racket/contract-helpers.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket
(require rackunit
racket/contract/private/arrow)
(check-equal? (matches-arity-exactly? (λ () 1) 0 0 '() '()) #t)
(check-equal? (matches-arity-exactly? (λ () 1) 1 1 '() '()) #f)
(check-equal? (matches-arity-exactly? (λ () 1) 0 1 '() '()) #f)
(check-equal? (matches-arity-exactly? (λ () 1) 0 #f '() '()) #f)
(check-equal? (matches-arity-exactly? (λ (x y) x) 2 2 '() '()) #t)
(check-equal? (matches-arity-exactly? (λ (x y) x) 1 1 '() '()) #f)
(check-equal? (matches-arity-exactly? (λ (x y) x) 2 3 '() '()) #f)
(check-equal? (matches-arity-exactly? (λ (x y) x) 3 #f '() '()) #f)
(check-equal? (matches-arity-exactly? (case-lambda
[() 1]
[(x) 2])
0 1 '() '()) #t)
(check-equal? (matches-arity-exactly? (case-lambda
[() 1]
[(x) 2])
0 2 '() '()) #f)
(check-equal? (matches-arity-exactly? (case-lambda
[() 1]
[(x y) 2])
0 2 '() '()) #f)
(check-equal? (matches-arity-exactly? (case-lambda
[() 1]
[(x y) 2])
0 1 '() '()) #f)
(check-equal? (matches-arity-exactly? (case-lambda
[() 1]
[(x y) 2])
0 #f '() '()) #f)
(check-equal? (matches-arity-exactly? (lambda (x . y) x)
1 #f '() '()) #t)
(check-equal? (matches-arity-exactly? (lambda (x . y) x)
0 #f '() '()) #f)