From 9b46e7ab7db815d7a91237c2a69fe15ce4cfc89f Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 9 Jul 2012 15:19:35 -0400 Subject: [PATCH] racket/draw: Use interface contracts Also removed `defclass` based runtime checks where appropriate. --- collects/racket/draw.rkt | 10 +- collects/racket/draw/private/color.rkt | 149 ++++++------ collects/racket/draw/private/contract.rkt | 152 +----------- collects/racket/draw/private/dc-intf.rkt | 241 ++++++++++++++------ collects/racket/draw/private/font-dir.rkt | 47 ++-- collects/racket/draw/private/font-syms.rkt | 17 +- collects/racket/draw/private/gl-context.rkt | 64 +++--- 7 files changed, 333 insertions(+), 347 deletions(-) diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index 1d6cdbdb08..cadf62203c 100644 --- 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] diff --git a/collects/racket/draw/private/color.rkt b/collects/racket/draw/private/color.rkt index 3c327bb18e..59b31ff3d9 100644 --- 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) + (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/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))) diff --git a/collects/racket/draw/private/dc-intf.rkt b/collects/racket/draw/private/dc-intf.rkt index 0f053c9cf0..b3afd790bf 100644 --- 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?)])) diff --git a/collects/racket/draw/private/font-dir.rkt b/collects/racket/draw/private/font-dir.rkt index cb7c6707f7..958e0df3f3 100644 --- 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%)) diff --git a/collects/racket/draw/private/font-syms.rkt b/collects/racket/draw/private/font-syms.rkt index 75c5e86b12..5648aa5f6d 100644 --- 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)) + diff --git a/collects/racket/draw/private/gl-context.rkt b/collects/racket/draw/private/gl-context.rkt index 0daf47a917..749f5e86e1 100644 --- 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)]))