From 3b966ff86b3af81fb8f70bc400665192b6628ed3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 13 Feb 2007 02:08:04 +0000
Subject: [PATCH] contract checks on {start,end}-{doc,page} use

svn: r5591
---
 collects/mred/private/gdi.ss | 130 ++++++++++++++++++++++++++++++++---
 1 file changed, 122 insertions(+), 8 deletions(-)

diff --git a/collects/mred/private/gdi.ss b/collects/mred/private/gdi.ss
index f9dd070ced..ec3aeb96e4 100644
--- a/collects/mred/private/gdi.ss
+++ b/collects/mred/private/gdi.ss
@@ -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
-	(check-top-level-parent/false '(constructor post-script-dc) parent)
-	(as-entry
-	 (lambda ()
-	   (let ([p (and parent (mred->wx parent))])
-	     (as-exit (lambda () (super-init interactive p use-paper-bbox as-eps)))))))))
+    (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-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