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

fixed and ->i bug that could cause expressions to be evaluated twice

Browse Source
This commit is contained in:
Robby Findler 2010-10-20 08:36:53 -05:00
parent 594c72167e
commit b91a0da469
3 changed files with 95 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -676,8 +676,9 @@
'racket/contract:negative-position 'racket/contract:negative-position
this->i) this->i)
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary)) (gensym '->i-indy-boundary))
val blame)))) val blame
un-dep))))
args+rst))) args+rst)))
;; then the non-dependent argument contracts that are themselves dependend on ;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values (list #,@(filter values
@ -711,7 +712,8 @@
this->i) this->i)
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary)) (gensym '->i-indy-boundary))
val blame))))) val blame
un-dep)))))
(istx-ress an-istx)))) (istx-ress an-istx))))
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)

48
collects/racket/contract/private/opt.rkt
View File

@ -173,30 +173,34 @@
(vector) (vector)
(begin-lifted (box #f)))))))])) (begin-lifted (box #f)))))))]))
;; this macro optimizes 'e' as a contract ;; this macro optimizes 'e' as a contract,
;; using otherwise-id if it does not recognize 'e'.
(define-syntax (opt/direct stx) (define-syntax (opt/direct stx)
(syntax-case stx () (syntax-case stx ()
[(_ e val-e blame-e) [(_ e val-e blame-e otherwise-id)
(let*-values ([(info) (make-opt/info #'ctc (identifier? #'otherwise-id)
#'val (if (top-level-unknown? #'e)
#'blame #'(otherwise-id e val-e blame-e)
#f (let*-values ([(info) (make-opt/info #'ctc
'() #'val
#f #'blame
#f #f
#'this '()
#'that)] #f
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) #f
#`(let ([ctc e] ;;; hm... what to do about this?! #'this
[val val-e] #'that)]
[blame blame-e]) [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
#,(bind-superlifts #`(let ([ctc e] ;;; hm... what to do about this?!
superlifts [val val-e]
(bind-lifts [blame blame-e])
lifts #,(bind-superlifts
(bind-superlifts superlifts
partials (bind-lifts
next)))))])) lifts
(bind-superlifts
partials
next))))))]))
(define-syntax (begin-lifted stx) (define-syntax (begin-lifted stx)
(syntax-case stx () (syntax-case stx ()

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

@ -2605,6 +2605,70 @@
'neg) 'neg)
#f)) #f))
(test/spec-passed/result
'->i48
'(let ([x '()])
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
[res () (begin
(set! x (cons 'res-eval x))
(λ (res)
(set! x (cons 'res-check x))))])
(λ (arg)
(set! x (cons 'body x)))
'pos
'neg)
1)
x)
'(res-check res-eval body arg-eval))
(test/spec-passed/result
'->i49
'(let ([x '()])
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
[_ () (begin
(set! x (cons 'res-eval x))
(λ (res)
(set! x (cons 'res-check x))))])
(λ (arg)
(set! x (cons 'body x)))
'pos
'neg)
1)
x)
'(res-check body res-eval arg-eval))
(test/spec-passed/result
'->i50
'(let ([x '()])
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
[res (begin
(set! x (cons 'res-eval x))
(λ (res)
(set! x (cons 'res-check x))))])
(λ (arg)
(set! x (cons 'body x)))
'pos
'neg)
1)
x)
'(res-check body res-eval arg-eval))
(test/spec-passed/result
'->i51
'(let ([x '()])
((contract (->i ([arg (begin (set! x (cons 'arg-eval x)) integer?)])
[_ (begin
(set! x (cons 'res-eval x))
(λ (res)
(set! x (cons 'res-check x))))])
(λ (arg)
(set! x (cons 'body x)))
'pos
'neg)
1)
x)
'(res-check body res-eval arg-eval))
(test/pos-blame (test/pos-blame
'->i-arity1 '->i-arity1
'(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))