diff --git a/collects/racket/contract/private/arr-i-parse.rkt b/collects/racket/contract/private/arr-i-parse.rkt index 22fb6e39e0..3af491c873 100644 --- a/collects/racket/contract/private/arr-i-parse.rkt +++ b/collects/racket/contract/private/arr-i-parse.rkt @@ -286,16 +286,13 @@ code does the parsing and validation of the syntax. (syntax->list #'(ctc-pr ...)))] [any #f] [[_ ctc] - (begin - (printf "eres.1\n") - (list (eres #'id #f #'ctc (car (generate-temporaries '(eres))))))] + (list (eres #'id #f #'ctc (car (generate-temporaries '(eres)))))] [[id ctc] (begin (check-id stx #'id) (list (lres #'id #f #'ctc)))] [[_ (id2 ...) ctc] (begin - (printf "eres.2\n") (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (list (eres #'id (syntax->list #'(id2 ...)) #'ctc (car (generate-temporaries '(eres))))))] [[id (id2 ...) ctc] diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 44a35df33a..3e25d21e72 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -77,7 +77,7 @@ partial-indy-rngs)))))) #:name (λ (ctc) '(->i ...)) ;; WRONG #:first-order (λ (ctc) (λ (x) #f)) ;; WRONG - #:stronger (λ (this that) #f))) ;; WRONG + #:stronger (λ (this that) (eq? this that)))) ;; WRONG ;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) ;; sorts the arguments according to the dependency order. @@ -328,8 +328,9 @@ arg-call-stx) (cond [(istx-ress an-istx) + ;; WRONG! needs to preserve tail recursion? .... well ->d does anyways. #`(let-values ([#,(vector->list wrapper-ress) #,arg-call-stx]) - + #,(add-wrapper-let (add-post-cond an-istx arg/res-to-indy-var #`(values #,@(vector->list wrapper-ress))) #f @@ -442,27 +443,30 @@ (λ (val) (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (make-contracted-function - (λ #,(args/vars->arglist an-istx wrapper-args) - #,(add-wrapper-let - (add-pre-cond - an-istx - arg/res-to-indy-var - (add-eres-lets - an-istx - res-proj-vars - arg/res-to-indy-var - (add-result-checks - an-istx - ordered-ress res-indicies - res-proj-vars indy-res-proj-vars - wrapper-ress indy-res-vars - arg/res-to-indy-var - (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args)))) - #t - ordered-args arg-indicies - arg-proj-vars indy-arg-proj-vars - wrapper-args indy-arg-vars - arg/res-to-indy-var)) + #,(syntax-property + #`(λ #,(args/vars->arglist an-istx wrapper-args) + #,(add-wrapper-let + (add-pre-cond + an-istx + arg/res-to-indy-var + (add-eres-lets + an-istx + res-proj-vars + arg/res-to-indy-var + (add-result-checks + an-istx + ordered-ress res-indicies + res-proj-vars indy-res-proj-vars + wrapper-ress indy-res-vars + arg/res-to-indy-var + (args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args)))) + #t + ordered-args arg-indicies + arg-proj-vars indy-arg-proj-vars + wrapper-args indy-arg-vars + arg/res-to-indy-var)) + 'inferred-name + (syntax-local-name)) ctc))))))) (define (un-dep ctc obj blame) diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt index ff92eb08ac..bffdfd1933 100644 --- a/collects/racket/contract/scratch.rkt +++ b/collects/racket/contract/scratch.rkt @@ -4,43 +4,9 @@ (pretty-print (syntax->datum (expand-once - #'(->i ([i (box/c (listof integer?))]) - (values [_ (i) - (begin - (set-box! i (cons 1 (unbox i))) - (λ (x) - (set-box! i (cons 4 (unbox i))) - #t))] - [_ (i) - (begin - (set-box! i (cons 2 (unbox i))) - (λ (x) - (set-box! i (cons 5 (unbox i))) - #t))]))))) + #'(->i () (res integer?))))) - -(let ([b (box '())]) - ((contract (->i ([i (box/c (listof integer?))]) - (values [_ (i) - (begin - (set-box! i (cons 1 (unbox i))) - (λ (x) - (set-box! i (cons 4 (unbox i))) - #t))] - [_ (i) - (begin - (set-box! i (cons 2 (unbox i))) - (λ (x) - (set-box! i (cons 5 (unbox i))) - #t))])) - (λ (i) - (set-box! i (cons 3 (unbox i))) - (values 2 2)) - (quote pos) - (quote neg)) - b) - (unbox b)) -;; ==> +;; ==> ??? #| ;; timing tests: diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index a6adb6fff7..b1722ca5ee 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -2506,7 +2506,7 @@ 'pos 'neg)) x) - '(ctc body)) + '(body ctc)) (test/spec-passed/result '->i-underscore4 @@ -2524,6 +2524,17 @@ 1 2 3 4 5) '(1 2 3 4 5)) + (test/spec-passed/result + '->i-underscore6 + '(let ([x '()]) + ((contract (->i ([a integer?]) () [_ (a) (begin (set! x (cons 'ctc x)) any/c)]) + (λ (a) (set! x (cons 'body x))) + 'pos + 'neg) + 11) + x) + '(body ctc)) + ; ; ; @@ -9034,73 +9045,6 @@ so that propagation occurs. (f 3)) (c))) - (ctest 2 - 'tail-arrow-i1 - (let ([c (counter)]) - (letrec ([x 5] - [f - (contract (->i ([arg any/c]) () (values [_ (arg) c] [_ (arg) c])) - (λ (_ignored) (if (zero? x) (values x x) (begin (set! x (- x 1)) (f _ignored)))) - 'pos - 'neg)]) - (f 'ignored)) - (c))) - - - ;; this one is just like the one two above. - (ctest 4 - 'tail-arrow-i2/changing-args - (let ([c (counter)]) - (letrec ([f - (contract (->i ([arg any/c]) () [rng (arg) c]) - (λ (x) (if (zero? x) x (f (- x 1)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - (ctest 1 - 'tail-arrow-i2 - (let ([c (counter)]) - (letrec ([x 3] - [f - (contract (->i ([arg any/c]) () [rng (arg) c]) - (λ (ignored) (if (zero? x) x (begin (set! x (- x 1)) (f ignored)))) - 'pos - 'neg)]) - (f 3)) - (c))) - - ;; the tail-call optimization cannot handle two different - ;; contracts on the stack one after the other one, so this - ;; returns '(4 4) instead of '(1 1) (which would indicate - ;; the optimization had happened). - (ctest '(4 4) - 'tail->i-mut-rec - (letrec ([odd-count 0] - [pos-count 0] - [count-odd? - (λ (x) - (set! odd-count (+ odd-count 1)) - (odd? x))] - [count-positive? - (λ (x) - (set! pos-count (+ pos-count 1)) - (positive? x))] - [returns-odd - (contract (->i ([x any/c]) () [_ count-odd?]) - (λ (x) (returns-pos x)) - 'pos - 'neg)] - [returns-pos - (contract (->i ([x any/c]) () [_ count-positive?]) - (λ (x) (if (zero? x) 1 (returns-odd (- x 1)))) - 'pos - 'neg)]) - (returns-odd 3) - (list odd-count pos-count))) - - (ctest 2 'case->-regular (let ([c (counter)])