fixed pen and color so they signal errors properly

This commit is contained in:
Robby Findler 2010-08-28 08:52:59 -05:00
parent 405fded9c3
commit 3d5843aa81
3 changed files with 44 additions and 12 deletions

View File

@ -46,7 +46,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
|# |#
(require (except-in "../mrlib/image-core.ss" make-color make-pen) (require (except-in "../mrlib/image-core.ss" make-color color make-pen pen)
"private/image-more.ss" "private/image-more.ss"
"private/img-err.ss" "private/img-err.ss"
(only-in lang/prim provide-primitive provide-primitives define-primitive) (only-in lang/prim provide-primitive provide-primitives define-primitive)
@ -117,23 +117,24 @@ and they all have good sample contracts. (It is amazing what we can do with kids
pen-cap? pen-cap?
pen-join? pen-join?
color-red color-blue color-green color? color color-red color-blue color-green color? color
pen-color pen-width pen-style pen-cap pen-join pen pen-color pen-width pen-style pen-cap pen-join
image-width image-width
image-height image-height
image-baseline image-baseline
make-color make-color
make-pen make-pen pen
pen? pen?
step-count? step-count?
save-image) save-image)
(provide bitmap) (provide bitmap)
(define-primitive make-color build-color/make-color)
(define-primitive make-color build-color) (define-primitive color build-color/color)
(define-primitive make-pen build-pen) (define-primitive make-pen build-pen/make-pen)
(define-primitive pen build-pen/pen)
#; #;
(provide (rename-out [build-color make-color]) (provide (rename-out [build-color make-color])

View File

@ -1165,18 +1165,30 @@
#`(make-object image-snip% (make-object bitmap% #,path 'unknown/mask)))])) #`(make-object image-snip% (make-object bitmap% #,path 'unknown/mask)))]))
(define build-color (define build-color/make-color
(let ([orig-make-color make-color]) (let ([orig-make-color make-color])
(define/chk (make-color int0-255-1 int0-255-2 int0-255-3) (define/chk (make-color int0-255-1 int0-255-2 int0-255-3)
(orig-make-color int0-255-1 int0-255-2 int0-255-3)) (orig-make-color int0-255-1 int0-255-2 int0-255-3))
make-color)) make-color))
(define build-pen (define build-color/color
(let ([orig-make-color make-color])
(define/chk (color int0-255-1 int0-255-2 int0-255-3)
(orig-make-color int0-255-1 int0-255-2 int0-255-3))
color))
(define build-pen/make-pen
(let ([orig-make-pen make-pen]) (let ([orig-make-pen make-pen])
(define/chk (make-pen color real-0-255 pen-style pen-cap pen-join) (define/chk (make-pen color real-0-255 pen-style pen-cap pen-join)
(orig-make-pen color real-0-255 pen-style pen-cap pen-join)) (orig-make-pen color real-0-255 pen-style pen-cap pen-join))
make-pen)) make-pen))
(define build-pen/pen
(let ([orig-make-pen make-pen])
(define/chk (pen color real-0-255 pen-style pen-cap pen-join)
(orig-make-pen color real-0-255 pen-style pen-cap pen-join))
pen))
(provide overlay (provide overlay
overlay/align overlay/align
overlay/xy overlay/xy
@ -1249,8 +1261,10 @@
rotate-xy rotate-xy
build-color build-color/make-color
build-pen) build-color/color
build-pen/make-pen
build-pen/pen)
(provide/contract (provide/contract
[np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))] [np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))]

View File

@ -644,8 +644,10 @@
(test (empty-scene 185 100) (test (empty-scene 185 100)
=> =>
(overlay (rectangle 185 100 'outline 'black) (overlay/align "left" "top"
(rectangle 185 100 'solid 'white))) (rectangle 184 99 'outline 'solid)
(rectangle 185 100 'solid 'white)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; testing normalization ;; testing normalization
@ -1604,6 +1606,21 @@
=> =>
#rx"^save-image:") #rx"^save-image:")
(test/exn (pen 1 2 3 4 5)
=>
#rx"^pen:")
(test/exn (make-pen 1 2 3 4 5)
=>
#rx"^make-pen:")
(test/exn (make-color #f #f #f)
=>
#rx"^make-color:")
(test/exn (color #f #f #f)
=>
#rx"^color:")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; random testing of normalization ;; random testing of normalization