gl-context: Fix re-entrancy of call-as-current

draw-doc/scribblings/draw/gl-context-intf.scrbl

@@ -74,6 +74,9 @@ If @racket[enable-breaks?] is true, then the method uses
  @racket[sync/enable-break] while blocking for the context-setting
  lock instead of @racket[sync].
 
+@history[#:changed "1.24" @elem{Added support for nested calls from
+          the same thread. (Previous versions were documented to
+          support nesting, but in practice it did not work correctly.)}]
 }
 
 @defmethod[(get-handle) cpointer?]{

draw-lib/info.rkt

@@ -22,7 +22,7 @@
 
 (define pkg-authors '(mflatt))
 
-(define version "1.23")
+(define version "1.24")
 
 (define license
   '(Apache-2.0 OR MIT))

draw-lib/racket/draw/private/gl-context.rkt

@@ -52,7 +52,7 @@
 ;; Implemented by subclasses:
 (define gl-context%
   (class* object% (gl-context<%>)
-    (define/private (with-gl-lock t alternate-evt enable-break?)
+    (define/private (with-gl-lock t wrapped-t alternate-evt enable-break?)
       (thread-resume manager-t (current-thread))
       (define current (channel-get lock-holder-ch))
       (if (and (eq? (vector-ref current 0) (current-thread))
@@ -65,7 +65,7 @@
                            (dynamic-wind
                                (lambda ()
                                  (thread-cell-set! current-gl-context this))
-                               t
+                               wrapped-t
                                (lambda ()
                                  (thread-cell-set! current-gl-context #f)
                                  (channel-put ch #t))))))
@@ -76,15 +76,17 @@
 
     (define/public (call-as-current t [alternate-evt never-evt] [enable-breaks? #f])
       (with-gl-lock
+       t
        (lambda ()
          (do-call-as-current t))
        alternate-evt
        enable-breaks?))
 
     (define/public (swap-buffers)
+      (define (do-swap) (do-swap-buffers))
       (with-gl-lock
-       (lambda ()
-         (do-swap-buffers))
+       do-swap
+       do-swap
        never-evt
        #f))
 

draw-test/tests/racket/draw/gl-context.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+
+(require racket/class
+         racket/gui/base
+         sgl/gl)
+
+;; Exercise reentrancy of `call-as-current`.
+(define bm (make-gl-bitmap 32 32 (new gl-config%)))
+(define ctx (send (make-object bitmap-dc% bm) get-gl-context))
+(send ctx call-as-current
+      (λ ()
+        (glClearColor 0.0 0.0 0.0 0.0)
+        (glClear GL_COLOR_BUFFER_BIT)
+        (glBegin GL_TRIANGLES)
+        (send ctx call-as-current
+              (λ ()
+                (glVertex2f -1.0 -1.0)
+                (glVertex2f +1.0 -1.0)
+                (glVertex2f -1.0 +1.0)))
+        (glEnd)
+        (glFinish)))