Added get-current-gl-context, tests (also for make-gl-bitmap), and docs

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
+but are instead the ones useful to Racket. For example, a @tt{NSOpenGLContext}
-@tt{CGLContextObj}, and a @tt{GdkGLContext} contains a @tt{GLXcontext}.
+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"]
+}

pkgs/draw-pkgs/draw-lib/info.rkt

@@ -14,4 +14,4 @@
 
 (define pkg-authors '(mflatt))
 
-(define version "1.2")
+(define version "1.3")

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

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)))
 

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)

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%)]