From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 11 Aug 2011 00:31:05 +0000 (-0700)
Subject: G-signal-connect now has an optional signal-name parameter.
X-Git-Tag: mit-scheme-pucked-9.2.12~648
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6238184bc61c7bc6625d1be6e53b01bd03845a4f;p=mit-scheme.git

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

diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm
index bdffeae7e..30f32d8fa 100644
--- 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)