gtk: change clipboard access to keep racket in charge

instead of letting the ... _wait_...() function drive an
 event loop;
 hopefully Closes PR 11534

collects/mred/private/wx/gtk/clipboard.rkt

@@ -27,13 +27,6 @@
 (define _GtkDisplay _pointer)
 (define _GtkSelectionData (_cpointer 'GtkSelectionData))
 
-(define _freed-string (make-ctype _pointer 
-                                  (lambda (s) s)
-                                  (lambda (p)
-                                    (let ([s (cast p _pointer _string)])
-                                      (g_free p)
-                                      s))))
-
 ;; Recent versions of Gtk provide function calls to
 ;;  access data, but use structure when the functions are
 ;;  not available
@@ -59,15 +52,11 @@
                                          _bytes
                                          _int
                                          -> _void))
-(define-gtk gtk_clipboard_wait_for_contents (_fun _GtkClipboard _GdkAtom -> (_or-null _GtkSelectionData)))
 (define-gtk gtk_selection_data_free (_fun _GtkSelectionData -> _void))
 (define-gtk gtk_selection_data_get_length (_fun _GtkSelectionData -> _int)
   #:fail (lambda () GtkSelectionDataT-length))
 (define-gtk gtk_selection_data_get_data (_fun _GtkSelectionData -> _pointer)
   #:fail (lambda () GtkSelectionDataT-data))
-(define-gtk gtk_clipboard_wait_for_text (_fun _GtkClipboard -> _freed-string))
-(define-gtk gtk_clipboard_wait_for_image (_fun _GtkClipboard -> _GdkPixbuf)
-  #:wrap (allocator gobject-unref))
 
 (define-cstruct _GtkTargetEntry ([target _pointer]
                                  [flags _uint]
@@ -88,6 +77,59 @@
 
 (define the-x-selection-driver #f)
 
+;; ----------------------------------------
+
+(define _request-fun (_fun #:atomic? #t _GtkClipboard (_or-null _GtkSelectionData) _pointer -> _void))
+(define _request-string-fun (_fun #:atomic? #t _GtkClipboard _string _pointer -> _void))
+(define _request-image-fun (_fun #:atomic? #t _GtkClipboard _GdkPixbuf _pointer -> _void))
+
+(define (handle-receipt backref data convert)
+  (let ([l (ptr-ref backref _racket)])
+    (free-immobile-cell backref)
+    (set-box! (car l) (and data (convert data)))
+    (semaphore-post (cdr l))))
+
+(define (make-request-backref)
+  (let ([l (cons (box #f) (make-semaphore))])
+    (values l (malloc-immobile-cell l))))
+
+(define (wait-request-backref l)
+  (semaphore-wait (cdr l))
+  (unbox (car l)))
+
+(define (request-received cb data backref)
+  (handle-receipt backref 
+		  data
+		  (lambda (v)
+		    (let ([bstr (scheme_make_sized_byte_string
+				 (gtk_selection_data_get_data v)
+				 (gtk_selection_data_get_length v)
+				 1)])
+		      bstr))))
+
+(define (string-request-received cb str backref)
+  (handle-receipt backref 
+		  str
+		  (lambda (str) str)))
+
+(define (image-request-received cb pix backref)
+  (handle-receipt backref 
+		  pix
+		  pixbuf->bitmap))
+
+(define request_received (function-ptr request-received _request-fun))
+(define string_request_received (function-ptr string-request-received _request-string-fun))
+(define image_request_received (function-ptr image-request-received _request-image-fun))
+
+(define-gtk gtk_clipboard_request_contents 
+  (_fun _GtkClipboard _GdkAtom (_fpointer = request_received) _pointer -> _void))
+(define-gtk gtk_clipboard_request_text 
+  (_fun _GtkClipboard (_fpointer = string_request_received) _pointer -> _void))
+(define-gtk gtk_clipboard_request_image 
+  (_fun _GtkClipboard (_fpointer = image_request_received) _pointer -> _void))
+
+;; ----------------------------------------
+
 (defclass clipboard-driver% object%
   (init-field [x-selection? #f])
 
@@ -195,29 +237,30 @@
                               bstr
                               (bytes-length bstr))))
 
-  (define/public (get-data format)
-    (let ([process (lambda (v)
-                     (and v
-                          (let ([bstr (scheme_make_sized_byte_string
-                                       (gtk_selection_data_get_data v)
-                                       (gtk_selection_data_get_length v)
-                                       1)])
-                            (gtk_selection_data_free v)
-                            bstr)))]
-	  [format (if (equal? format "TEXT")
-		      "UTF8_STRING"
-		      format)])
-      (process (gtk_clipboard_wait_for_contents cb (gdk_atom_intern format #t)))))
+  (define/public (get-data data-format)
+    (let* ([data-format (if (equal? data-format "TEXT")
+			    "UTF8_STRING"
+			    data-format)]
+	   [atom (gdk_atom_intern data-format #t)])
+      (wait-request-backref 
+       (atomically
+	(let-values ([(l backref) (make-request-backref)])
+	  (gtk_clipboard_request_contents cb atom backref)
+	  l)))))
 
   (define/public (get-text-data)
-    (or (gtk_clipboard_wait_for_text cb) ""))
+    (wait-request-backref 
+     (atomically
+      (let-values ([(l backref) (make-request-backref)])
+	(gtk_clipboard_request_text cb backref)
+	l))))
 
   (define/public (get-bitmap-data)
-    (let ([pixbuf (gtk_clipboard_wait_for_image cb)])
-      (and pixbuf
-           (begin0
-            (pixbuf->bitmap pixbuf)
-            (gobject-unref pixbuf)))))
+    (wait-request-backref 
+     (atomically
+      (let-values ([(l backref) (make-request-backref)])
+	(gtk_clipboard_request_image cb backref)
+	l))))
   
   (super-new))