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

fixed pr 7628, ->d now checks the domain contract before partially applying the range function

Browse Source 
svn: r1042
This commit is contained in:
Robby Findler 2005-10-11 12:57:57 +00:00
parent bc6ef7ede0
commit 71a5040785
4 changed files with 37 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drscheme/acks.ss
View File

@ -55,7 +55,8 @@
"Jens Axel Søgaard, "
"Francisco Solsona, "
"Reini Urban, "
"Paolo Zoppetti, "
"and "
"Paolo Zoppetti "
"Zhu Chongkai "
"for their help translating DrScheme's GUI to other languages.")))

15
collects/mzlib/private/contract.ss
View File

@ -1959,13 +1959,14 @@ add struct contracts for immutable structs?
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
(syntax
((arg-x ...)
(let ([rng-contract (rng-x arg-x ...)])
(((coerce/select-contract ->d rng-contract)
pos-blame
neg-blame
src-info
orig-str)
(val (dom-projection-x arg-x) ...)))))))))]))
(let ([arg-x (dom-projection-x arg-x)] ...)
(let ([rng-contract (rng-x arg-x ...)])
(((coerce/select-contract ->d rng-contract)
pos-blame
neg-blame
src-info
orig-str)
(val arg-x ...))))))))))]))
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d*/h method-proc? stx)

21
collects/slideshow/viewer.ss
View File

@ -415,8 +415,8 @@
[close-bg? #f]
[label "Slideshow Preview"]
[x 0] [y 0]
[width (inexact->exact (floor config:actual-screen-w))]
[height (inexact->exact (quotient (floor config:actual-screen-h) 2))]
[width (inexact->exact (floor (* config:actual-screen-w 8/10 1)))]
[height (inexact->exact (floor (* config:actual-screen-h 8/10 2/3)))]
[style '()]))
(define current-sinset zero-inset)
@ -730,7 +730,7 @@
(let ([dc (get-dc)])
(let*-values ([(cw ch) (send dc get-size)])
(send dc set-scale
(/ (/ cw 2) (send prefetch-bitmap get-width))
(/ (* cw 1/2) (send prefetch-bitmap get-width))
(/ ch (send prefetch-bitmap get-height)))
(send dc set-origin (/ cw 2) 0)
(send dc draw-bitmap prefetch-bitmap 0 0)
@ -751,7 +751,7 @@
(send dc draw-bitmap now-bm 0 0)
(cond
[(equal? prefetched-page (add1 current-page))
(send dc set-origin (/ cw 2) 0)
(send dc set-origin (/ cw 3) 0)
(send dc draw-bitmap prefetch-bitmap 0 0)]
[else
(when (< (add1 current-page) slide-count)
@ -761,16 +761,17 @@
(send dc set-brush b)))])
(send dc set-scale 1 1))]
[else
(paint-slide dc current-page 1/2 1/2 cw (* 2 ch) cw (* 2 ch) #f)
(send dc set-origin (/ cw 2) 0)
(paint-slide dc current-page 2/3 1/2 cw ch cw ch #f)
(send dc set-origin (* cw 2/3) 0)
(when (< (add1 current-page) slide-count)
(paint-slide dc
(send dc draw-rectangle (* cw 2/3) 0 (* cw 1/3) ch)
(paint-slide dc
(+ current-page 1)
1/2 1/2
cw (* 2 ch) cw (* 2 ch)
1/3 1/6
cw ch cw ch
#f))])
(send dc set-origin 0 0)
(send dc draw-line (/ cw 2) 0 (/ cw 2) ch))))
(send dc draw-line (* cw 2/3) 0 (* cw 2/3) ch))))
(inherit get-top-level-window)
(define/override (on-event e)

16
collects/tests/mzscheme/contract-test.ss
View File

@ -378,6 +378,22 @@
'neg)
2))
(test/neg-blame
'contract-d3
'((contract (integer? . ->d . (lambda (x) (let ([z (+ x 1)]) (lambda (y) (= z y)))))
(lambda (x) (+ x 1))
'pos
'neg)
"bad input"))
(test/neg-blame
'contract-d4
'((contract (integer? . ->d . (lambda (x) (lambda (y) (= (+ x 1) y))))
(lambda (x) (+ x 1))
'pos
'neg)
"bad input"))
(test/spec-passed
'contract-arrow1
'(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))