52 lines
1.3 KiB
Racket
52 lines
1.3 KiB
Racket
#lang racket/gui
|
|
|
|
(require sgl/gl
|
|
rackunit)
|
|
|
|
;; Test 1: Make sure creating multiple GL bitmaps doesn't crash
|
|
|
|
(for ([_ (in-range 5)])
|
|
(define bm (make-gl-bitmap 32 32 (new gl-config%)))
|
|
(send (send (make-object bitmap-dc% bm) get-gl-context)
|
|
call-as-current
|
|
(λ ()
|
|
(glClearColor 0.0 0.0 0.0 0.0)
|
|
(glClear GL_COLOR_BUFFER_BIT)
|
|
(glBegin GL_TRIANGLES)
|
|
(glVertex2f -1.0 -1.0)
|
|
(glVertex2f +1.0 -1.0)
|
|
(glVertex2f -1.0 +1.0)
|
|
(glEnd)
|
|
(glFinish)))
|
|
(set! bm #f)
|
|
(collect-garbage))
|
|
|
|
;; Test 2: make sure `get-current-gl-context` returns non-#f only within the dynamic extent of
|
|
;; `call-as-current` - in particular, that it returns #f on other threads
|
|
|
|
(define bm (make-gl-bitmap 32 32 (new gl-config%)))
|
|
(define ctxt (send (make-object bitmap-dc% bm) get-gl-context))
|
|
|
|
(define outside-context #f)
|
|
(define inside-context #f)
|
|
|
|
(define ch (make-channel))
|
|
|
|
(define th
|
|
(thread
|
|
(λ ()
|
|
(channel-get ch)
|
|
(set! outside-context (get-current-gl-context))
|
|
(channel-put ch #t))))
|
|
|
|
(send ctxt call-as-current
|
|
(λ ()
|
|
(set! inside-context (get-current-gl-context))
|
|
(channel-put ch #t)
|
|
(channel-get ch)
|
|
(void)))
|
|
|
|
(check-false (get-current-gl-context))
|
|
(check-false outside-context)
|
|
(check-eq? inside-context ctxt)
|