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

PR 10219

Browse Source 
svn: r14654
This commit is contained in:
Robby Findler 2009-04-29 16:38:31 +00:00
parent 6c3b8a9f2e
commit de6c1a524d
1 changed files with 25 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/scheme/private/contract-arrow.ss
View File

@ -836,9 +836,22 @@ v4 todo:
(define ->d-tail-key (gensym '->d-tail-key))
(define (->d-proj ->d-stct)
(let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
(length (->d-optional-dom-ctcs ->d-stct))
(if (->d-mtd? ->d-stct) 1 0))])
(let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))]
[mandatory-count (length (->d-mandatory-dom-ctcs ->d-stct))]
[non-kwd-ctc-count (+ mandatory-count
opt-count
(if (->d-mtd? ->d-stct) 1 0))]
[arity
(cond
[(->d-rest-ctc ->d-stct)
(make-arity-at-least mandatory-count)]
[else
(let loop ([i 0])
(cond
[(= i opt-count)
(list (+ mandatory-count i))]
[else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (pos-blame neg-blame src-info orig-str)
(let ([this->d-id (gensym '->d-tail-key)])
(λ (val)
@ -967,10 +980,15 @@ v4 todo:
(loop (cdr results) (cdr result-contracts)))]))))))]
[else
(thunk)])))))])
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args
(apply kwd-proc '() '() args))))))))))
(procedure-reduce-keyword-arity
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args
(apply kwd-proc '() '() args))))
arity
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct))))))))
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str)