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

cleaned up a few little things here and there to pass the last of the existing tests

Browse Source
This commit is contained in:
Robby Findler 2010-08-06 13:46:03 -05:00
parent b5fad95e58
commit 9d98533e23
4 changed files with 42 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/racket/contract/private/arr-i-parse.rkt
View File

@ -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]

48
collects/racket/contract/private/arr-i.rkt
View File

@ -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,6 +328,7 @@
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
@ -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)

38
collects/racket/contract/scratch.rkt
View File

@ -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:

80
collects/tests/racket/contract-test.rktl
View File

@ -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)])