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

racket/draw: Use interface contracts

Browse Source 
Also removed `defclass` based runtime checks where
appropriate.
This commit is contained in:
Asumu Takikawa 2012-07-09 15:19:35 -04:00
parent 80ca36e6ab
commit 9b46e7ab7d
7 changed files with 333 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/racket/draw.rkt
View File

@ -45,11 +45,11 @@
[pen-list% pen-list%/c] [pen-list% pen-list%/c]
[brush% brush%/c] [brush% brush%/c]
[brush-list% brush-list%/c] [brush-list% brush-list%/c]
[bitmap-dc% (and/c dc<%>/c bitmap-dc%/c)] [bitmap-dc% bitmap-dc%/c]
[post-script-dc% (and/c dc<%>/c post-script-dc%/c)] [post-script-dc% post-script-dc%/c]
[pdf-dc% (and/c dc<%>/c pdf-dc%/c)] [pdf-dc% pdf-dc%/c]
[svg-dc% (and/c dc<%>/c svg-dc%/c)] [svg-dc% svg-dc%/c]
[record-dc% (and/c dc<%>/c record-dc%/c)] [record-dc% record-dc%/c]
[linear-gradient% linear-gradient%/c] [linear-gradient% linear-gradient%/c]
[radial-gradient% radial-gradient%/c] [radial-gradient% radial-gradient%/c]
[region% region%/c] [region% region%/c]

