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

Fix tail call behavior for ->, ->* contracts.

Browse Source
This commit is contained in:
Stevie Strickland 2010-10-19 15:45:25 -07:00
parent 8835f2f470
commit 1a9dffe78d
1 changed files with 195 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -110,7 +110,19 @@ v4 todo:
(let-values ([(vr va) (procedure-keywords val)]) (let-values ([(vr va) (procedure-keywords val)])
(and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds))))) (and va (equal? vr contract-req-kwds) (equal? va contract-opt-kwds)))))
(define contract-key (gensym 'contract-key))
(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)
(define (check-tail-contract num-rng-ctcs rng-ctcs rng-checkers call-gen)
#`(call-with-immediate-continuation-mark
contract-key
(λ (m)
(cond
[(and m
(= (length m) #,num-rng-ctcs)
(andmap procedure-closure-contents-eq? m (list . #,rng-ctcs)))
#,(call-gen #'())]
[else #,(call-gen rng-checkers)]))))
(with-syntax ([blame blame] (with-syntax ([blame blame]
[val val]) [val val])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)
@ -137,181 +149,188 @@ v4 todo:
[([opt-kwd opt-kwd-ctc opt-kwd-x] ...) [([opt-kwd opt-kwd-ctc opt-kwd-x] ...)
(for/list ([d (in-list opt-kwds)]) (for/list ([d (in-list opt-kwds)])
(list (car d) (cadr d) (gensym 'opt-kwds)))] (list (car d) (cadr d) (gensym 'opt-kwds)))]
[(rng-checker ...) [([rng-ctc rng-x] ...)
(if rngs (if rngs
(with-syntax ([rng-len (length rngs)] (for/list ([r (in-list rngs)])
[rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")] (list r (gensym 'rng)))
[([rng-ctc rng-x] ...)
(for/list ([r (in-list rngs)])
(list r (gensym 'rng)))])
(with-syntax ([rng-params
(if (null? rngs)
#'rest-x
#'([rng-x unspecified-dom] ... . rest-x))]
[rng-results
(if (and (pair? rngs) (null? (cdr rngs)))
(with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))]
[name (car (syntax->list #'(rng-x ...)))])
#'(proj name))
#'(values (rng-ctc rng-x) ...))])
(list #'(λ rng-params
(when (or (pair? rest-x)
(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)] (with-syntax ([(rng-checker ...)
[max-method-arity (+ min-method-arity (length opt-doms))] (if rngs
[min-arity (+ (length this-args) min-method-arity)] (with-syntax ([rng-len (length rngs)]
[max-arity (+ min-arity (length opt-doms))] [rng-pluralize (if (and (pair? rngs) (null? (cdr rngs))) "" "s")])
[req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)] (with-syntax ([rng-params
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)] (if (null? rngs)
[need-apply-values? (or dom-rest (not (null? opt-doms)))]) #'rest-x
(with-syntax ([args-len #'([rng-x unspecified-dom] ... . rest-x))]
(if (= min-method-arity min-arity) [rng-results
#'(length args) (if (and (pair? rngs) (null? (cdr rngs)))
#'(sub1 (length args)))] (with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))]
[arity-string [name (car (syntax->list #'(rng-x ...)))])
(if dom-rest #'(proj name))
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s")) #'(values (rng-ctc rng-x) ...))])
(if (= min-method-arity max-method-arity) (list #'(λ rng-params
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s")) (when (or (pair? rest-x)
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)))] (eq? unspecified-dom rng-x) ...)
[arity-checker (let ([num-values (+ (length rest-x) (if (eq? unspecified-dom rng-x) 0 1) ...)])
(if dom-rest (raise-blame-error blame val
#`(>= (length args) #,min-arity) "expected ~a value~a, returned ~a value~a"
(if (= min-arity max-arity) rng-len rng-pluralize
#`(= (length args) #,min-arity) num-values (if (= num-values 1) "" "s"))))
#`(and (>= (length args) #,min-arity) (<= (length args) #,max-arity))))] post ...
[basic-params rng-results))))
(cond null)])
[dom-rest (let* ([min-method-arity (length doms)]
#'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... . rest-x)] [max-method-arity (+ min-method-arity (length opt-doms))]
[else [min-arity (+ (length this-args) min-method-arity)]
#'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])] [max-arity (+ min-arity (length opt-doms))]
[opt+rest-uses [req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
(for/fold ([i (if dom-rest #'(rest-ctc rest-x) #'null)]) [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
([o (in-list (reverse (syntax->list #'([opt-dom-ctc opt-dom-x] ...))))]) [need-apply-values? (or dom-rest (not (null? opt-doms)))]
(let* ([l (syntax->list o)] [no-rng-checking? (not rngs)])
[c (car l)] (with-syntax ([args-len
[x (cadr l)]) (if (= min-method-arity min-arity)
#`(let ([r #,i]) #'(length args)
(if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))] #'(sub1 (length args)))]
[(kwd-param ...) [arity-string
(apply append
(map list
(syntax->list #'(req-kwd ... opt-kwd ...))
(syntax->list #'(req-kwd-x ... [opt-kwd-x unspecified-dom] ...))))]
[kwd-stx
(let* ([req-stxs
(map (λ (s) (λ (r) #`(cons #,s #,r)))
(syntax->list #'((req-kwd-ctc req-kwd-x) ...)))]
[opt-stxs
(map (λ (x c) (λ (r) #`(let ([r #,r]) (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))
(syntax->list #'(opt-kwd-x ...))
(syntax->list #'(opt-kwd-ctc ...)))]
[reqs (map cons req-keywords req-stxs)]
[opts (map cons opt-keywords opt-stxs)]
[all-together-now (append reqs opts)]
[put-in-reverse (sort all-together-now (λ (k1 k2) (keyword<? k2 k1)) #:key car)])
(for/fold ([s #'null])
([tx (in-list (map cdr put-in-reverse))])
(tx s)))])
(with-syntax ([kwd-lam-params
(if dom-rest (if dom-rest
#'(dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ... . rest-x) (format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))
#'(dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ...))] (if (= min-method-arity max-method-arity)
[basic-return (format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))
(if need-apply-values? (format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)))]
#'(apply values rng-checker ... this-param ... (dom-ctc dom-x) ... opt+rest-uses) [arity-checker
(let* ([mand-params #'(rng-checker ... this-param ... (dom-ctc dom-x) ...)] (if dom-rest
[params-no-stx (syntax->list mand-params)]) #`(>= (length args) #,min-arity)
(if (and (pair? params-no-stx) (null? (cdr params-no-stx))) (if (= min-arity max-arity)
(car params-no-stx) #`(= (length args) #,min-arity)
#`(values . #,mand-params))))] #`(and (>= (length args) #,min-arity) (<= (length args) #,max-arity))))]
[kwd-return [basic-params
(if need-apply-values? (cond
#'(let ([kwd-results kwd-stx]) [dom-rest
(if (null? kwd-results) #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... . rest-x)]
(apply values rng-checker ... this-param ... (dom-ctc dom-x) ... opt+rest-uses) [else
(apply values rng-checker ... kwd-results this-param ... (dom-ctc dom-x) ... opt+rest-uses))) #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])]
(let* ([mand-params #'(rng-checker ... this-param ... (dom-ctc dom-x) ...)] [opt+rest-uses
[params-no-stx (syntax->list mand-params)]) (for/fold ([i (if dom-rest #'(rest-ctc rest-x) #'null)])
#`(let ([kwd-results kwd-stx]) ([o (in-list (reverse (syntax->list #'([opt-dom-ctc opt-dom-x] ...))))])
(if (null? kwd-results) (let* ([l (syntax->list o)]
#,(if (and (pair? params-no-stx) (null? params-no-stx)) [c (car l)]
(car params-no-stx) [x (cadr l)])
#`(values . #,mand-params)) #`(let ([r #,i])
(values rng-checker ... kwd-results this-param ... (dom-ctc dom-x) ...)))))]) (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))]
(with-syntax ([basic-lambda-name (gensym 'basic-lambda)] [(kwd-param ...)
[basic-lambda #'(λ basic-params pre ... basic-return)] (apply append
[kwd-lambda-name (gensym 'kwd-lambda)] (map list
[kwd-lambda #`(λ kwd-lam-params pre ... kwd-return)]) (syntax->list #'(req-kwd ... opt-kwd ...))
(with-syntax ([basic-checker-name (gensym 'basic-checker)] (syntax->list #'(req-kwd-x ... [opt-kwd-x unspecified-dom] ...))))]
[basic-checker [kwd-stx
(if (null? req-keywords) (let* ([req-stxs
#'(λ args (map (λ (s) (λ (r) #`(cons #,s #,r)))
(unless arity-checker (syntax->list #'((req-kwd-ctc req-kwd-x) ...)))]
(raise-blame-error blame val [opt-stxs
"received ~a argument~a, expected ~a" (map (λ (x c) (λ (r) #`(let ([r #,r]) (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))
args-len (if (= args-len 1) "" "s") arity-string)) (syntax->list #'(opt-kwd-x ...))
(apply basic-lambda-name args)) (syntax->list #'(opt-kwd-ctc ...)))]
#'(λ args [reqs (map cons req-keywords req-stxs)]
(raise-blame-error (blame-swap blame) val [opts (map cons opt-keywords opt-stxs)]
"expected required keyword ~a" [all-together-now (append reqs opts)]
(quote #,(car req-keywords)))))] [put-in-reverse (sort all-together-now (λ (k1 k2) (keyword<? k2 k1)) #:key car)])
[kwd-checker (for/fold ([s #'null])
(if (and (null? req-keywords) (null? opt-keywords)) ([tx (in-list (map cdr put-in-reverse))])
#'(λ (kwds kwd-args . args) (tx s)))])
(raise-blame-error (blame-swap blame) val (with-syntax ([kwd-lam-params
"expected no keywords")) (if dom-rest
#'(λ (kwds kwd-args . args) #'(dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ... . rest-x)
(unless arity-checker #'(dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ...))]
(raise-blame-error blame val [basic-return
"received ~a argument~a, expected ~a" (let ([inner-stx-gen
args-len (if (= args-len 1) "" "s") arity-string)) (if need-apply-values?
(unless (memq (quote req-kwd) kwds) (λ (s) #`(apply values #,@s this-param ... (dom-ctc dom-x) ... opt+rest-uses))
(raise-blame-error blame val (λ (s) #`(values #,@s this-param ... (dom-ctc dom-x) ...)))])
"expected keyword argument ~a" (if no-rng-checking?
(quote req-kwd))) ... (inner-stx-gen #'())
(let ([all-kwds (list (quote req-kwd) ... (quote opt-kwd) ...)]) (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) inner-stx-gen)))]
(for/list ([k (in-list kwds)]) [kwd-return
(unless (memq k all-kwds) (let* ([inner-stx-gen
(raise-blame-error blame val (if need-apply-values?
"received unexpected keyword argument ~a" (λ (s k) #`(apply values #,@s #,@k this-param ... (dom-ctc dom-x) ... opt+rest-uses))
k)))) (λ (s k) #`(values #,@s #,@k this-param ... (dom-ctc dom-x) ...)))]
(keyword-apply kwd-lambda-name kwds kwd-args args)))] [outer-stx-gen
[contract-arity (if (null? req-keywords)
(cond (λ (s)
[dom-rest #`(make-arity-at-least #,min-arity)] #`(let ([kwd-results kwd-stx])
[(= min-arity max-arity) min-arity] (if (null? kwd-results)
[else (cons #'list (build-list (add1 (- max-arity min-arity)) (λ (n) (+ min-arity n))))])]) #,(inner-stx-gen s #'())
(cond #,(inner-stx-gen s #'(kwd-results)))))
[(and (null? req-keywords) (null? opt-keywords)) (λ (s)
#`(let ([basic-lambda-name basic-lambda]) #`(let ([kwd-results kwd-stx])
(if (matches-arity-exactly? val contract-arity null null) #,(inner-stx-gen s #'(kwd-results)))))])
basic-lambda-name (if no-rng-checking?
(let-values ([(vr va) (procedure-keywords val)] (outer-stx-gen #'())
[(basic-checker-name) basic-checker]) (check-tail-contract (length rngs) #'(rng-ctc ...) #'(rng-checker ...) outer-stx-gen)))])
(if (or (not va) (pair? vr) (pair? va)) (with-syntax ([basic-lambda-name (gensym 'basic-lambda)]
(make-keyword-procedure kwd-checker basic-checker-name) [basic-lambda #'(λ basic-params pre ... basic-return)]
basic-checker-name))))] [kwd-lambda-name (gensym 'kwd-lambda)]
[(pair? req-keywords) [kwd-lambda #`(λ kwd-lam-params pre ... kwd-return)])
#`(let ([kwd-lambda-name kwd-lambda]) (with-syntax ([basic-checker-name (gensym 'basic-checker)]
(if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...)) [basic-checker
kwd-lambda-name (if (null? req-keywords)
(make-keyword-procedure kwd-checker basic-checker)))] #'(λ args
[else (unless arity-checker
#`(let ([basic-lambda-name basic-lambda] (raise-blame-error blame val
[kwd-lambda-name kwd-lambda]) "received ~a argument~a, expected ~a"
(if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...)) args-len (if (= args-len 1) "" "s") arity-string))
kwd-lambda-name (apply basic-lambda-name args))
(make-keyword-procedure kwd-checker basic-checker)))])))))))))) #'(λ 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
[(and (null? req-keywords) (null? opt-keywords))
#`(let ([basic-lambda-name basic-lambda])
(if (matches-arity-exactly? val contract-arity null null)
basic-lambda-name
(let-values ([(vr va) (procedure-keywords val)]
[(basic-checker-name) basic-checker])
(if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name))))]
[(pair? req-keywords)
#`(let ([kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity (list 'req-kwd ...) (list 'opt-kwd ...))
kwd-lambda-name
(make-keyword-procedure kwd-checker basic-checker)))]
[else
#`(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(if (matches-arity-exactly? val contract-arity null (list 'opt-kwd ...))
kwd-lambda-name
(make-keyword-procedure kwd-checker basic-checker)))])))))))))))
;; 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.
@ -576,7 +595,8 @@ v4 todo:
(syntax->list #'(kwd-names ...))) (syntax->list #'(kwd-names ...)))
null null
(if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))) (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))))
proxy-prop:contracted ctc)))]) proxy-prop:contracted ctc
proxy-prop:application-mark (cons contract-key (list rng-names ...)))))])
(syntax-property (syntax-property
(syntax (syntax
(build--> '-> (build--> '->
@ -900,7 +920,8 @@ v4 todo:
(map list (syntax->list #'(optional-dom-kwd ...)) (map list (syntax->list #'(optional-dom-kwd ...))
(syntax->list #'(optional-dom-kwd-proj ...))) (syntax->list #'(optional-dom-kwd-proj ...)))
(if rng-ctc (syntax->list #'(rng-proj ...)) #f)) (if rng-ctc (syntax->list #'(rng-proj ...)) #f))
proxy-prop:contracted ctc))))))))))])) proxy-prop:contracted ctc
proxy-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)))