cleaned up a few little things here and there to pass the last of the existing tests
This commit is contained in:
Robby Findler
parent
b5fad95e58
commit
9d98533e23
|
|
@ -286,16 +286,13 @@ code does the parsing and validation of the syntax.
|
||||||
(syntax->list #'(ctc-pr ...)))]
|
(syntax->list #'(ctc-pr ...)))]
|
||||||
[any #f]
|
[any #f]
|
||||||
[[_ ctc]
|
[[_ ctc]
|
||||||
(begin
|
(list (eres #'id #f #'ctc (car (generate-temporaries '(eres)))))]
|
||||||
(printf "eres.1\n")
|
|
||||||
(list (eres #'id #f #'ctc (car (generate-temporaries '(eres))))))]
|
|
||||||
[[id ctc]
|
[[id ctc]
|
||||||
(begin
|
(begin
|
||||||
(check-id stx #'id)
|
(check-id stx #'id)
|
||||||
(list (lres #'id #f #'ctc)))]
|
(list (lres #'id #f #'ctc)))]
|
||||||
[[_ (id2 ...) ctc]
|
[[_ (id2 ...) ctc]
|
||||||
(begin
|
(begin
|
||||||
(printf "eres.2\n")
|
|
||||||
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...)))
|
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...)))
|
||||||
(list (eres #'id (syntax->list #'(id2 ...)) #'ctc (car (generate-temporaries '(eres))))))]
|
(list (eres #'id (syntax->list #'(id2 ...)) #'ctc (car (generate-temporaries '(eres))))))]
|
||||||
[[id (id2 ...) ctc]
|
[[id (id2 ...) ctc]
|
||||||
|
|
|
||||||
|
|
@ -77,7 +77,7 @@
|
||||||
partial-indy-rngs))))))
|
partial-indy-rngs))))))
|
||||||
#:name (λ (ctc) '(->i ...)) ;; WRONG
|
#:name (λ (ctc) '(->i ...)) ;; WRONG
|
||||||
#:first-order (λ (ctc) (λ (x) #f)) ;; 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))
|
;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
|
||||||
;; sorts the arguments according to the dependency order.
|
;; sorts the arguments according to the dependency order.
|
||||||
|
|
@ -328,6 +328,7 @@
|
||||||
arg-call-stx)
|
arg-call-stx)
|
||||||
(cond
|
(cond
|
||||||
[(istx-ress an-istx)
|
[(istx-ress an-istx)
|
||||||
|
;; WRONG! needs to preserve tail recursion? .... well ->d does anyways.
|
||||||
#`(let-values ([#,(vector->list wrapper-ress) #,arg-call-stx])
|
#`(let-values ([#,(vector->list wrapper-ress) #,arg-call-stx])
|
||||||
|
|
||||||
#,(add-wrapper-let
|
#,(add-wrapper-let
|
||||||
|
|
@ -442,27 +443,30 @@
|
||||||
(λ (val)
|
(λ (val)
|
||||||
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
||||||
(make-contracted-function
|
(make-contracted-function
|
||||||
(λ #,(args/vars->arglist an-istx wrapper-args)
|
#,(syntax-property
|
||||||
#,(add-wrapper-let
|
#`(λ #,(args/vars->arglist an-istx wrapper-args)
|
||||||
(add-pre-cond
|
#,(add-wrapper-let
|
||||||
an-istx
|
(add-pre-cond
|
||||||
arg/res-to-indy-var
|
an-istx
|
||||||
(add-eres-lets
|
arg/res-to-indy-var
|
||||||
an-istx
|
(add-eres-lets
|
||||||
res-proj-vars
|
an-istx
|
||||||
arg/res-to-indy-var
|
res-proj-vars
|
||||||
(add-result-checks
|
arg/res-to-indy-var
|
||||||
an-istx
|
(add-result-checks
|
||||||
ordered-ress res-indicies
|
an-istx
|
||||||
res-proj-vars indy-res-proj-vars
|
ordered-ress res-indicies
|
||||||
wrapper-ress indy-res-vars
|
res-proj-vars indy-res-proj-vars
|
||||||
arg/res-to-indy-var
|
wrapper-ress indy-res-vars
|
||||||
(args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args))))
|
arg/res-to-indy-var
|
||||||
#t
|
(args/vars->callsite #'val (istx-args an-istx) (istx-rst an-istx) wrapper-args))))
|
||||||
ordered-args arg-indicies
|
#t
|
||||||
arg-proj-vars indy-arg-proj-vars
|
ordered-args arg-indicies
|
||||||
wrapper-args indy-arg-vars
|
arg-proj-vars indy-arg-proj-vars
|
||||||
arg/res-to-indy-var))
|
wrapper-args indy-arg-vars
|
||||||
|
arg/res-to-indy-var))
|
||||||
|
'inferred-name
|
||||||
|
(syntax-local-name))
|
||||||
ctc)))))))
|
ctc)))))))
|
||||||
|
|
||||||
(define (un-dep ctc obj blame)
|
(define (un-dep ctc obj blame)
|
||||||
|
|
|
||||||
|
|
@ -4,43 +4,9 @@
|
||||||
|
|
||||||
(pretty-print
|
(pretty-print
|
||||||
(syntax->datum (expand-once
|
(syntax->datum (expand-once
|
||||||
#'(->i ([i (box/c (listof integer?))])
|
#'(->i () (res 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))])))))
|
|
||||||
|
|
||||||
|
;; ==> ???
|
||||||
(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:
|
;; timing tests:
|
||||||
|
|
|
||||||
|
|
@ -2506,7 +2506,7 @@
|
||||||
'pos
|
'pos
|
||||||
'neg))
|
'neg))
|
||||||
x)
|
x)
|
||||||
'(ctc body))
|
'(body ctc))
|
||||||
|
|
||||||
(test/spec-passed/result
|
(test/spec-passed/result
|
||||||
'->i-underscore4
|
'->i-underscore4
|
||||||
|
|
@ -2524,6 +2524,17 @@
|
||||||
1 2 3 4 5)
|
1 2 3 4 5)
|
||||||
'(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))
|
(f 3))
|
||||||
(c)))
|
(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
|
(ctest 2
|
||||||
'case->-regular
|
'case->-regular
|
||||||
(let ([c (counter)])
|
(let ([c (counter)])
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user