diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 87860226a2..4dc0fea462 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -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))))))) + + + ; ; ; diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index ca1d32a8ba..6627e2dee7 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -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)) + + ; ; ; diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl index dff45ca2d9..bc1376e3de 100644 --- a/collects/scribblings/guide/contracts-simple-function.scrbl +++ b/collects/scribblings/guide/contracts-simple-function.scrbl @@ -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) -] -}} diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 76eb3302a4..ff8c1b6ff0 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -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 diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 52ef6ffe3f..41a88c6369 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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))) + ; ; ;