X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/2c0a3ce122a03f76cfd1e49b8bb08bb04b7b0b47..0c976d9133f0cad7bb959f1c9d067c37d557be78:/glib/gcallback.lisp

diff --git a/glib/gcallback.lisp b/glib/gcallback.lisp
index 4a48777..976bc64 100644
--- a/glib/gcallback.lisp
+++ b/glib/gcallback.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gcallback.lisp,v 1.25 2005-04-24 13:25:31 espen Exp $
+;; $Id: gcallback.lisp,v 1.29 2006-02-08 19:56:25 espen Exp $
 
 (in-package "GLIB")
 
@@ -58,10 +58,17 @@
 			(gvalue-type return-value)))
 	 (args (loop
 		for n from 0 below n-params
-		collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
-    (let ((result (apply #'invoke-callback callback-id return-type args)))
-      (when return-type
-	(gvalue-set return-value result)))))
+		for offset from 0 by +gvalue-size+
+		collect (gvalue-get (sap+ param-values offset) t))))
+    (unwind-protect
+	(let ((result (apply #'invoke-callback callback-id return-type args)))
+	  (when return-type
+	    (gvalue-set return-value result)))
+      (loop 
+       for arg in args
+       when (typep arg 'proxy)
+       do (invalidate-instance arg)))))
+
 
 (defun invoke-callback (callback-id return-type &rest args)
   (restart-case
@@ -186,6 +193,78 @@
 
 ;;;; Signal connecting and controlling
 
+(defvar *overridden-signals* (make-hash-table :test 'equalp))
+
+(defbinding %signal-override-class-closure () nil
+  (signal-id unsigned-int)
+  (type-number type-number)
+  (callback-closure pointer))
+
+
+(defun signal-override-class-closure (name type function)
+  (let* ((signal-id (ensure-signal-id-from-type name type))
+	 (type-number (find-type-number type t))
+	 (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
+    (if callback-id
+	(update-user-data callback-id function)
+      (multiple-value-bind (callback-closure callback-id)
+	  (make-callback-closure function)
+	(%signal-override-class-closure signal-id type-number callback-closure)
+	(setf 
+	 (gethash (cons type-number signal-id) *overridden-signals*)
+	 callback-id)))))
+
+
+(defbinding %signal-chain-from-overridden () nil
+  (args pointer)
+  (return-value (or null gvalue)))
+
+
+(defun %call-next-handler (n-params types args return-type)
+  (let ((params (allocate-memory (* n-params +gvalue-size+))))
+    (loop 
+     for arg in args
+     for type in types
+     for offset from 0 by +gvalue-size+
+     do (gvalue-init (sap+ params offset) type arg))
+
+    (unwind-protect
+	(if return-type
+	    (with-gvalue (return-value return-type)
+	      (%signal-chain-from-overridden params return-value))
+	  (%signal-chain-from-overridden params nil))
+      (progn
+	(loop
+	 repeat n-params
+	 for offset from 0 by +gvalue-size+
+	 do (gvalue-unset (sap+ params offset)))
+	(deallocate-memory params)))))
+
+
+(defmacro define-signal-handler (name ((object class) &rest args) &body body)
+  (let* ((info (signal-query (ensure-signal-id-from-type name class)))
+	 (types (cons class (signal-param-types info)))
+	 (n-params (1+ (slot-value info 'n-params)))
+	 (return-type (type-from-number (slot-value info 'return-type)))
+	 (vars (loop
+		for arg in args
+		until (eq arg '&rest)
+		collect arg))
+	 (rest (cadr (member '&rest args)))
+	 (next (make-symbol "ARGS"))
+	 (default (make-symbol "DEFAULT")))
+
+    `(progn
+       (signal-override-class-closure ',name ',class 
+	#'(lambda (,object ,@args)
+	    (let ((,default (list* ,object ,@vars ,rest)))
+	      (flet ((call-next-handler (&rest ,next)
+		       (%call-next-handler 
+			,n-params ',types (or ,next ,default) ',return-type))))
+	      ,@body)))
+       ',name)))
+
+
 (defbinding %signal-stop-emission () nil
   (instance ginstance)
   (signal-id unsigned-int)