29
collects/racket/draw/private/color.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
"syntax.rkt") racket/contract/base
(except-in "syntax.rkt" real-in integer-in))
(provide color% (provide color%
make-color make-color
@ -16,7 +17,8 @@
r g b a r g b a
set-immutable) set-immutable)
(defclass color% object% (define color%
(class object%
(field [r 0] (field [r 0]
[g 0] [g 0]
[b 0] [b 0]
@ -52,10 +54,10 @@
(set! a (exact->inexact _a))] (set! a (exact->inexact _a))]
(init-name 'color%)) (init-name 'color%))
(def/public (red) r) (define/public (red) r)
(def/public (green) g) (define/public (green) g)
(def/public (blue) b) (define/public (blue) b)
(def/public (alpha) a) (define/public (alpha) a)
(define/public (set rr rg rb [ra 1.0]) (define/public (set rr rg rb [ra 1.0])
(if immutable? (if immutable?
@ -74,7 +76,7 @@
(if immutable? (if immutable?
(error (method-name 'color% 'copy-from) "object is immutable") (error (method-name 'color% 'copy-from) "object is immutable")
(begin (set (color-red c) (color-green c) (color-blue c) (color-alpha c)) (begin (set (color-red c) (color-green c) (color-blue c) (color-alpha c))
this)))) this)))))
(define color-red (class-field-accessor color% r)) (define color-red (class-field-accessor color% r))
(define color-green (class-field-accessor color% g)) (define color-green (class-field-accessor color% g))
@ -99,11 +101,14 @@
(define color-objects (make-hash)) (define color-objects (make-hash))
(define color-database<%> (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<%>) (define color-database%
(class* object% (color-database<%>)
(super-new) (super-new)
(def/public (find-color [string? name]) (define/public (find-color name)
(let ([name (string-downcase name)]) (let ([name (string-downcase name)])
(or (hash-ref color-objects name #f) (or (hash-ref color-objects name #f)
(let ([v (hash-ref colors (string-foldcase name) #f)]) (let ([v (hash-ref colors (string-foldcase name) #f)])
@ -114,8 +119,8 @@
(hash-set! color-objects name c) (hash-set! color-objects name c)
c) c)
#f))))) #f)))))
(def/public (get-names) (define/public (get-names)
(sort (hash-map colors (lambda (k v) k)) string<?))) (sort (hash-map colors (lambda (k v) k)) string<?))))
(define the-color-database (new color-database%)) (define the-color-database (new color-database%))

152
collects/racket/draw/private/contract.rkt
View File

@ -45,6 +45,13 @@
'xor-dot 'xor-long-dash 'xor-short-dash 'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-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 (define transformation-vector/c
(vector/c (vector/c real? real? real? real? real? real?) (vector/c (vector/c real? real? real? real? real? real?)
real? real? real? real? real?)) real? real? real? real? real?))
@ -79,151 +86,6 @@
#:immutable? any/c) #:immutable? any/c)
(is-a?/c pen%))) (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 (define color%/c
(class/c (class/c
(alpha (->m (real-in 0 1))) (alpha (->m (real-in 0 1)))

241
collects/racket/draw/private/dc-intf.rkt
View File

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

47
collects/racket/draw/private/font-dir.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
"syntax.rkt" racket/contract/base
"font-syms.rkt") "font-syms.rkt")
(provide font-name-directory<%> (provide font-name-directory<%>
@ -26,25 +26,23 @@
'(default decorative roman script '(default decorative roman script
swiss modern symbol system)) swiss modern symbol system))
(def/public (find-family-default-font-id [family-symbol? family]) (define/public (find-family-default-font-id family)
(intern family)) (intern family))
(def/public (find-or-create-font-id [string? name] (define/public (find-or-create-font-id name family)
[family-symbol? family])
(intern (cons 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)]) (let ([v (hash-ref reverse-table id #f)])
(and v (pair? v) (car v)))) (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)]) (let ([v (hash-ref reverse-table id #f)])
(or (and (pair? v) (cdr v)) (or (and (pair? v) (cdr v))
(and (symbol? v) v) (and (symbol? v) v)
'default))) 'default)))
(def/public (get-font-id [string? name] (define/public (get-font-id name family)
[family-symbol? family])
(hash-ref table (cons string family) 0)) (hash-ref table (cons string family) 0))
(define/private (default-font s) (define/private (default-font s)
@ -69,9 +67,7 @@
[(macosx) "Lucida Grande"] [(macosx) "Lucida Grande"]
[else "Sans"])])) [else "Sans"])]))
(def/public (get-post-script-name [exact-integer? id] (define/public (get-post-script-name id w s)
[weight-symbol? w]
[style-symbol? s])
(let ([s (or (hash-ref ps-table (list id w s) #f) (let ([s (or (hash-ref ps-table (list id w s) #f)
(hash-ref reverse-table id #f))]) (hash-ref reverse-table id #f))])
(cond (cond
@ -79,9 +75,7 @@
[(symbol? s) (default-font s)] [(symbol? s) (default-font s)]
[else "Serif"]))) [else "Serif"])))
(def/public (get-screen-name [exact-integer? id] (define/public (get-screen-name id w s)
[weight-symbol? w]
[style-symbol? s])
(let ([s (or (hash-ref screen-table (list id w s) #f) (let ([s (or (hash-ref screen-table (list id w s) #f)
(hash-ref reverse-table id #f))]) (hash-ref reverse-table id #f))])
(cond (cond
@ -89,22 +83,29 @@
[(symbol? s) (default-font s)] [(symbol? s) (default-font s)]
[else "Serif"]))) [else "Serif"])))
(def/public (set-post-script-name [exact-integer? id] (define/public (set-post-script-name id w s name)
[weight-symbol? w]
[style-symbol? s]
[string? name])
(hash-set! ps-table (list id w s) name)) (hash-set! ps-table (list id w s) name))
(def/public (set-screen-name [exact-integer? id] (define/public (set-screen-name id w s name)
[weight-symbol? w]
[style-symbol? s]
[string? name])
(hash-set! screen-table (list id w s) name)) (hash-set! screen-table (list id w s) name))
(super-new))) (super-new)))
(define font-name-directory<%> (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%)) (define the-font-name-directory (new font-name-directory%))

17
collects/racket/draw/private/font-syms.rkt
View File

@ -1,7 +1,12 @@
#lang racket/base #lang racket/base
;; font utilities for contracts
(require racket/contract/base)
(provide family-symbol? style-symbol? weight-symbol? (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) (define (family-symbol? s)
(memq s '(default decorative roman script (memq s '(default decorative roman script
@ -18,3 +23,13 @@
(define (hinting-symbol? s) (define (hinting-symbol? s)
(memq s '(aligned unaligned))) (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))

20
collects/racket/draw/private/gl-context.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
"syntax.rkt") racket/contract/base)
(provide gl-context% (provide gl-context%
gl-context<%> gl-context<%>
@ -12,10 +12,6 @@
do-call-as-current do-call-as-current
do-swap-buffers) do-swap-buffers)
(define (procedure-arity-0? v)
(and (procedure? v)
(procedure-arity-includes? v 0)))
(define lock-ch (make-channel)) (define lock-ch (make-channel))
(define lock-holder-ch (make-channel)) (define lock-holder-ch (make-channel))
(define (lock-manager) (define (lock-manager)
@ -41,8 +37,8 @@
(define manager-t (thread/suspend-to-kill lock-manager)) (define manager-t (thread/suspend-to-kill lock-manager))
;; Implemented by subclasses: ;; Implemented by subclasses:
(defclass gl-context% object% (define gl-context%
(class object%
(define/private (with-gl-lock t) (define/private (with-gl-lock t)
(thread-resume manager-t (current-thread)) (thread-resume manager-t (current-thread))
(if (eq? (current-thread) (channel-get lock-holder-ch)) (if (eq? (current-thread) (channel-get lock-holder-ch))
@ -55,7 +51,7 @@
(lambda () (lambda ()
(channel-put ch #t)))))) (channel-put ch #t))))))
(def/public (call-as-current [procedure-arity-0? t]) (define/public (call-as-current t)
(with-gl-lock (with-gl-lock
(lambda () (lambda ()
(do-call-as-current t)))) (do-call-as-current t))))
@ -70,6 +66,10 @@
(define/public (do-call-as-current t) (t)) (define/public (do-call-as-current t) (t))
(define/public (do-swap-buffers t) (void)) (define/public (do-swap-buffers t) (void))
(super-new)) (super-new)))
(define gl-context<%> (class->interface gl-context%)) (define gl-context<%>
(interface ()
[call-as-current (->*m [(-> any)] [evt? any/c] any)]
[ok? (->m boolean?)]
[swap-buffers (->m any)]))