[clg] / glib / gcallback.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: gcallback.lisp,v 1.23 2005-03-06 17:18:00 espen Exp $

(in-package "GLIB")

(use-prefix "g")


;;;; Callback invokation

(defun register-callback-function (function)
  (check-type function (or null symbol function))
  (register-user-data function))

;; Callback marshal for regular signal handlers
(defcallback closure-marshal (nil
			      (gclosure pointer)
			      (return-value gvalue)
			      (n-params unsigned-int) 
			      (param-values pointer)
			      (invocation-hint pointer) 
			      (callback-id unsigned-int))
  (declare (ignore gclosure invocation-hint))
  (callback-trampoline callback-id n-params param-values return-value))

;; Callback function for emission hooks
(defcallback signal-emission-hook (nil
				   (invocation-hint pointer)
				   (n-params unsigned-int) 
				   (param-values pointer)
				   (callback-id unsigned-int))
  (callback-trampoline callback-id n-params param-values))

(defun callback-trampoline (callback-id n-params param-values &optional
			    (return-value (make-pointer 0)))
  (let* ((return-type (unless (null-pointer-p return-value)
			(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)))))

(defun invoke-callback (callback-id return-type &rest args)
  (restart-case
      (apply (find-user-data callback-id) args)
    (continue nil :report "Return from callback function"
	      (when return-type
		(format *query-io* "Enter return value of type ~S: " return-type)
		(force-output *query-io*)
		(eval (read *query-io*))))
    (re-invoke nil :report "Re-invoke callback function"
	       (apply #'invoke-callback callback-id return-type args))))


;;;; Timeouts and idle functions

(defconstant +priority-high+ -100)
(defconstant +priority-default+ 0)
(defconstant +priority-high-idle+ 100)
(defconstant +priority-default-idle+ 200)
(defconstant +priority-low+ 300)

(defbinding source-remove () boolean
  (tag unsigned-int))

(defcallback source-callback-marshal (nil (callback-id unsigned-int))
  (callback-trampoline callback-id 0 nil))

(defbinding (timeout-add "g_timeout_add_full")
    (interval function &optional (priority +priority-default+)) unsigned-int 
  (priority int)
  (interval unsigned-int)
  ((callback source-callback-marshal) pointer)
  ((register-callback-function function) unsigned-long)
  ((callback user-data-destroy-func) pointer))

(defun timeout-remove (timeout)
  (source-remove timeout))

(defbinding (idle-add "g_idle_add_full")
    (function &optional (priority +priority-default-idle+)) unsigned-int 
  (priority int)
  ((callback source-callback-marshal) pointer)
  ((register-callback-function function) unsigned-long)
  ((callback user-data-destroy-func) pointer))

(defun idle-remove (idle)
  (source-remove idle))


;;;; Signal information querying

(defbinding signal-lookup (name type) unsigned-int
  ((signal-name-to-string name) string)
  ((find-type-number type t) type-number))

(defbinding signal-name () (copy-of string)
  (signal-id unsigned-int))

(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
  ((find-type-number type t) type-number)
  (n-ids unsigned-int :out))

(defun signal-list-names (type)
  (map 'list #'signal-name (signal-list-ids type)))

(defun ensure-signal-id-from-type (signal-id type)
  (etypecase signal-id
    (integer (if (signal-name signal-id)
		 signal-id
	       (error "Invalid signal id: ~D" signal-id)))
    ((or symbol string) 
     (let ((numeric-id (signal-lookup signal-id type)))
       (if (zerop numeric-id)
	   (error "Invalid signal name for ~S: ~D" type signal-id)
	 numeric-id)))))

(defun ensure-signal-id (signal-id instance)
  (ensure-signal-id-from-type signal-id (type-of instance)))
  
(eval-when (:compile-toplevel :load-toplevel :execute)
  (deftype signal-flags () 
    '(flags :run-first :run-last :run-cleanup :no-recurse 
	    :detailed :action :no-hooks))

  (defclass signal-query (struct)
    ((id :allocation :alien :type unsigned-int)
     (name :allocation :alien :type (copy-of string))
     (type :allocation :alien :type type-number)
     (flags :allocation :alien :type signal-flags)
     (return-type :allocation :alien :type type-number)
     (n-params :allocation :alien :type unsigned-int)
     (param-types :allocation :alien :type pointer))
    (:metaclass struct-class)))

(defbinding signal-query 
    (signal-id &optional (signal-query (make-instance 'signal-query))) nil
  (signal-id unsigned-int)
  (signal-query signal-query :return))

(defun signal-param-types (info)
  (with-slots (n-params param-types) info
   (map-c-vector 'list 
    #'(lambda (type-number) 
	(type-from-number type-number))
    param-types 'type-number n-params)))


(defun describe-signal (signal-id &optional type)
  (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
    (with-slots (id name type flags return-type n-params) info
      (format t "The signal with id ~D is named '~A' and may be emitted on instances of type ~S~%~%" id name (type-from-number type t))
      (format t "Signal handlers should return ~A and take ~A~%"
       (cond
	((= return-type (find-type-number "void")) "no values")
	((not (type-from-number return-type)) "values of unknown type")
	((format nil "values of type ~S" (type-from-number return-type))))
       (if (zerop n-params)
	   "no arguments"
	 (format nil "arguments with the following types: ~A"
	  (signal-param-types info)))))))


;;;; Signal connecting and controlling

(defbinding %signal-stop-emission () nil
  (instance ginstance)
  (signal-id unsigned-int)
  (detail quark))

(defvar *signal-stop-emission* nil)
(declaim (special *signal-stop-emission*))

(defun signal-stop-emission ()
  (if *signal-stop-emission*
      (funcall *signal-stop-emission*)
    (error "Not inside a signal handler")))


(defbinding signal-add-emission-hook (type signal function &key (detail 0))
    unsigned-int
  ((ensure-signal-id-from-type signal type) unsigned-int)
  (detail quark)
  ((callback signal-emission-hook) pointer)
  ((register-callback-function function) unsigned-int)
  ((callback user-data-destroy-func) pointer))

(defbinding signal-remove-emission-hook (type signal hook-id) nil
  ((ensure-signal-id-from-type signal type) unsigned-int)
  (hook-id unsigned-int))


(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
    (instance signal-id &key detail blocked) boolean
  (instance ginstance)
  ((ensure-signal-id signal-id instance) unsigned-int)
  ((or detail 0) quark)
  (blocked boolean))
    
(defbinding %signal-connect-closure-by-id () unsigned-int
  (instance ginstance)
  (signal-id unsigned-int)
  (detail quark)
  (closure pointer)
  (after boolean))

(defbinding signal-handler-block () nil
  (instance ginstance)
  (handler-id unsigned-int))

(defbinding signal-handler-unblock () nil
  (instance ginstance)
  (handler-id unsigned-int))

(defbinding signal-handler-disconnect () nil
  (instance ginstance)
  (handler-id unsigned-int))

(defbinding signal-handler-is-connected-p () boolean
  (instance ginstance)
  (handler-id unsigned-int))

(deftype gclosure () 'pointer)

(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
  (callback-id unsigned-int) 
  (callback pointer)
  (destroy-notify pointer))

(defun make-callback-closure (function)
  (let ((callback-id (register-callback-function function)))
    (values
     (callback-closure-new 
      callback-id (callback closure-marshal) 
      (callback user-data-destroy-func))
     callback-id)))

(defgeneric compute-signal-function (gobject signal function object))

(defmethod compute-signal-function ((gobject gobject) signal function object)
  (declare (ignore signal))
  (cond
   ((or (eq object t) (eq object gobject)) function)
   ((not object)
    #'(lambda (&rest args) (apply function (rest args))))
   (t
    #'(lambda (&rest args) (apply function object (rest args))))))


(defgeneric compute-signal-id (gobject signal))

(defmethod compute-signal-id ((gobject gobject) signal)
  (ensure-signal-id signal gobject))


(defgeneric signal-connect (gobject signal function &key detail after object remove))

(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
  (declare (ignore gobject signal args))
  (when function
    (call-next-method)))


(defmethod signal-connect ((gobject gobject) signal function
			   &key detail after object remove)
"Connects a callback function to a signal for a particular object. If
:OBJECT is T, the object connected to is passed as the first argument
to the callback function, or if :OBJECT is any other non NIL value, it
is passed as the first argument instead. If :AFTER is non NIL, the
handler will be called after the default handler for the signal. If
:REMOVE is non NIL, the handler will be removed after beeing invoked
once."
(let* ((signal-id (compute-signal-id gobject signal))
       (detail-quark (if detail (quark-intern detail) 0))
       (signal-stop-emission
	#'(lambda ()
	    (%signal-stop-emission gobject signal-id detail-quark)))
       (callback (compute-signal-function gobject signal function object))
       (wrapper #'(lambda (&rest args)
		    (let ((*signal-stop-emission* signal-stop-emission))
		      (apply callback args)))))
      (multiple-value-bind (closure-id callback-id)
	  (make-callback-closure wrapper)
	(let ((handler-id (%signal-connect-closure-by-id 
			   gobject signal-id detail-quark closure-id after)))
	  (when remove
	    (update-user-data callback-id
	     #'(lambda (&rest args)
		 (unwind-protect
		     (let ((*signal-stop-emission* signal-stop-emission))
		       (apply callback args))
		   (signal-handler-disconnect gobject handler-id)))))
	  handler-id))))


;;;; Signal emission

(defbinding %signal-emitv () nil
  (gvalues pointer)
  (signal-id unsigned-int)
  (detail quark)
  (return-value gvalue))

(defvar *signal-emit-functions* (make-hash-table))

(defun create-signal-emit-function (signal-id)
  (let ((info (signal-query signal-id)))
    (let* ((type (type-from-number (slot-value info 'type)))
	   (param-types (cons type (signal-param-types info)))
	   (return-type (type-from-number (slot-value info 'return-type)))
	   (n-params (1+ (slot-value info 'n-params)))
	   (params (allocate-memory (* n-params +gvalue-size+))))
      #'(lambda (detail object &rest args)
 	  (unless (= (length args) (1- n-params))
 	    (error "Invalid number of arguments: ~A" (+ 2 (length args))))
	  (unwind-protect
	      (loop
	       for arg in (cons object args)
	       for type in param-types
	       as tmp = params then (sap+ tmp +gvalue-size+)
	       do (gvalue-init tmp type arg)	      
	       finally 
	       (if return-type
		   (return 
		    (with-gvalue (return-value)
		      (%signal-emitv params signal-id detail return-value)))
		 (%signal-emitv params signal-id detail (make-pointer 0))))
	    (loop
	     repeat n-params
	     as tmp = params then (sap+ tmp +gvalue-size+)
	     while (gvalue-p tmp)
	     do (gvalue-unset tmp)))))))

(defun signal-emit-with-detail (object signal detail &rest args)
  (let* ((signal-id (ensure-signal-id signal object))
	 (function (or 
		    (gethash signal-id *signal-emit-functions*)
		    (setf 
		     (gethash signal-id *signal-emit-functions*)
		     (create-signal-emit-function signal-id)))))
    (apply function detail object args)))

(defun signal-emit (object signal &rest args)
  (apply #'signal-emit-with-detail object signal 0 args))


;;;; Convenient macros

(defmacro def-callback-marshal (name (return-type &rest args))
  (let ((names (loop 
		for arg in args 
		collect (if (atom arg) (gensym) (first arg))))
	(types (loop 
		for arg in args 
		collect (if (atom arg) arg (second arg)))))
    `(defcallback ,name (,return-type ,@(mapcar #'list names types)
			 (callback-id unsigned-int))
      (invoke-callback callback-id ',return-type ,@names))))

(defmacro with-callback-function ((id function) &body body)
  `(let ((,id (register-callback-function ,function)))
    (unwind-protect
	 (progn ,@body)
      (destroy-user-data ,id))))
Commit	Line	Data
c8c48a4c	1	;; Common Lisp bindings for GTK+ v2.0
	2	;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
266ca870	18	;; $Id: gcallback.lisp,v 1.23 2005-03-06 17:18:00 espen Exp $
c8c48a4c	19
	20	(in-package "GLIB")
	21
	22	(use-prefix "g")
	23
	24
e0d2987b	25	;;;; Callback invokation
c8c48a4c	26
e378b861	27	(defun register-callback-function (function)
	28	(check-type function (or null symbol function))
	29	(register-user-data function))
c8c48a4c	30
e0d2987b	31	;; Callback marshal for regular signal handlers
	32	(defcallback closure-marshal (nil
	33	(gclosure pointer)
	34	(return-value gvalue)
	35	(n-params unsigned-int)
	36	(param-values pointer)
	37	(invocation-hint pointer)
	38	(callback-id unsigned-int))
266ca870	39	(declare (ignore gclosure invocation-hint))
e0d2987b	40	(callback-trampoline callback-id n-params param-values return-value))
c8c48a4c	41
e0d2987b	42	;; Callback function for emission hooks
	43	(defcallback signal-emission-hook (nil
	44	(invocation-hint pointer)
	45	(n-params unsigned-int)
	46	(param-values pointer)
	47	(callback-id unsigned-int))
	48	(callback-trampoline callback-id n-params param-values))
	49
	50	(defun callback-trampoline (callback-id n-params param-values &optional
	51	(return-value (make-pointer 0)))
c8c48a4c	52	(let* ((return-type (unless (null-pointer-p return-value)
e378b861	53	(gvalue-type return-value)))
34f9e1d4	54	(args (loop
	55	for n from 0 below n-params
	56	collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
	57	(let ((result (apply #'invoke-callback callback-id return-type args)))
	58	(when return-type
	59	(gvalue-set return-value result)))))
	60
8755b1a5	61	(defun invoke-callback (callback-id return-type &rest args)
34f9e1d4	62	(restart-case
	63	(apply (find-user-data callback-id) args)
	64	(continue nil :report "Return from callback function"
8755b1a5	65	(when return-type
8755b1a5	66	(format query-io "Enter return value of type ~S: " return-type)
34f9e1d4	67	(force-output query-io)
	68	(eval (read query-io))))
	69	(re-invoke nil :report "Re-invoke callback function"
8755b1a5	70	(apply #'invoke-callback callback-id return-type args))))
c8c48a4c	71
c8c48a4c	72
e378b861	73	;;;; Timeouts and idle functions
e378b861	74
acd28982	75	(defconstant +priority-high+ -100)
	76	(defconstant +priority-default+ 0)
	77	(defconstant +priority-high-idle+ 100)
	78	(defconstant +priority-default-idle+ 200)
	79	(defconstant +priority-low+ 300)
	80
	81	(defbinding source-remove () boolean
	82	(tag unsigned-int))
	83
8755b1a5	84	(defcallback source-callback-marshal (nil (callback-id unsigned-int))
e0d2987b	85	(callback-trampoline callback-id 0 nil))
e378b861	86
e378b861	87	(defbinding (timeout-add "g_timeout_add_full")
acd28982	88	(interval function &optional (priority +priority-default+)) unsigned-int
e378b861	89	(priority int)
e378b861	90	(interval unsigned-int)
acd28982	91	((callback source-callback-marshal) pointer)
e378b861	92	((register-callback-function function) unsigned-long)
73572c12	93	((callback user-data-destroy-func) pointer))
e378b861	94
acd28982	95	(defun timeout-remove (timeout)
	96	(source-remove timeout))
	97
e378b861	98	(defbinding (idle-add "g_idle_add_full")
acd28982	99	(function &optional (priority +priority-default-idle+)) unsigned-int
e378b861	100	(priority int)
acd28982	101	((callback source-callback-marshal) pointer)
e378b861	102	((register-callback-function function) unsigned-long)
73572c12	103	((callback user-data-destroy-func) pointer))
e378b861	104
acd28982	105	(defun idle-remove (idle)
acd28982	106	(source-remove idle))
e378b861	107
c8c48a4c	108
e0d2987b	109	;;;; Signal information querying
c8c48a4c	110
e0d2987b	111	(defbinding signal-lookup (name type) unsigned-int
c8c48a4c	112	((signal-name-to-string name) string)
e0d2987b	113	((find-type-number type t) type-number))
c8c48a4c	114
e0d2987b	115	(defbinding signal-name () (copy-of string)
c8c48a4c	116	(signal-id unsigned-int))
c8c48a4c	117
e0d2987b	118	(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
	119	((find-type-number type t) type-number)
	120	(n-ids unsigned-int :out))
	121
	122	(defun signal-list-names (type)
	123	(map 'list #'signal-name (signal-list-ids type)))
	124
	125	(defun ensure-signal-id-from-type (signal-id type)
c8c48a4c	126	(etypecase signal-id
e0d2987b	127	(integer (if (signal-name signal-id)
	128	signal-id
	129	(error "Invalid signal id: ~D" signal-id)))
	130	((or symbol string)
	131	(let ((numeric-id (signal-lookup signal-id type)))
	132	(if (zerop numeric-id)
	133	(error "Invalid signal name for ~S: ~D" type signal-id)
	134	numeric-id)))))
	135
	136	(defun ensure-signal-id (signal-id instance)
	137	(ensure-signal-id-from-type signal-id (type-of instance)))
c8c48a4c	138
e0d2987b	139	(eval-when (:compile-toplevel :load-toplevel :execute)
	140	(deftype signal-flags ()
	141	'(flags :run-first :run-last :run-cleanup :no-recurse
	142	:detailed :action :no-hooks))
	143
	144	(defclass signal-query (struct)
	145	((id :allocation :alien :type unsigned-int)
	146	(name :allocation :alien :type (copy-of string))
	147	(type :allocation :alien :type type-number)
	148	(flags :allocation :alien :type signal-flags)
	149	(return-type :allocation :alien :type type-number)
	150	(n-params :allocation :alien :type unsigned-int)
	151	(param-types :allocation :alien :type pointer))
	152	(:metaclass struct-class)))
	153
	154	(defbinding signal-query
	155	(signal-id &optional (signal-query (make-instance 'signal-query))) nil
	156	(signal-id unsigned-int)
	157	(signal-query signal-query :return))
	158
	159	(defun signal-param-types (info)
	160	(with-slots (n-params param-types) info
	161	(map-c-vector 'list
	162	#'(lambda (type-number)
	163	(type-from-number type-number))
	164	param-types 'type-number n-params)))
	165
	166
	167	(defun describe-signal (signal-id &optional type)
	168	(let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
	169	(with-slots (id name type flags return-type n-params) info
	170	(format t "The signal with id ~D is named '~A' and may be emitted on instances of type ~S~%~%" id name (type-from-number type t))
	171	(format t "Signal handlers should return ~A and take ~A~%"
	172	(cond
	173	((= return-type (find-type-number "void")) "no values")
	174	((not (type-from-number return-type)) "values of unknown type")
	175	((format nil "values of type ~S" (type-from-number return-type))))
	176	(if (zerop n-params)
	177	"no arguments"
	178	(format nil "arguments with the following types: ~A"
	179	(signal-param-types info)))))))
	180
	181
	182	;;;; Signal connecting and controlling
	183
	184	(defbinding %signal-stop-emission () nil
c8c48a4c	185	(instance ginstance)
e0d2987b	186	(signal-id unsigned-int)
	187	(detail quark))
	188
	189	(defvar signal-stop-emission nil)
	190	(declaim (special signal-stop-emission))
c8c48a4c	191
e0d2987b	192	(defun signal-stop-emission ()
	193	(if signal-stop-emission
	194	(funcall signal-stop-emission)
	195	(error "Not inside a signal handler")))
	196
	197
	198	(defbinding signal-add-emission-hook (type signal function &key (detail 0))
	199	unsigned-int
	200	((ensure-signal-id-from-type signal type) unsigned-int)
	201	(detail quark)
	202	((callback signal-emission-hook) pointer)
	203	((register-callback-function function) unsigned-int)
73572c12	204	((callback user-data-destroy-func) pointer))
e0d2987b	205
	206	(defbinding signal-remove-emission-hook (type signal hook-id) nil
	207	((ensure-signal-id-from-type signal type) unsigned-int)
	208	(hook-id unsigned-int))
c8c48a4c	209
c8c48a4c	210
0383dd48	211	(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c	212	(instance signal-id &key detail blocked) boolean
c8c48a4c	213	(instance ginstance)
e49e135a	214	((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c	215	((or detail 0) quark)
73572c12	216	(blocked boolean))
c8c48a4c	217
e0d2987b	218	(defbinding %signal-connect-closure-by-id () unsigned-int
c8c48a4c	219	(instance ginstance)
e0d2987b	220	(signal-id unsigned-int)
	221	(detail quark)
	222	(closure pointer)
c8c48a4c	223	(after boolean))
c8c48a4c	224
0383dd48	225	(defbinding signal-handler-block () nil
c8c48a4c	226	(instance ginstance)
e0d2987b	227	(handler-id unsigned-int))
c8c48a4c	228
0383dd48	229	(defbinding signal-handler-unblock () nil
c8c48a4c	230	(instance ginstance)
e0d2987b	231	(handler-id unsigned-int))
c8c48a4c	232
0383dd48	233	(defbinding signal-handler-disconnect () nil
c8c48a4c	234	(instance ginstance)
e0d2987b	235	(handler-id unsigned-int))
	236
	237	(defbinding signal-handler-is-connected-p () boolean
	238	(instance ginstance)
	239	(handler-id unsigned-int))
c8c48a4c	240
d75a77ff	241	(deftype gclosure () 'pointer)
	242
	243	(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
e0d2987b	244	(callback-id unsigned-int)
	245	(callback pointer)
	246	(destroy-notify pointer))
c8c48a4c	247
e0d2987b	248	(defun make-callback-closure (function)
	249	(let ((callback-id (register-callback-function function)))
	250	(values
	251	(callback-closure-new
	252	callback-id (callback closure-marshal)
73572c12	253	(callback user-data-destroy-func))
e0d2987b	254	callback-id)))
e0d2987b	255
cd9b9e8b	256	(defgeneric compute-signal-function (gobject signal function object))
65670fe5	257
cd9b9e8b	258	(defmethod compute-signal-function ((gobject gobject) signal function object)
cd9b9e8b	259	(declare (ignore signal))
e0d2987b	260	(cond
cd9b9e8b	261	((or (eq object t) (eq object gobject)) function)
cd9b9e8b	262	((not object)
e0d2987b	263	#'(lambda (&rest args) (apply function (rest args))))
e0d2987b	264	(t
cd9b9e8b	265	#'(lambda (&rest args) (apply function object (rest args))))))
	266
	267
	268	(defgeneric compute-signal-id (gobject signal))
	269
	270	(defmethod compute-signal-id ((gobject gobject) signal)
	271	(ensure-signal-id signal gobject))
	272
	273
	274	(defgeneric signal-connect (gobject signal function &key detail after object remove))
	275
	276	(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
	277	(declare (ignore gobject signal args))
	278	(when function
	279	(call-next-method)))
e0d2987b	280
65670fe5	281
e0d2987b	282	(defmethod signal-connect ((gobject gobject) signal function
cd9b9e8b	283	&key detail after object remove)
e0d2987b	284	"Connects a callback function to a signal for a particular object. If
	285	:OBJECT is T, the object connected to is passed as the first argument
	286	to the callback function, or if :OBJECT is any other non NIL value, it
	287	is passed as the first argument instead. If :AFTER is non NIL, the
	288	handler will be called after the default handler for the signal. If
	289	:REMOVE is non NIL, the handler will be removed after beeing invoked
	290	once."
cd9b9e8b	291	(let* ((signal-id (compute-signal-id gobject signal))
	292	(detail-quark (if detail (quark-intern detail) 0))
	293	(signal-stop-emission
	294	#'(lambda ()
	295	(%signal-stop-emission gobject signal-id detail-quark)))
	296	(callback (compute-signal-function gobject signal function object))
	297	(wrapper #'(lambda (&rest args)
	298	(let ((signal-stop-emission signal-stop-emission))
	299	(apply callback args)))))
e0d2987b	300	(multiple-value-bind (closure-id callback-id)
	301	(make-callback-closure wrapper)
	302	(let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b	303	gobject signal-id detail-quark closure-id after)))
e0d2987b	304	(when remove
	305	(update-user-data callback-id
	306	#'(lambda (&rest args)
	307	(unwind-protect
	308	(let ((signal-stop-emission signal-stop-emission))
	309	(apply callback args))
	310	(signal-handler-disconnect gobject handler-id)))))
cd9b9e8b	311	handler-id))))
e0d2987b	312
	313
	314	;;;; Signal emission
	315
	316	(defbinding %signal-emitv () nil
	317	(gvalues pointer)
	318	(signal-id unsigned-int)
	319	(detail quark)
	320	(return-value gvalue))
	321
	322	(defvar signal-emit-functions (make-hash-table))
	323
	324	(defun create-signal-emit-function (signal-id)
	325	(let ((info (signal-query signal-id)))
	326	(let* ((type (type-from-number (slot-value info 'type)))
	327	(param-types (cons type (signal-param-types info)))
	328	(return-type (type-from-number (slot-value info 'return-type)))
	329	(n-params (1+ (slot-value info 'n-params)))
	330	(params (allocate-memory (* n-params +gvalue-size+))))
	331	#'(lambda (detail object &rest args)
	332	(unless (= (length args) (1- n-params))
	333	(error "Invalid number of arguments: ~A" (+ 2 (length args))))
	334	(unwind-protect
	335	(loop
	336	for arg in (cons object args)
	337	for type in param-types
	338	as tmp = params then (sap+ tmp +gvalue-size+)
	339	do (gvalue-init tmp type arg)
	340	finally
	341	(if return-type
	342	(return
	343	(with-gvalue (return-value)
	344	(%signal-emitv params signal-id detail return-value)))
	345	(%signal-emitv params signal-id detail (make-pointer 0))))
	346	(loop
	347	repeat n-params
	348	as tmp = params then (sap+ tmp +gvalue-size+)
	349	while (gvalue-p tmp)
	350	do (gvalue-unset tmp)))))))
	351
	352	(defun signal-emit-with-detail (object signal detail &rest args)
	353	(let* ((signal-id (ensure-signal-id signal object))
	354	(function (or
	355	(gethash signal-id signal-emit-functions)
	356	(setf
	357	(gethash signal-id signal-emit-functions)
	358	(create-signal-emit-function signal-id)))))
	359	(apply function detail object args)))
	360
	361	(defun signal-emit (object signal &rest args)
	362	(apply #'signal-emit-with-detail object signal 0 args))
	363
c0f178d0	364
fd1e4a39	365	;;;; Convenient macros
	366
	367	(defmacro def-callback-marshal (name (return-type &rest args))
	368	(let ((names (loop
	369	for arg in args
	370	collect (if (atom arg) (gensym) (first arg))))
	371	(types (loop
	372	for arg in args
	373	collect (if (atom arg) arg (second arg)))))
	374	`(defcallback ,name (,return-type ,@(mapcar #'list names types)
	375	(callback-id unsigned-int))
	376	(invoke-callback callback-id ',return-type ,@names))))
	377
	378	(defmacro with-callback-function ((id function) &body body)
	379	`(let ((,id (register-callback-function ,function)))
	380	(unwind-protect
	381	(progn ,@body)
	382	(destroy-user-data ,id))))