G-signal-connect now has an optional signal-name parameter.

diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm
index bdffeae7e3bfeb1ae4f60bddf5f87a35accc5ddf..30f32d8fa4e89658dbca5c290a28b3be85ea2b9f 100644 (file)
--- a/src/gtk/gobject.scm
+++ b/src/gtk/gobject.scm
@@ -82,25 +82,33 @@ USA.
        (alien-null! alien)))
   (%trace ";gobject-cleanup done with "alien"\n"))
 
-(define (g-signal-connect gobject alien-function callback)
+(define (g-signal-connect gobject alien-function callback
+                         #!optional signal-name)
+  ;; Specify SIGNAL-NAME if it is not the same as ALIEN-FUNCTION's name.
   (guarantee-gobject gobject 'g-signal-connect)
   (guarantee-alien-function alien-function 'g-signal-connect)
-  (without-interrupts
-   (lambda ()
-     (let* ((name (alien-function/name alien-function))
-           (sym (string->symbol name))
-           (alien (gobject-alien gobject))
-           (signals (gobject-signals gobject))
-           (sym.id.handle (or (assq sym (cdr signals))
-                              (let ((entry (cons* sym #f #f)))
-                                (set-cdr! signals (cons entry (cdr signals)))
-                                entry))))
-       (disconnect!? alien (cdr sym.id.handle))
-       (connect! alien sym.id.handle
-                alien-function
-                (register-c-callback
-                 (make-gobject-signal-callback
-                  sym (gobject-weak-self gobject) callback)))))))
+  (let ((name (cond ((default-object? signal-name)
+                    (string->symbol (alien-function/name alien-function)))
+                   ((symbol? signal-name) signal-name)
+                   ((string? signal-name) (string->symbol signal-name))
+                   (else
+                    (error:wrong-type-argument
+                     signal-name "string or symbol" 'g-signal-connect)))))
+    (without-interrupts
+     (lambda ()
+       (let* ((alien (gobject-alien gobject))
+             (signals (gobject-signals gobject))
+             (name.id.handle
+              (or (assq name (cdr signals))
+                  (let ((entry (cons* name #f #f)))
+                    (set-cdr! signals (cons entry (cdr signals)))
+                    entry))))
+        (disconnect!? alien (cdr name.id.handle))
+        (connect! alien name.id.handle
+                  alien-function
+                  (register-c-callback
+                   (make-gobject-signal-callback
+                    name (gobject-weak-self gobject) callback))))))))
 
 (define (make-gobject-signal-callback name weak-pair callback)
   (named-lambda (gobject-signal-callback instance . args)
@@ -112,12 +120,12 @@ USA.
          (apply callback gobject args))
        (error "Cannot signal a <gobject> that is already GC'ed:" name args))))
 
-(define (connect! alien sym.id.handle alien-function newid)
-  (let ((id.handle (cdr sym.id.handle)))
+(define (connect! alien name.id.handle alien-function newid)
+  (let ((id.handle (cdr name.id.handle)))
     (set-car! id.handle newid)
     (set-cdr! id.handle
              (C-call "g_signal_connect_data" alien
-                     (alien-function/name alien-function)
+                     (symbol-name (car name.id.handle))
                      alien-function newid 0 0))))
 
 (define (g-signal-disconnect gobject name)