[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
c9819f3e	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
08d14e5e	18	;; $Id: gcallback.lisp,v 1.23 2005/03/06 17:18:00 espen Exp $
c9819f3e	19
	20	(in-package "GLIB")
	21
	22	(use-prefix "g")
	23
	24
3b8e5eb0	25	;;;; Callback invokation
c9819f3e	26
60cfb912	27	(defun register-callback-function (function)
	28	(check-type function (or null symbol function))
	29	(register-user-data function))
c9819f3e	30
3b8e5eb0	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))
08d14e5e	39	(declare (ignore gclosure invocation-hint))
3b8e5eb0	40	(callback-trampoline callback-id n-params param-values return-value))
c9819f3e	41
3b8e5eb0	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)))
c9819f3e	52	(let* ((return-type (unless (null-pointer-p return-value)
60cfb912	53	(gvalue-type return-value)))
831668e8	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
7bde5a67	61	(defun invoke-callback (callback-id return-type &rest args)
831668e8	62	(restart-case
	63	(apply (find-user-data callback-id) args)
	64	(continue nil :report "Return from callback function"
7bde5a67	65	(when return-type
7bde5a67	66	(format query-io "Enter return value of type ~S: " return-type)
831668e8	67	(force-output query-io)
	68	(eval (read query-io))))
	69	(re-invoke nil :report "Re-invoke callback function"
7bde5a67	70	(apply #'invoke-callback callback-id return-type args))))
c9819f3e	71
c9819f3e	72
60cfb912	73	;;;; Timeouts and idle functions
60cfb912	74
0f2fb864	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
7bde5a67	84	(defcallback source-callback-marshal (nil (callback-id unsigned-int))
3b8e5eb0	85	(callback-trampoline callback-id 0 nil))
60cfb912	86
60cfb912	87	(defbinding (timeout-add "g_timeout_add_full")
0f2fb864	88	(interval function &optional (priority +priority-default+)) unsigned-int
60cfb912	89	(priority int)
60cfb912	90	(interval unsigned-int)
0f2fb864	91	((callback source-callback-marshal) pointer)
60cfb912	92	((register-callback-function function) unsigned-long)
3d36c5d6	93	((callback user-data-destroy-func) pointer))
60cfb912	94
0f2fb864	95	(defun timeout-remove (timeout)
	96	(source-remove timeout))
	97
60cfb912	98	(defbinding (idle-add "g_idle_add_full")
0f2fb864	99	(function &optional (priority +priority-default-idle+)) unsigned-int
60cfb912	100	(priority int)
0f2fb864	101	((callback source-callback-marshal) pointer)
60cfb912	102	((register-callback-function function) unsigned-long)
3d36c5d6	103	((callback user-data-destroy-func) pointer))
60cfb912	104
0f2fb864	105	(defun idle-remove (idle)
0f2fb864	106	(source-remove idle))
60cfb912	107
c9819f3e	108
3b8e5eb0	109	;;;; Signal information querying
c9819f3e	110
3b8e5eb0	111	(defbinding signal-lookup (name type) unsigned-int
c9819f3e	112	((signal-name-to-string name) string)
3b8e5eb0	113	((find-type-number type t) type-number))
c9819f3e	114
3b8e5eb0	115	(defbinding signal-name () (copy-of string)
c9819f3e	116	(signal-id unsigned-int))
c9819f3e	117
3b8e5eb0	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)
c9819f3e	126	(etypecase signal-id
3b8e5eb0	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)))
c9819f3e	138
3b8e5eb0	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
c9819f3e	185	(instance ginstance)
3b8e5eb0	186	(signal-id unsigned-int)
	187	(detail quark))
	188
	189	(defvar signal-stop-emission nil)
	190	(declaim (special signal-stop-emission))
c9819f3e	191
3b8e5eb0	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)
3d36c5d6	204	((callback user-data-destroy-func) pointer))
3b8e5eb0	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))
c9819f3e	209
c9819f3e	210
3f4249c7	211	(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c9819f3e	212	(instance signal-id &key detail blocked) boolean
c9819f3e	213	(instance ginstance)
7eec806d	214	((ensure-signal-id signal-id instance) unsigned-int)
c9819f3e	215	((or detail 0) quark)
3d36c5d6	216	(blocked boolean))
c9819f3e	217
3b8e5eb0	218	(defbinding %signal-connect-closure-by-id () unsigned-int
c9819f3e	219	(instance ginstance)
3b8e5eb0	220	(signal-id unsigned-int)
	221	(detail quark)
	222	(closure pointer)
c9819f3e	223	(after boolean))
c9819f3e	224
3f4249c7	225	(defbinding signal-handler-block () nil
c9819f3e	226	(instance ginstance)
3b8e5eb0	227	(handler-id unsigned-int))
c9819f3e	228
3f4249c7	229	(defbinding signal-handler-unblock () nil
c9819f3e	230	(instance ginstance)
3b8e5eb0	231	(handler-id unsigned-int))
c9819f3e	232
3f4249c7	233	(defbinding signal-handler-disconnect () nil
c9819f3e	234	(instance ginstance)
3b8e5eb0	235	(handler-id unsigned-int))
	236
	237	(defbinding signal-handler-is-connected-p () boolean
	238	(instance ginstance)
	239	(handler-id unsigned-int))
c9819f3e	240
bde4e068	241	(deftype gclosure () 'pointer)
	242
	243	(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
3b8e5eb0	244	(callback-id unsigned-int)
	245	(callback pointer)
	246	(destroy-notify pointer))
c9819f3e	247
3b8e5eb0	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)
3d36c5d6	253	(callback user-data-destroy-func))
3b8e5eb0	254	callback-id)))
3b8e5eb0	255
54ea42fe	256	(defgeneric compute-signal-function (gobject signal function object))
a6e13fb0	257
54ea42fe	258	(defmethod compute-signal-function ((gobject gobject) signal function object)
54ea42fe	259	(declare (ignore signal))
3b8e5eb0	260	(cond
54ea42fe	261	((or (eq object t) (eq object gobject)) function)
54ea42fe	262	((not object)
3b8e5eb0	263	#'(lambda (&rest args) (apply function (rest args))))
3b8e5eb0	264	(t
54ea42fe	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)))
3b8e5eb0	280
a6e13fb0	281
3b8e5eb0	282	(defmethod signal-connect ((gobject gobject) signal function
54ea42fe	283	&key detail after object remove)
3b8e5eb0	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."
54ea42fe	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)))))
3b8e5eb0	300	(multiple-value-bind (closure-id callback-id)
	301	(make-callback-closure wrapper)
	302	(let ((handler-id (%signal-connect-closure-by-id
54ea42fe	303	gobject signal-id detail-quark closure-id after)))
3b8e5eb0	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)))))
54ea42fe	311	handler-id))))
3b8e5eb0	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
dd181a20	364
11e1e57c	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))))