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

function contracts now preserve tail recursion

Browse Source 
svn: r12360
This commit is contained in:
Robby Findler 2008-11-09 02:31:25 +00:00
parent 5c2e2c25c5
commit 2394848555
5 changed files with 328 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -316,8 +316,8 @@ v4 todo:
(syntax (dom-kwd-ctc ...))
(syntax (dom-kwd ...))
(syntax ((this-parameter ... args ... keyword-formal-parameters ...)
(let-values ([(rng-x ...) (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...)])
(values (rng-ctc rng-x) ...))))
(apply-projections ((rng-x rng-ctc) ...)
(val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...))))
#f))]
[rng
(with-syntax ([(rng-ctc) (generate-temporaries (syntax (rng)))])
@ -329,7 +329,7 @@ v4 todo:
(syntax (dom-kwd-ctc ...))
(syntax (dom-kwd ...))
(syntax ((this-parameter ... args ... keyword-formal-parameters ...)
(rng-ctc (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...))))
(apply-projection rng-ctc (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...))))
#f))]))))]))
(define-for-syntax (maybe-a-method/name stx)
@ -653,6 +653,9 @@ v4 todo:
#'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
#'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
(if rng-ctc
#`(apply-projections ((rng rng-proj) ...)
#,call)
#;
#`(let-values ([(rng ...) #,call])
(values (rng-proj rng) ...))
call))))))))))))))]))
@ -835,126 +838,132 @@ v4 todo:
(length (->d-optional-dom-ctcs ->d-stct))
(if (->d-mtd? ->d-stct) 1 0))])
(λ (pos-blame neg-blame src-info orig-str)
(λ (val)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
src-info pos-blame orig-str)
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
(cdr raw-orig-args)
raw-orig-args)]
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
[dep-pre-args
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
[thnk
(λ ()
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation")))
(keyword-apply
val
kwd-args
;; contracted keyword arguments
(let loop ([all-kwds (->d-keywords ->d-stct)]
[kwd-ctcs (->d-keyword-ctcs ->d-stct)]
[building-kwd-args kwd-args]
[building-kwd-arg-vals kwd-arg-vals])
(cond
[(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds)
(car building-kwd-args))
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str)
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
(append
;; this parameter (if necc.)
(if (->d-mtd? ->d-stct)
(list (car raw-orig-args))
'())
;; contracted ordinary arguments
(let loop ([args orig-args]
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
(->d-optional-dom-ctcs ->d-stct))])
(cond
[(null? args)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str)
'())]
[(null? non-kwd-ctcs)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str)
;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
(loop (cdr args)
(cdr non-kwd-ctcs)))])))))]
[rng (let ([rng (->d-range ->d-stct)])
(cond
[(not rng) #f]
[(box? rng)
(map (λ (val) (apply val dep-pre-args))
(unbox rng))]
[else rng]))]
[rng-underscore? (box? (->d-range ->d-stct))])
(if rng
(call-with-values
thnk
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation")))
(unless (= range-count (length orig-results))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str)
(loop (cdr results) (cdr result-contracts)))]))))))
(thnk))))])
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args
(apply kwd-proc '() '() args)))))))))
(let ([tail-key (gensym '->d-tail-key)])
(λ (val)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
src-info pos-blame orig-str)
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
(cdr raw-orig-args)
raw-orig-args)]
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
[dep-pre-args
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
[thnk
(λ ()
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation")))
(with-continuation-mark tail-key #t
(keyword-apply
val
kwd-args
;; contracted keyword arguments
(let loop ([all-kwds (->d-keywords ->d-stct)]
[kwd-ctcs (->d-keyword-ctcs ->d-stct)]
[building-kwd-args kwd-args]
[building-kwd-arg-vals kwd-arg-vals])
(cond
[(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds)
(car building-kwd-args))
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str)
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
(append
;; this parameter (if necc.)
(if (->d-mtd? ->d-stct)
(list (car raw-orig-args))
'())
;; contracted ordinary arguments
(let loop ([args orig-args]
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
(->d-optional-dom-ctcs ->d-stct))])
(cond
[(null? args)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str)
'())]
[(null? non-kwd-ctcs)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str)
;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
(loop (cdr args)
(cdr non-kwd-ctcs)))]))))))]
[rng (let ([rng (->d-range ->d-stct)])
(cond
[(not rng) #f]
[(box? rng)
(map (λ (val) (apply val dep-pre-args))
(unbox rng))]
[else rng]))]
[rng-underscore? (box? (->d-range ->d-stct))])
(call-with-immediate-continuation-mark
tail-key
(λ (first-mark)
(if (and rng
(not first-mark))
(call-with-values
thnk
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation")))
(unless (= range-count (length orig-results))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str)
(loop (cdr results) (cdr result-contracts)))]))))))
(thnk))))))])
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args
(apply kwd-proc '() '() args))))))))))
;; 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)
@ -1144,15 +1153,15 @@ v4 todo:
(this-parameter ... dom-formals ... . #,(if rst #'rst-formal '()))
#,(cond
[rng
(with-syntax ([(rng-exp ...) #'((rng-proj-x rng-id) ...)])
(with-syntax ([rng (if (= 1 (length (syntax->list #'(rng-exp ...))))
(car (syntax->list #'(rng-exp ...)))
#`(values rng-exp ...))])
(if rst
#`(let-values ([(rng-id ...) (apply f this-parameter ... (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))])
rng)
#`(let-values ([(rng-id ...) (f this-parameter ... (dom-proj-x dom-formals) ...)])
rng))))]
(if rst
#`(apply-projections ((rng-id rng-proj-x) ...)
(apply f
this-parameter ...
(dom-proj-x dom-formals) ...
(rst-proj-x rst-formal)))
#`(apply-projections ((rng-id rng-proj-x) ...)
(f this-parameter ... (dom-proj-x dom-formals) ...)))]
[rst
#`(apply f this-parameter ... (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))]
[else
@ -1267,6 +1276,76 @@ v4 todo:
(apply append (map (λ (x) (or x '())) (case->-rng-ctcs ctc))))
;
;
;
;
; ; ;;; ;;;
; ;;; ;;;
; ;;;; ;;;;; ;;; ;;;
; ;;;; ;;;;;;; ;;; ;;;
; ;;; ;; ;;; ;;; ;;;
; ;;; ;;;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;;
; ;;;; ;;; ;;; ;;; ;;;
; ;;; ;;;;;; ;;; ;;;
;
;
;
;
#;
(define-syntax (apply-projection stx)
(syntax-case stx ()
[(_ f v) #'(f v)]))
#;
(define-syntax (apply-projections stx)
(syntax-case stx ()
[(_ ((x f) ...) e)
#'(let-values ([(x ...) e])
(values (f x) ...))]))
(define-syntax (apply-projections stx)
(syntax-case stx ()
[(_ ((x f) ...) e)
(with-syntax ([count (length (syntax->list #'(x ...)))])
#'(let ([fs (list f ...)]
[thunk (λ () e)])
(call-with-immediate-continuation-mark
multiple-contract-key
(λ (first-mark)
(if (and first-mark
(= (length first-mark) count)
(andmap eq? fs first-mark))
(thunk)
(let-values ([(x ...) (with-continuation-mark multiple-contract-key fs
(thunk))])
(values (f x) ...)))))))]))
(define multiple-contract-key (gensym 'multiple-contract-key))
(define-syntax (apply-projection stx)
(syntax-case stx ()
[(_ ctc arg)
#'(apply-projection/proc ctc (λ () arg))]))
(define single-contract-key (gensym 'single-contract-key))
(define (apply-projection/proc ctc thnk)
(call-with-immediate-continuation-mark
single-contract-key
(λ (first-mark) ;; note this is #f if there is no mark (so if #f can be a contract, something must change)
(if (eq? first-mark ctc)
(thnk)
(ctc
(with-continuation-mark single-contract-key ctc
(thnk)))))))
;
;
;

4
collects/scheme/private/contract-guts.ss
View File

@ -350,7 +350,7 @@
(let ([ctc (coerce-contract 'contract-name ctc)])
((name-get ctc) ctc)))
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract-proc ctc) ((proj-get ctc) ctc))
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
@ -456,6 +456,8 @@
(define none/c (make-none/c 'none/c))
;
;
;

25
collects/scribblings/guide/contracts-simple-function.scrbl
View File

@ -324,10 +324,8 @@ difference between these two contracts is:
(-> integer? any/c)
]
Both allow any result, right? There are two differences:
@itemize{
@item{In the first case, the function may return anything at
Both allow any result, right? There is one important difference:
in the first case, the function may return anything at
all, including multiple values. In the second case, the
function may return any value, but not more than one. For
example, this function:
@ -336,22 +334,3 @@ example, this function:
]
meets the first contract, but not the second one.}
@item{This also means that a call to a function that
has the second contract is not a tail call. So, for example,
the following program is an infinite loop that takes only a constant
amount of space, but if you replace @scheme[any] with
@scheme[any/c], it uses up all of the memory available.
@schemeblock[
(module server scheme
(provide/contract
[f (-> (-> procedure? any) boolean?)])
(define (f g) (g g)))
(module client scheme
(require 'server)
(f f))
(require 'client)
]
}}

4
collects/scribblings/reference/contracts.scrbl
View File

@ -392,8 +392,8 @@ is an integer and a @scheme[#:x] argument is that a boolean.
If @scheme[any] is used as the last sub-form for @scheme[->], no
contract checking is performed on the result of the function, and
tail-recursion is preserved. Note that the function may return
multiple values in that case.
thus any number of values is legal (even different numbers on different
invocations of the function).
If @scheme[(values res-expr ...)] is used as the last sub-form of
@scheme[->], the function must produce a result for each contract, and

111
collects/tests/mzscheme/contract-test.ss
View File

@ -1617,7 +1617,6 @@
(and/c
void?
(λ (new)
(printf "old ~a new ~a\n" old (unbox b))
(= old (unbox b)))))])
(λ (b)
(set-box! b (+ (unbox b) 1)))
@ -5184,6 +5183,116 @@ so that propagation occurs.
(ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx")
(ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y)
;
;
;
;
; ; ;;; ;;;
; ;;; ;;;
; ;;;; ;;;;; ;;; ;;;
; ;;;; ;;;;;;; ;;; ;;;
; ;;; ;; ;;; ;;; ;;;
; ;;; ;;;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;;
; ;;;; ;;; ;;; ;;; ;;;
; ;;; ;;;;;; ;;; ;;;
;
;
;
;
(contract-eval
`(define (counter)
(let ([c 0])
(case-lambda
[() c]
[(x) (set! c (+ c 1)) #t]))))
(ctest 1
'tail-arrow
(let ([c (counter)])
(letrec ([f
(contract (-> any/c c)
(λ (x) (if (zero? x) x (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest 2
'tail-multiple-value-arrow
(let ([c (counter)])
(letrec ([f
(contract (-> any/c (values c c))
(λ (x) (if (zero? x) (values x x) (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest 2
'tail-arrow-star
(let ([c (counter)])
(letrec ([f
(contract (->* (any/c) () (values c c))
(λ (x) (if (zero? x) (values x x) (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest 2
'tail-arrow-d1
(let ([c (counter)])
(letrec ([f
(contract (->d ([arg any/c]) () (values [_ c] [_ c]))
(λ (x) (if (zero? x) (values x x) (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest 1
'tail-arrow-d2
(let ([c (counter)])
(letrec ([f
(contract (->d ([arg any/c]) () [rng c])
(λ (x) (if (zero? x) x (f (- x 1))))
'pos
'neg)])
(f 3))
(c)))
(ctest 2
'case->-regular
(let ([c (counter)])
(letrec ([f
(contract (case-> (-> any/c c)
(-> any/c any/c c))
(case-lambda
[(x) (if (zero? x) x (f (- x 1)))]
[(x y) (f x)])
'pos
'neg)])
(f 4 1))
(c)))
(ctest 1
'case->-rest-args
(let ([c (counter)])
(letrec ([f
(contract (case-> (-> any/c #:rest any/c c)
(-> any/c any/c #:rest any/c c))
(case-lambda
[(x) (f x 1)]
[(x y . z) (if (zero? x) x (apply f (- x 1) y (list y y)))])
'pos
'neg)])
(f 4))
(c)))
;
;
;