diff --git a/pkgs/draw-pkgs/draw-doc/scribblings/draw/gl-context-intf.scrbl b/pkgs/draw-pkgs/draw-doc/scribblings/draw/gl-context-intf.scrbl index b44b4331f9..76ade64df0 100644 --- a/pkgs/draw-pkgs/draw-doc/scribblings/draw/gl-context-intf.scrbl +++ b/pkgs/draw-pkgs/draw-doc/scribblings/draw/gl-context-intf.scrbl @@ -39,7 +39,6 @@ Only one OpenGL context can be active at a time across all threads and @method[gl-context<%> call-as-current] uses a lock to serialize context selection across all threads in Racket. - @defmethod[(call-as-current [thunk (-> any)] [alternate evt? never-evt] [enable-breaks? any/c #f]) @@ -85,12 +84,12 @@ pointer represents depends on the platform: @itemize[ @item{Windows: @tt{HGLRC}} @item{Mac OS X: @tt{NSOpenGLContext}} -@item{Unix: @tt{GdkGLContext}} +@item{Unix: @tt{GLXContext}} ] Note that these values are not necessary the most ``low-level'' context objects, -but are instead the ones useful to Racket. A @tt{NSOpenGLContext} wraps a -@tt{CGLContextObj}, and a @tt{GdkGLContext} contains a @tt{GLXcontext}. +but are instead the ones useful to Racket. For example, a @tt{NSOpenGLContext} +wraps a @tt{CGLContextObj}. } @defmethod[(ok?) @@ -120,3 +119,12 @@ This method implicitly uses @method[gl-context<%> call-as-current] to a @method[gl-context<%> call-as-current] thunk. }} + +@defproc[(get-current-gl-context) gl-context<%>]{ +If within the dynamic extent of a @method[gl-context<%> call-as-current] +method call, returns the current context; otherwise returns @racket[#f]. +This is possibly most useful for caching context-dependent state or data, +such as extension strings. Create such caches using @racket[make-weak-hasheq]. + +@history[#:added "1.3"] +} diff --git a/pkgs/draw-pkgs/draw-lib/info.rkt b/pkgs/draw-pkgs/draw-lib/info.rkt index cb7a277575..7084970f93 100644 --- a/pkgs/draw-pkgs/draw-lib/info.rkt +++ b/pkgs/draw-pkgs/draw-lib/info.rkt @@ -14,4 +14,4 @@ (define pkg-authors '(mflatt)) -(define version "1.2") +(define version "1.3") diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw.rkt index 6b0b9f1513..ed7bf976af 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw.rkt @@ -34,6 +34,7 @@ get-face-list get-family-builtin-face gl-context<%> + get-current-gl-context make-bitmap make-platform-bitmap read-bitmap diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/gl-context.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/gl-context.rkt index f71ebfe794..9a80134e08 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/gl-context.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/gl-context.rkt @@ -6,7 +6,9 @@ gl-context<%> do-call-as-current - do-swap-buffers) + do-swap-buffers + + get-current-gl-context) (define-local-member-name do-call-as-current @@ -44,6 +46,9 @@ [swap-buffers (->m any)] [get-handle (->m any)])) +(define current-gl-context (make-thread-cell #f)) +(define (get-current-gl-context) (thread-cell-ref current-gl-context)) + ;; Implemented by subclasses: (define gl-context% (class* object% (gl-context<%>) @@ -58,9 +63,11 @@ (handle-evt (channel-put-evt lock-ch (vector (current-thread) this ch)) (lambda (val) (dynamic-wind - void + (lambda () + (thread-cell-set! current-gl-context this)) t (lambda () + (thread-cell-set! current-gl-context #f) (channel-put ch #t)))))) alternate-evt))) diff --git a/pkgs/gui-pkgs/gui-test/tests/gracket/gl-bitmap.rkt b/pkgs/gui-pkgs/gui-test/tests/gracket/gl-bitmap.rkt new file mode 100644 index 0000000000..3f64308cc9 --- /dev/null +++ b/pkgs/gui-pkgs/gui-test/tests/gracket/gl-bitmap.rkt @@ -0,0 +1,51 @@ +#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) diff --git a/pkgs/typed-racket-pkgs/typed-racket-more/typed/racket/draw.rkt b/pkgs/typed-racket-pkgs/typed-racket-more/typed/racket/draw.rkt index b3417a094d..6837b01ca7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-more/typed/racket/draw.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-more/typed/racket/draw.rkt @@ -10,10 +10,12 @@ racket/draw/private/color racket/draw/private/font racket/draw/private/gl-config + racket/draw/private/gl-context racket/draw/private/gradient racket/draw/private/pen racket/draw/private/region (for-syntax (only-in (rep type-rep) make-Instance)) + (only-in typed/racket/base -> U) "private/gui-types.rkt" (for-syntax (submod "private/gui-types.rkt" #%type-decl))) @@ -76,6 +78,7 @@ [the-color-database (make-Instance (parse-type #'Color-Database<%>))] [font% (parse-type #'Font%)] [font-list% (parse-type #'Font-List%)] + [get-current-gl-context (parse-type #'(-> (U #f GL-Context<%>)))] [gl-config% (parse-type #'GL-Config%)] [linear-gradient% (parse-type #'Linear-Gradient%)] [pen% (parse-type #'Pen%)]