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

contract checks on {start,end}-{doc,page} use

Browse Source 
svn: r5591
This commit is contained in:
Matthew Flatt 2007-02-13 02:08:04 +00:00
parent e3394a5cf5
commit 3b966ff86b
1 changed files with 122 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/mred/private/gdi.ss
View File

@ -44,17 +44,131 @@
(when bitmap
(set-bitmap bitmap)))))
(define-syntax check-page-active
(syntax-rules ()
[(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
(define-syntax check-one-page-active
(syntax-rules ()
[(_ check-page-status id simple ... (arg ... [opt ...]))
(check-one-page-active
check-page-status id
simple ...
(arg ...)
(arg ... opt ...))]
[(_ check-page-status id (arg ...) ...)
(define/override id
(case-lambda
[(arg ...) (check-page-status 'id) (super id arg ...)]
...))]))
(define-local-member-name multiple-pages-ok?)
(define (doc+page-check-mixin % class-name)
(class %
(define status #f)
(define did-one-page? #f)
(define/public (multiple-pages-ok?) #t)
(define/override (start-doc s)
(when status
(raise-mismatch-error (who->name (list 'method class-name 'start-doc))
(case status
[(done)
"document has already been ended: "]
[else
"document has already been started: "])
this))
(set! status 'doc)
(super start-doc s))
(define/override (end-doc)
(unless (eq? status 'doc)
(raise-mismatch-error (who->name (list 'method class-name 'end-doc))
(case status
[(page)
"current page has not been ended: "]
[(done)
"document is already ended: "]
[(#f)
"document is not started: "])
this))
(set! status 'done)
(super end-doc))
(define/override (start-page)
(unless (eq? status 'doc)
(raise-mismatch-error (who->name (list 'method class-name 'start-page))
(if (eq? status 'page)
"current page has not been ended: "
"document is not started (use the `start-doc' method): ")
this))
(when did-one-page?
(unless (multiple-pages-ok?)
(raise-mismatch-error (who->name (list 'method class-name 'start-page))
"cannot create multiple pages for EPS output: "
this)))
(set! status 'page)
(set! did-one-page? #t)
(super start-page))
(define/override (end-page)
(unless (eq? status 'page)
(raise-mismatch-error (who->name (list 'method class-name 'end-page))
"no page is currently started: "
this))
(set! status 'doc)
(super end-page))
(define/private (check-page-status method-name)
(unless (eq? status 'page)
(raise-mismatch-error (who->name (list 'method class-name method-name))
"no page is currently started (use `start-doc' and `start-page' before drawing): "
this)))
(check-page-active
check-page-status
(draw-bitmap source dest-x dest-y [style [color [mask]]])
(draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]])
(set-text-foreground c)
(set-text-background c)
(set-brush b/c [style])
(set-pen p/c [width style])
(set-font f)
(set-background c)
(set-clipping-region r)
(set-clipping-rect x y w h)
(draw-polygon pts [x [y [fill]]])
(draw-lines pts [x [y]])
(draw-path path [x [y [fill]]])
(draw-ellipse x y w h)
(draw-arc x y w h s e)
(draw-text txt x y [combine? [offset [angle]]])
(draw-spline x1 y1 x2 y2 x3 y3)
(draw-rounded-rectangle x y w h [r])
(draw-rectangle x y w h)
(draw-point x y)
(draw-line x1 y1 x2 y2)
(clear))
(super-new)))
(define post-script-dc%
(class100 wx:post-script-dc% ([interactive #t][parent #f][use-paper-bbox #f][as-eps #t])
(sequence
(class (doc+page-check-mixin wx:post-script-dc% 'post-script-dc%)
(init [interactive #t][parent #f][use-paper-bbox #f][as-eps #t])
(check-top-level-parent/false '(constructor post-script-dc) parent)
(define is-eps? (and as-eps #t))
(define/override (multiple-pages-ok?) (not is-eps?))
(as-entry
(lambda ()
(let ([p (and parent (mred->wx parent))])
(as-exit (lambda () (super-init interactive p use-paper-bbox as-eps)))))))))
(as-exit (lambda () (super-make-object interactive p use-paper-bbox as-eps))))))))
(define printer-dc%
(class100 wx:printer-dc% ([parent #f])
(class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f])
(sequence
(check-top-level-parent/false '(constructor printer-dc) parent)
(as-entry