racket/draw: Use interface contracts

Also removed `defclass` based runtime checks where appropriate.
2012-07-09 15:19:35 -04:00 · 2012-07-09 15:19:35 -04:00 · 9b46e7ab7d
commit 9b46e7ab7d
parent 80ca36e6ab
7 changed files with 333 additions and 347 deletions
--- a/collects/racket/draw.rkt
+++ b/collects/racket/draw.rkt
@ -45,11 +45,11 @@
                  [pen-list%         pen-list%/c]
                  [brush%            brush%/c]
                  [brush-list%       brush-list%/c]
-                  [bitmap-dc%        (and/c dc<%>/c bitmap-dc%/c)]
-                  [post-script-dc%   (and/c dc<%>/c post-script-dc%/c)]
-                  [pdf-dc%           (and/c dc<%>/c pdf-dc%/c)]
-                  [svg-dc%           (and/c dc<%>/c svg-dc%/c)]
-                  [record-dc%        (and/c dc<%>/c record-dc%/c)]
+                  [bitmap-dc%        bitmap-dc%/c]
+                  [post-script-dc%   post-script-dc%/c]
+                  [pdf-dc%           pdf-dc%/c]
+                  [svg-dc%           svg-dc%/c]
+                  [record-dc%        record-dc%/c]
                  [linear-gradient%  linear-gradient%/c]
                  [radial-gradient%  radial-gradient%/c]
                  [region%           region%/c]
--- a/collects/racket/draw/private/color.rkt
+++ b/collects/racket/draw/private/color.rkt
@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
-         "syntax.rkt")
+         racket/contract/base
+         (except-in "syntax.rkt" real-in integer-in))

 (provide color%
         make-color
@ -16,65 +17,66 @@
  r g b a
  set-immutable)

