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

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

@ -173,30 +173,34 @@
(vector)
(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)
(syntax-case stx ()
[(_ e val-e blame-e)
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'blame
#f
'()
#f
#f
#'this
#'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
#`(let ([ctc e] ;;; hm... what to do about this?!
[val val-e]
[blame blame-e])
#,(bind-superlifts
superlifts
(bind-lifts
lifts
(bind-superlifts
partials
next)))))]))
[(_ e val-e blame-e otherwise-id)
(identifier? #'otherwise-id)
(if (top-level-unknown? #'e)
#'(otherwise-id e val-e blame-e)
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'blame
#f
'()
#f
#f
#'this
#'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
#`(let ([ctc e] ;;; hm... what to do about this?!
[val val-e]
[blame blame-e])
#,(bind-superlifts
superlifts
(bind-lifts
lifts
(bind-superlifts
partials
next))))))]))
(define-syntax (begin-lifted stx)
(syntax-case stx ()

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

@ -2605,6 +2605,70 @@
'neg)
#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
'->i-arity1
'(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))