-(defclass color% object%
-  (field [r 0]
-         [g 0]
-         [b 0]
-         [a 1.0])
-  (define immutable? #f)
+(define color%
+  (class object%
+    (field [r 0]
+           [g 0]
+           [b 0]
+           [a 1.0])
+    (define immutable? #f)

-  (init-rest args)
-  (super-new)
-  (case-args 
-   args
-   [() (void)]
-   [([string? s])
-    (let ([v (hash-ref colors (string-foldcase s) #f)])
-      (if v
+    (init-rest args)
+    (super-new)
+    (case-args
+     args
+     [() (void)]
+     [([string? s])
+      (let ([v (hash-ref colors (string-foldcase s) #f)])
+        (if v
+            (begin
+              (set! r (vector-ref v 0))
+              (set! g (vector-ref v 1))
+              (set! b (vector-ref v 2)))
+            (error 'color% "unknown color name: ~e" (car args))))]
+     [([color% c])
+      (set! r (color-red c))
+      (set! g (color-green c))
+      (set! b (color-blue c))
+      (set! a (color-alpha c))]
+     [([byte? _r] [byte? _g] [byte? _b])
+      (set! r _r)
+      (set! g _g)
+      (set! b _b)]
+     [([byte? _r] [byte? _g] [byte? _b] [(real-in 0 1) _a])
+      (set! r _r)
+      (set! g _g)
+      (set! b _b)
+      (set! a (exact->inexact _a))]
+     (init-name 'color%))
+
+    (define/public (red) r)
+    (define/public (green) g)
+    (define/public (blue) b)
+    (define/public (alpha) a)
+
+    (define/public (set rr rg rb [ra 1.0])
+      (if immutable?
+          (error (method-name 'color% 'set) "object is immutable")
          (begin
-            (set! r (vector-ref v 0))
-            (set! g (vector-ref v 1))
-            (set! b (vector-ref v 2)))
-          (error 'color% "unknown color name: ~e" (car args))))]
-   [([color% c])
-    (set! r (color-red c))
-    (set! g (color-green c))
-    (set! b (color-blue c))
-    (set! a (color-alpha c))]
-   [([byte? _r] [byte? _g] [byte? _b])
-    (set! r _r)
-    (set! g _g)
-    (set! b _b)]
-   [([byte? _r] [byte? _g] [byte? _b] [(real-in 0 1) _a])
-    (set! r _r)
-    (set! g _g)
-    (set! b _b)
-    (set! a (exact->inexact _a))]
-   (init-name 'color%))
+            (set! r rr)
+            (set! g rg)
+            (set! b rb)
+            (set! a (exact->inexact ra)))))

-  (def/public (red) r)
-  (def/public (green) g)
-  (def/public (blue) b)
-  (def/public (alpha) a)
+    (define/public (ok?) #t)
+    (define/public (is-immutable?) immutable?)
+    (define/public (set-immutable) (set! immutable? #t))

-  (define/public (set rr rg rb [ra 1.0])
-    (if immutable?
-        (error (method-name 'color% 'set) "object is immutable")
-        (begin
-          (set! r rr)
-          (set! g rg)
-          (set! b rb)
-          (set! a (exact->inexact ra)))))
-
-  (define/public (ok?) #t)
-  (define/public (is-immutable?) immutable?)
-  (define/public (set-immutable) (set! immutable? #t))
-  
-  (define/public (copy-from c)
-    (if immutable?
-        (error (method-name 'color% 'copy-from) "object is immutable")
-        (begin (set (color-red c) (color-green c) (color-blue c) (color-alpha c))
-               this))))
+    (define/public (copy-from c)
+      (if immutable?
+          (error (method-name 'color% 'copy-from) "object is immutable")
+          (begin (set (color-red c) (color-green c) (color-blue c) (color-alpha c))
+                 this)))))

 (define color-red (class-field-accessor color% r))
 (define color-green (class-field-accessor color% g))
@ -99,23 +101,26 @@
 (define color-objects (make-hash))

 (define color-database<%>
-  (interface () find-color get-names))
+  (interface ()
+    [find-color (->m string? (or/c (is-a?/c color%) #f))]
+    [get-names (->m (listof string?))]))

-(defclass* color-database% object% (color-database<%>)
-  (super-new)
-  (def/public (find-color [string? name])
-    (let ([name (string-downcase name)])
-      (or (hash-ref color-objects name #f)
-          (let ([v (hash-ref colors (string-foldcase name) #f)])
-            (if v
-                (let ([c (new color%)])
-                  (send c set (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))
-                  (send c set-immutable)
-                  (hash-set! color-objects name c)
-                  c)
-                #f)))))
-  (def/public (get-names)
-    (sort (hash-map colors (lambda (k v) k)) string<?)))
+(define color-database%
+  (class* object% (color-database<%>)
+    (super-new)
+    (define/public (find-color name)
+      (let ([name (string-downcase name)])
+        (or (hash-ref color-objects name #f)
+            (let ([v (hash-ref colors (string-foldcase name) #f)])
+              (if v
+                  (let ([c (new color%)])
+                    (send c set (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))
+                    (send c set-immutable)
+                    (hash-set! color-objects name c)
+                    c)
+                  #f)))))
+    (define/public (get-names)
+      (sort (hash-map colors (lambda (k v) k)) string<?))))

 (define the-color-database (new color-database%))

--- a/collects/racket/draw/private/contract.rkt
+++ b/collects/racket/draw/private/contract.rkt
@ -45,6 +45,13 @@
        'xor-dot 'xor-long-dash 'xor-short-dash
        'xor-dot-dash))

+(define font-family/c
+  (or/c 'default 'decorative 'roman 'script
+        'swiss 'modern 'symbol 'system))
+
+(define font-weight/c (or/c 'normal 'bold 'light))
+(define font-style/c  (or/c 'normal 'italic 'slant))
+
 (define transformation-vector/c
  (vector/c (vector/c real? real? real? real? real? real?)
            real? real? real? real? real?))
@ -79,151 +86,6 @@
        #:immutable? any/c)
       (is-a?/c pen%)))

-(define dc<%>/c
-  (class/c
-    [cache-font-metrics-key (->m exact-integer?)]
-    [clear (->m void?)]
-    [copy (->m real? real?
-               (and/c real? (not/c negative?))
-               (and/c real? (not/c negative?))
-               real? real?
-               void?)]
-    [draw-arc (->m real? real?
-                   (and/c real? (not/c negative?))
-                   (and/c real? (not/c negative?))
-                   real? real?
-                   void?)]
-    [draw-bitmap (->*m ((is-a?/c bitmap%)
-                        real? real?)
-                       ((or/c 'solid 'opaque 'xor)
-                        (is-a?/c color%)
-                        (or/c (is-a?/c bitmap%) #f))
-                       boolean?)]
-    [draw-bitmap-section (->*m ((is-a?/c bitmap%)
-                                real? real?
-                                real? real?
-                                (and/c real? (not/c negative?))
-                                (and/c real? (not/c negative?)))
-                               ((or/c 'solid 'opaque 'xor)
-                                (is-a?/c color%)
-                                (or/c (is-a?/c bitmap%) #f))
-                               boolean?)]
-    [draw-ellipse (->m real? real?
-                       (and/c real? (not/c negative?))
-                       (and/c real? (not/c negative?))
-                       void?)]
-    [draw-line (->m real? real?
-                    real? real?
-                    void?)]
-    [draw-lines (->*m ((or/c (listof (is-a?/c point%))
-                             (listof (cons/c real? real?))))
-                      (real? real?)
-                      void?)]
-    [draw-path (->*m ((is-a?/c dc-path%))
-                     (real? real? (or/c 'odd-even 'winding))
-                     void?)]
-    [draw-point (->m real? real? void?)]
-    [draw-polygon (->*m ((or/c (listof (is-a?/c point%))
-                               (listof (cons/c real? real?))))
-                        (real? real? (or/c 'odd-even 'winding))
-                        void?)]
-    [draw-rectangle (->m real? real?
-                         (and/c real? (not/c negative?))
-                         (and/c real? (not/c negative?))
-                         void?)]
-    [draw-rounded-rectangle (->*m (real? real?
-                                         (and/c real? (not/c negative?))
-                                         (and/c real? (not/c negative?)))
-                                  (real?)
-                                  void?)]
-    [draw-spline (->m real? real? real?
-                      real? real? real?
-                      void?)]
-    [draw-text (->*m (string? real? real?)
-                     (any/c exact-nonnegative-integer? real?)
-                     void?)]
-    [end-doc (->m void?)]
-    [end-page (->m void?)]
-    [erase (->m void?)]
-    [flush (->m void?)]
-    [get-alpha (->m real?)]
-    [get-background (->m (is-a?/c color%))]
-    [get-brush (->m (is-a?/c brush%))]
-    [get-char-height (->m (and/c real? (not/c negative?)))]
-    [get-char-width (->m (and/c real? (not/c negative?)))]
-    [get-clipping-region (->m (or/c (is-a?/c region%) #f))]
-    [get-device-scale (->m (values (and/c real? (not/c negative?))
-                                   (and/c real? (not/c negative?))))]
-    [get-font (->m (is-a?/c font%))]
-    [get-gl-context (->m (or/c (is-a?/c gl-context<%>) #f))]
-    [get-initial-matrix (->m (vector/c real? real? real?
-                                       real? real? real?))]
-    [get-origin (->m (values real? real?))]
-    [get-pen (->m (is-a?/c pen%))]
-    [get-rotation (->m real?)]
-    [get-scale (->m (values real? real?))]
-    [get-size (->m (values (and/c real? (not/c negative?))
-                           (and/c real? (not/c negative?))))]
-    [get-smoothing (->m (or/c 'unsmoothed 'smoothed 'aligned))]
-    [get-text-background (->m (is-a?/c color%))]
-    [get-text-extent (->*m (string?)
-                           ((or/c (is-a?/c font%) #f)
-                            any/c
-                            exact-nonnegative-integer?)
-                           (values
-                             (and/c real? (not/c negative?))
-                             (and/c real? (not/c negative?))
-                             (and/c real? (not/c negative?))
-                             (and/c real? (not/c negative?))))]
-    [get-text-foreground (->m (is-a?/c color%))]
-    [get-text-mode (->m (or/c 'solid 'transparent))]
-    [get-transformation (->m (vector/c (vector/c real? real? real?
-                                                 real? real? real?)
-                                       real? real? real? real? real?))]
-    [glyph-exists? (->m char? boolean?)]
-    [ok? (->m boolean?)]
-    [resume-flush (->m void?)]
-    [rotate (->m real? void?)]
-    [scale (->m real? real? void?)]
-    [set-alpha (->m real? void?)]
-    [set-background (->m (or/c (is-a?/c color%) string?) void?)]
-    [set-brush (case->m (-> (is-a?/c brush%) void?)
-                        (-> (or/c (is-a?/c color%) string?)
-                            brush-style/c
-                            void?))]
-    [set-clipping-rect (->m real? real?
-                            (and/c real? (not/c negative?))
-                            (and/c real? (not/c negative?))
-                            void?)]
-    [set-clipping-region (->m (or/c (is-a?/c region%) #f) void?)]
-    [set-font (->m (is-a?/c font%) void?)]
-    [set-initial-matrix (->m (vector/c real? real? real?
-                                       real? real? real?)
-                             void?)]
-    [set-origin (->m real? real? void?)]
-    [set-pen (case->m (-> (is-a?/c pen%) void?)
-                      (-> (or/c (is-a?/c color%) string?)
-                          real?
-                          pen-style/c
-                          void?))]
-    [set-rotation (->m real? void?)]
-    [set-scale (->m real? real? void?)]
-    [set-smoothing (->m (or/c 'unsmoothed 'smoothed 'aligned) void?)]
-    [set-text-background (->m (or/c (is-a?/c color%) string?) void?)]
-    [set-text-foreground (->m (or/c (is-a?/c color%) string?) void?)]
-    [set-text-mode (->m (or/c 'solid 'transparent) void?)]
-    [set-transformation (->m (vector/c (vector/c real? real? real?
-                                                 real? real? real?)
-                                       real? real? real? real? real?)
-                             void?)]
-    [start-doc (->m string? void?)]
-    [start-page (->m void?)]
-    [suspend-flush (->m void?)]
-    [transform (->m (vector/c real? real? real? real? real? real?)
-                    void?)]
-    [translate (->m real? real? void?)]
-    [try-color (->m (is-a?/c color%) (is-a?/c color%) void?)]))
-
 (define color%/c
  (class/c
    (alpha (->m (real-in 0 1)))
--- a/collects/racket/draw/private/dc-intf.rkt
+++ b/collects/racket/draw/private/dc-intf.rkt
@ -1,75 +1,178 @@
 #lang racket/base
-(require racket/class)
+
+;; drawing context interface
+
+(require "bitmap.rkt"
+         "brush.rkt"
+         "color.rkt"
+         "dc-path.rkt"
+         "font.rkt"
+         "gl-context.rkt"
+         "pen.rkt"
+         "point.rkt"
+         racket/class
+         racket/contract)

 (provide dc<%>)

+;; dummy value to avoid cycles via "region.rkt"
+(define region% object%)
+
+;; repeated here from "contract.rkt" to avoid cycles
+(define pen-style/c
+  (or/c 'transparent 'solid 'xor 'hilite
+        'dot 'long-dash 'short-dash 'dot-dash
+        'xor-dot 'xor-long-dash 'xor-short-dash
+        'xor-dot-dash))
+
+(define brush-style/c
+  (or/c 'transparent 'solid 'opaque
+        'xor 'hilite 'panel
+        'bdiagonal-hatch 'crossdiag-hatch
+        'fdiagonal-hatch 'cross-hatch
+        'horizontal-hatch 'vertical-hatch))
+
 (define dc<%>
  (interface ()
-    cache-font-metrics-key
-    clear
-    copy
-    draw-arc
-    draw-bitmap
-    draw-bitmap-section
-    draw-ellipse
-    draw-line
-    draw-lines
-    draw-path
-    draw-point
-    draw-polygon
-    draw-rectangle
-    draw-rounded-rectangle
-    draw-spline
-    draw-text
-    end-doc
-    end-page
-    erase
-    flush
-    get-alpha
-    get-background
-    get-brush
-    get-char-height
-    get-char-width
-    get-clipping-region
-    get-device-scale
-    get-font
-    get-gl-context
-    get-initial-matrix
-    get-origin
-    get-pen
-    get-rotation
-    get-scale
-    get-size
-    get-smoothing
-    get-text-background
-    get-text-extent
-    get-text-foreground
-    get-text-mode
-    get-transformation
-    glyph-exists?
-    ok?
-    resume-flush
-    rotate
-    scale
-    set-alpha
-    set-background
-    set-brush
-    set-clipping-rect
-    set-clipping-region
-    set-font
-    set-initial-matrix
-    set-origin
-    set-pen
-    set-rotation
-    set-scale
-    set-smoothing
-    set-text-background
-    set-text-foreground
-    set-text-mode
-    set-transformation
-    start-doc
-    start-page
-    suspend-flush
-    transform
-    translate
-    try-color))
+    [cache-font-metrics-key (->m exact-integer?)]
+    [clear (->m void?)]
+    [copy (->m real? real?
+               (and/c real? (not/c negative?))
+               (and/c real? (not/c negative?))
+               real? real?
+               void?)]
+    [draw-arc (->m real? real?
+                   (and/c real? (not/c negative?))
+                   (and/c real? (not/c negative?))
+                   real? real?
+                   void?)]
+    [draw-bitmap (->*m ((is-a?/c bitmap%)
+                        real? real?)
+                       ((or/c 'solid 'opaque 'xor)
+                        (is-a?/c color%)
+                        (or/c (is-a?/c bitmap%) #f))
+                       boolean?)]
+    [draw-bitmap-section (->*m ((is-a?/c bitmap%)
+                                real? real?
+                                real? real?
+                                (and/c real? (not/c negative?))
+                                (and/c real? (not/c negative?)))
+                               ((or/c 'solid 'opaque 'xor)
+                                (is-a?/c color%)
+                                (or/c (is-a?/c bitmap%) #f))
+                               boolean?)]
+    [draw-ellipse (->m real? real?
+                       (and/c real? (not/c negative?))
+                       (and/c real? (not/c negative?))
+                       void?)]
+    [draw-line (->m real? real?
+                    real? real?
+                    void?)]
+    [draw-lines (->*m ((or/c (listof (is-a?/c point%))
+                             (listof (cons/c real? real?))))
+                      (real? real?)
+                      void?)]
+    [draw-path (->*m ((is-a?/c dc-path%))
+                     (real? real? (or/c 'odd-even 'winding))
+                     void?)]
+    [draw-point (->m real? real? void?)]
+    [draw-polygon (->*m ((or/c (listof (is-a?/c point%))
+                               (listof (cons/c real? real?))))
+                        (real? real? (or/c 'odd-even 'winding))
+                        void?)]
+    [draw-rectangle (->m real? real?
+                         (and/c real? (not/c negative?))
+                         (and/c real? (not/c negative?))
+                         void?)]
+    [draw-rounded-rectangle (->*m (real? real?
+                                         (and/c real? (not/c negative?))
+                                         (and/c real? (not/c negative?)))
+                                  (real?)
+                                  void?)]
+    [draw-spline (->m real? real? real?
+                      real? real? real?
+                      void?)]
+    [draw-text (->*m (string? real? real?)
+                     (any/c exact-nonnegative-integer? real?)
+                     void?)]
+    [end-doc (->m void?)]
+    [end-page (->m void?)]
+    [erase (->m void?)]
+    [flush (->m void?)]
+    [get-alpha (->m real?)]
+    [get-background (->m (is-a?/c color%))]
+    [get-brush (->m (is-a?/c brush%))]
+    [get-char-height (->m (and/c real? (not/c negative?)))]
+    [get-char-width (->m (and/c real? (not/c negative?)))]
+    [get-clipping-region (->m (or/c (is-a?/c region%) #f))]
+    [get-device-scale (->m (values (and/c real? (not/c negative?))
+                                   (and/c real? (not/c negative?))))]
+    [get-font (->m (is-a?/c font%))]
+    [get-gl-context (->m (or/c (is-a?/c gl-context<%>) #f))]
+    [get-initial-matrix (->m (vector/c real? real? real?
+                                       real? real? real?))]
+    [get-origin (->m (values real? real?))]
+    [get-pen (->m (is-a?/c pen%))]
+    [get-rotation (->m real?)]
+    [get-scale (->m (values real? real?))]
+    [get-size (->m (values (and/c real? (not/c negative?))
+                           (and/c real? (not/c negative?))))]
+    [get-smoothing (->m (or/c 'unsmoothed 'smoothed 'aligned))]
+    [get-text-background (->m (is-a?/c color%))]
+    [get-text-extent (->*m (string?)
+                           ((or/c (is-a?/c font%) #f)
+                            any/c
+                            exact-nonnegative-integer?)
+                           (values
+                             (and/c real? (not/c negative?))
+                             (and/c real? (not/c negative?))
+                             (and/c real? (not/c negative?))
+                             (and/c real? (not/c negative?))))]
+    [get-text-foreground (->m (is-a?/c color%))]
+    [get-text-mode (->m (or/c 'solid 'transparent))]
+    [get-transformation (->m (vector/c (vector/c real? real? real?
+                                                 real? real? real?)
+                                       real? real? real? real? real?))]
+    [glyph-exists? (->m char? boolean?)]
+    [ok? (->m boolean?)]
+    [resume-flush (->m void?)]
+    [rotate (->m real? void?)]
+    [scale (->m real? real? void?)]
+    [set-alpha (->m real? void?)]
+    [set-background (->m (or/c (is-a?/c color%) string?) void?)]
+    [set-brush (case->m (-> (is-a?/c brush%) void?)
+                        (-> (or/c (is-a?/c color%) string?)
+                            brush-style/c
+                            void?))]
+    [set-clipping-rect (->m real? real?
+                            (and/c real? (not/c negative?))
+                            (and/c real? (not/c negative?))
+                            void?)]
+    [set-clipping-region (->m (or/c (is-a?/c region%) #f) void?)]
+    [set-font (->m (is-a?/c font%) void?)]
+    [set-initial-matrix (->m (vector/c real? real? real?
+                                       real? real? real?)
+                             void?)]
+    [set-origin (->m real? real? void?)]
+    [set-pen (case->m (-> (is-a?/c pen%) void?)
+                      (-> (or/c (is-a?/c color%) string?)
+                          real?
+                          pen-style/c
+                          void?))]
+    [set-rotation (->m real? void?)]
+    [set-scale (->m real? real? void?)]
+    [set-smoothing (->m (or/c 'unsmoothed 'smoothed 'aligned) void?)]
+    [set-text-background (->m (or/c (is-a?/c color%) string?) void?)]
+    [set-text-foreground (->m (or/c (is-a?/c color%) string?) void?)]
+    [set-text-mode (->m (or/c 'solid 'transparent) void?)]
+    [set-transformation (->m (vector/c (vector/c real? real? real?
+                                                 real? real? real?)
+                                       real? real? real? real? real?)
+                             void?)]
+    [start-doc (->m string? void?)]
+    [start-page (->m void?)]
+    [suspend-flush (->m void?)]
+    [transform (->m (vector/c real? real? real? real? real? real?)
+                    void?)]
+    [translate (->m real? real? void?)]
+    [try-color (->m (is-a?/c color%) (is-a?/c color%) void?)]))
--- a/collects/racket/draw/private/font-dir.rkt
+++ b/collects/racket/draw/private/font-dir.rkt
@ -1,6 +1,6 @@
 #lang racket/base
 (require racket/class
-         "syntax.rkt"
+         racket/contract/base
         "font-syms.rkt")

 (provide font-name-directory<%>
@ -26,25 +26,23 @@
              '(default decorative roman script
                 swiss modern symbol system))

-    (def/public (find-family-default-font-id [family-symbol? family])
+    (define/public (find-family-default-font-id family)
      (intern family))

-    (def/public (find-or-create-font-id [string? name]
-                                        [family-symbol? family])
+    (define/public (find-or-create-font-id name family)
      (intern (cons name family)))

-    (def/public (get-face-name [exact-integer? id])
+    (define/public (get-face-name id)
      (let ([v (hash-ref reverse-table id #f)])
        (and v (pair? v) (car v))))
    
-    (def/public (get-family [exact-integer? id])
+    (define/public (get-family id)
      (let ([v (hash-ref reverse-table id #f)])
        (or (and (pair? v) (cdr v))
            (and (symbol? v) v)
            'default)))

-    (def/public (get-font-id [string? name]
-                             [family-symbol? family])
+    (define/public (get-font-id name family)
      (hash-ref table (cons string family) 0))

    (define/private (default-font s)
@ -69,9 +67,7 @@
                [(macosx) "Lucida Grande"]
                [else "Sans"])]))

-    (def/public (get-post-script-name [exact-integer? id]
-                                      [weight-symbol? w]
-                                      [style-symbol? s])
+    (define/public (get-post-script-name id w s)
      (let ([s (or (hash-ref ps-table (list id w s) #f)
                   (hash-ref reverse-table id #f))])
        (cond
@ -79,9 +75,7 @@
         [(symbol? s) (default-font s)]
         [else "Serif"])))

-    (def/public (get-screen-name [exact-integer? id]
-                                 [weight-symbol? w]
-                                 [style-symbol? s])
+    (define/public (get-screen-name id w s)
      (let ([s (or (hash-ref screen-table (list id w s) #f)
                   (hash-ref reverse-table id #f))])
        (cond
@ -89,22 +83,29 @@
         [(symbol? s) (default-font s)]
         [else "Serif"])))

-    (def/public (set-post-script-name [exact-integer? id]
-                                      [weight-symbol? w]
-                                      [style-symbol? s]
-                                      [string? name])
+    (define/public (set-post-script-name id w s name)
      (hash-set! ps-table (list id w s) name))

-    (def/public (set-screen-name [exact-integer? id]
-                                 [weight-symbol? w]
-                                 [style-symbol? s]
-                                 [string? name])
+    (define/public (set-screen-name id w s name)
      (hash-set! screen-table (list id w s) name))

    (super-new)))

 (define font-name-directory<%>
-  (class->interface font-name-directory%))
+  (interface ()
+    [find-family-default-font-id (->m font-family/c exact-integer?)]
+    [fint-or-create-font-id (->m string? font-family/c exact-integer?)]
+    [get-face-name (->m exact-integer? (or/c string? #f))]
+    [get-family (->m exact-integer? font-family/c)]
+    [get-font-id (->m string? font-family/c exact-integer?)]
+    [get-post-script-name
+     (->m exact-integer? font-weight/c font-style/c (or/c string? #f))]
+    [get-screen-name
+     (->m exact-integer? font-weight/c font-style/c (or/c string? #f))]
+    [set-post-script-name
+     (->m exact-integer? font-weight/c font-style/c string? any)]
+    [set-screen-name
+     (->m exact-integer? font-weight/c font-style/c string? any)]))

 (define the-font-name-directory (new font-name-directory%))

--- a/collects/racket/draw/private/font-syms.rkt
+++ b/collects/racket/draw/private/font-syms.rkt
@ -1,7 +1,12 @@
 #lang racket/base

+;; font utilities for contracts
+
+(require racket/contract/base)
+
 (provide family-symbol? style-symbol? weight-symbol? 
-         smoothing-symbol? hinting-symbol?)
+         smoothing-symbol? hinting-symbol?
+         font-family/c font-weight/c font-style/c)

 (define (family-symbol? s)
  (memq s '(default decorative roman script
@ -18,3 +23,13 @@

 (define (hinting-symbol? s)
  (memq s '(aligned unaligned)))
+
+;; TODO: eventually once all old checks are converted to
+;;       contracts, the above can be removed
+(define font-family/c
+  (or/c 'default 'decorative 'roman 'script
+        'swiss 'modern 'symbol 'system))
+
+(define font-weight/c (or/c 'normal 'bold 'light))
+(define font-style/c  (or/c 'normal 'italic 'slant))
+
--- a/collects/racket/draw/private/gl-context.rkt
+++ b/collects/racket/draw/private/gl-context.rkt
@ -1,6 +1,6 @@
 #lang racket/base
 (require racket/class
-         "syntax.rkt")
+         racket/contract/base)

 (provide gl-context%
         gl-context<%>
@ -12,10 +12,6 @@
  do-call-as-current
  do-swap-buffers)

-(define (procedure-arity-0? v) 
-  (and (procedure? v)
-       (procedure-arity-includes? v 0)))
-
 (define lock-ch (make-channel))
 (define lock-holder-ch (make-channel))
 (define (lock-manager)
@ -41,35 +37,39 @@
 (define manager-t (thread/suspend-to-kill lock-manager))

 ;; Implemented by subclasses:
-(defclass gl-context% object%
-  
-  (define/private (with-gl-lock t)
-    (thread-resume manager-t (current-thread))
-    (if (eq? (current-thread) (channel-get lock-holder-ch))
-        (t)
-        (let ([ch (make-channel)])
-          (dynamic-wind
-              (lambda ()
-                (channel-put lock-ch (cons (current-thread) ch)))
-              t
-              (lambda ()
-                (channel-put ch #t))))))
+(define gl-context%
+  (class object%
+    (define/private (with-gl-lock t)
+      (thread-resume manager-t (current-thread))
+      (if (eq? (current-thread) (channel-get lock-holder-ch))
+          (t)
+          (let ([ch (make-channel)])
+            (dynamic-wind
+                (lambda ()
+                  (channel-put lock-ch (cons (current-thread) ch)))
+                t
+                (lambda ()
+                  (channel-put ch #t))))))

-  (def/public (call-as-current [procedure-arity-0? t])
-    (with-gl-lock
-     (lambda ()
-       (do-call-as-current t))))
-        
-  (define/public (swap-buffers)
-    (with-gl-lock
-     (lambda ()
-       (do-swap-buffers))))
+    (define/public (call-as-current t)
+      (with-gl-lock
+       (lambda ()
+         (do-call-as-current t))))

-  (define/public (ok?) #t)
+    (define/public (swap-buffers)
+      (with-gl-lock
+       (lambda ()
+         (do-swap-buffers))))

-  (define/public (do-call-as-current t) (t))
-  (define/public (do-swap-buffers t) (void))
+    (define/public (ok?) #t)

-  (super-new))
+    (define/public (do-call-as-current t) (t))
+    (define/public (do-swap-buffers t) (void))

-(define gl-context<%> (class->interface gl-context%))
+    (super-new)))
+
+(define gl-context<%>
+  (interface ()
+    [call-as-current (->*m [(-> any)] [evt? any/c] any)]
+    [ok? (->m boolean?)]
+    [swap-buffers (->m any)]))