[clg] / glib / gcallback.lisp

;; Common Lisp bindings for GTK+ v2.x
;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; 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.26 2006/02/01 14:18:49 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

(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 defaults return-type)
  (let ((params (allocate-memory (* n-params +gvalue-size+))))
    (loop 
     as tmp = args then (rest tmp)
     for default in defaults
     for type in types
     for offset from 0 by +gvalue-size+
     as arg = (if tmp (car tmp) default)
     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")))

    `(progn
       (signal-override-class-closure ',name ',class 
	#'(lambda (,object ,@args)
	    (flet ((call-next-handler (&rest ,next)
		     (let ((defaults (list* ,object ,@vars ,rest)))
		       (%call-next-handler 
			,n-params ',types ,next defaults ',return-type))))
	      ,@body)))
       ',name)))


(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)
(register-type 'gclosure "GClosure")

(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
55212af1	1	;; Common Lisp bindings for GTK+ v2.x
55212af1	2	;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
c9819f3e	3	;;
55212af1	4	;; Permission is hereby granted, free of charge, to any person obtaining
	5	;; a copy of this software and associated documentation files (the
	6	;; "Software"), to deal in the Software without restriction, including
	7	;; without limitation the rights to use, copy, modify, merge, publish,
	8	;; distribute, sublicense, and/or sell copies of the Software, and to
	9	;; permit persons to whom the Software is furnished to do so, subject to
	10	;; the following conditions:
c9819f3e	11	;;
55212af1	12	;; The above copyright notice and this permission notice shall be
55212af1	13	;; included in all copies or substantial portions of the Software.
c9819f3e	14	;;
55212af1	15	;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	16	;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	17	;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
	18	;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
	19	;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
	20	;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
	21	;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
	22
2d3de529	23	;; $Id: gcallback.lisp,v 1.26 2006/02/01 14:18:49 espen Exp $
c9819f3e	24
	25	(in-package "GLIB")
	26
	27	(use-prefix "g")
	28
	29
3b8e5eb0	30	;;;; Callback invokation
c9819f3e	31
60cfb912	32	(defun register-callback-function (function)
	33	(check-type function (or null symbol function))
	34	(register-user-data function))
c9819f3e	35
3b8e5eb0	36	;; Callback marshal for regular signal handlers
	37	(defcallback closure-marshal (nil
	38	(gclosure pointer)
	39	(return-value gvalue)
	40	(n-params unsigned-int)
	41	(param-values pointer)
	42	(invocation-hint pointer)
	43	(callback-id unsigned-int))
08d14e5e	44	(declare (ignore gclosure invocation-hint))
3b8e5eb0	45	(callback-trampoline callback-id n-params param-values return-value))
c9819f3e	46
3b8e5eb0	47	;; Callback function for emission hooks
	48	(defcallback signal-emission-hook (nil
	49	(invocation-hint pointer)
	50	(n-params unsigned-int)
	51	(param-values pointer)
	52	(callback-id unsigned-int))
	53	(callback-trampoline callback-id n-params param-values))
	54
	55	(defun callback-trampoline (callback-id n-params param-values &optional
	56	(return-value (make-pointer 0)))
c9819f3e	57	(let* ((return-type (unless (null-pointer-p return-value)
60cfb912	58	(gvalue-type return-value)))
831668e8	59	(args (loop
	60	for n from 0 below n-params
	61	collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
	62	(let ((result (apply #'invoke-callback callback-id return-type args)))
	63	(when return-type
	64	(gvalue-set return-value result)))))
	65
7bde5a67	66	(defun invoke-callback (callback-id return-type &rest args)
831668e8	67	(restart-case
	68	(apply (find-user-data callback-id) args)
	69	(continue nil :report "Return from callback function"
7bde5a67	70	(when return-type
7bde5a67	71	(format query-io "Enter return value of type ~S: " return-type)
831668e8	72	(force-output query-io)
	73	(eval (read query-io))))
	74	(re-invoke nil :report "Re-invoke callback function"
7bde5a67	75	(apply #'invoke-callback callback-id return-type args))))
c9819f3e	76
c9819f3e	77
60cfb912	78	;;;; Timeouts and idle functions
60cfb912	79
0f2fb864	80	(defconstant +priority-high+ -100)
	81	(defconstant +priority-default+ 0)
	82	(defconstant +priority-high-idle+ 100)
	83	(defconstant +priority-default-idle+ 200)
	84	(defconstant +priority-low+ 300)
	85
	86	(defbinding source-remove () boolean
	87	(tag unsigned-int))
	88
7bde5a67	89	(defcallback source-callback-marshal (nil (callback-id unsigned-int))
3b8e5eb0	90	(callback-trampoline callback-id 0 nil))
60cfb912	91
60cfb912	92	(defbinding (timeout-add "g_timeout_add_full")
0f2fb864	93	(interval function &optional (priority +priority-default+)) unsigned-int
60cfb912	94	(priority int)
60cfb912	95	(interval unsigned-int)
0f2fb864	96	((callback source-callback-marshal) pointer)
60cfb912	97	((register-callback-function function) unsigned-long)
3d36c5d6	98	((callback user-data-destroy-func) pointer))
60cfb912	99
0f2fb864	100	(defun timeout-remove (timeout)
	101	(source-remove timeout))
	102
60cfb912	103	(defbinding (idle-add "g_idle_add_full")
0f2fb864	104	(function &optional (priority +priority-default-idle+)) unsigned-int
60cfb912	105	(priority int)
0f2fb864	106	((callback source-callback-marshal) pointer)
60cfb912	107	((register-callback-function function) unsigned-long)
3d36c5d6	108	((callback user-data-destroy-func) pointer))
60cfb912	109
0f2fb864	110	(defun idle-remove (idle)
0f2fb864	111	(source-remove idle))
60cfb912	112
c9819f3e	113
3b8e5eb0	114	;;;; Signal information querying
c9819f3e	115
3b8e5eb0	116	(defbinding signal-lookup (name type) unsigned-int
c9819f3e	117	((signal-name-to-string name) string)
3b8e5eb0	118	((find-type-number type t) type-number))
c9819f3e	119
3b8e5eb0	120	(defbinding signal-name () (copy-of string)
c9819f3e	121	(signal-id unsigned-int))
c9819f3e	122
3b8e5eb0	123	(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
	124	((find-type-number type t) type-number)
	125	(n-ids unsigned-int :out))
	126
	127	(defun signal-list-names (type)
	128	(map 'list #'signal-name (signal-list-ids type)))
	129
	130	(defun ensure-signal-id-from-type (signal-id type)
c9819f3e	131	(etypecase signal-id
3b8e5eb0	132	(integer (if (signal-name signal-id)
	133	signal-id
	134	(error "Invalid signal id: ~D" signal-id)))
	135	((or symbol string)
	136	(let ((numeric-id (signal-lookup signal-id type)))
	137	(if (zerop numeric-id)
	138	(error "Invalid signal name for ~S: ~D" type signal-id)
	139	numeric-id)))))
	140
	141	(defun ensure-signal-id (signal-id instance)
	142	(ensure-signal-id-from-type signal-id (type-of instance)))
c9819f3e	143
3b8e5eb0	144	(eval-when (:compile-toplevel :load-toplevel :execute)
	145	(deftype signal-flags ()
	146	'(flags :run-first :run-last :run-cleanup :no-recurse
	147	:detailed :action :no-hooks))
	148
	149	(defclass signal-query (struct)
	150	((id :allocation :alien :type unsigned-int)
	151	(name :allocation :alien :type (copy-of string))
	152	(type :allocation :alien :type type-number)
	153	(flags :allocation :alien :type signal-flags)
	154	(return-type :allocation :alien :type type-number)
	155	(n-params :allocation :alien :type unsigned-int)
	156	(param-types :allocation :alien :type pointer))
	157	(:metaclass struct-class)))
	158
	159	(defbinding signal-query
	160	(signal-id &optional (signal-query (make-instance 'signal-query))) nil
	161	(signal-id unsigned-int)
	162	(signal-query signal-query :return))
	163
	164	(defun signal-param-types (info)
	165	(with-slots (n-params param-types) info
	166	(map-c-vector 'list
	167	#'(lambda (type-number)
	168	(type-from-number type-number))
	169	param-types 'type-number n-params)))
	170
	171
	172	(defun describe-signal (signal-id &optional type)
	173	(let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
	174	(with-slots (id name type flags return-type n-params) info
	175	(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))
	176	(format t "Signal handlers should return ~A and take ~A~%"
	177	(cond
	178	((= return-type (find-type-number "void")) "no values")
	179	((not (type-from-number return-type)) "values of unknown type")
	180	((format nil "values of type ~S" (type-from-number return-type))))
	181	(if (zerop n-params)
	182	"no arguments"
	183	(format nil "arguments with the following types: ~A"
	184	(signal-param-types info)))))))
	185
	186
	187	;;;; Signal connecting and controlling
	188
2d3de529	189	(defvar overridden-signals (make-hash-table :test 'equalp))
	190
	191	(defbinding %signal-override-class-closure () nil
	192	(signal-id unsigned-int)
	193	(type-number type-number)
	194	(callback-closure pointer))
	195
	196
	197	(defun signal-override-class-closure (name type function)
	198	(let* ((signal-id (ensure-signal-id-from-type name type))
	199	(type-number (find-type-number type t))
	200	(callback-id (gethash (cons type-number signal-id) overridden-signals)))
	201	(if callback-id
	202	(update-user-data callback-id function)
	203	(multiple-value-bind (callback-closure callback-id)
	204	(make-callback-closure function)
	205	(%signal-override-class-closure signal-id type-number callback-closure)
	206	(setf
	207	(gethash (cons type-number signal-id) overridden-signals)
	208	callback-id)))))
	209
	210
	211	(defbinding %signal-chain-from-overridden () nil
	212	(args pointer)
	213	(return-value (or null gvalue)))
	214
	215
	216	(defun %call-next-handler (n-params types args defaults return-type)
	217	(let ((params (allocate-memory (* n-params +gvalue-size+))))
	218	(loop
	219	as tmp = args then (rest tmp)
	220	for default in defaults
	221	for type in types
	222	for offset from 0 by +gvalue-size+
	223	as arg = (if tmp (car tmp) default)
	224	do (gvalue-init (sap+ params offset) type arg))
	225
	226	(unwind-protect
	227	(if return-type
	228	(with-gvalue (return-value return-type)
	229	(%signal-chain-from-overridden params return-value))
	230	(%signal-chain-from-overridden params nil))
	231	(progn
	232	(loop
	233	repeat n-params
	234	for offset from 0 by +gvalue-size+
	235	do (gvalue-unset (sap+ params offset)))
	236	(deallocate-memory params)))))
	237
	238
	239	(defmacro define-signal-handler (name ((object class) &rest args) &body body)
	240	(let* ((info (signal-query (ensure-signal-id-from-type name class)))
	241	(types (cons class (signal-param-types info)))
	242	(n-params (1+ (slot-value info 'n-params)))
	243	(return-type (type-from-number (slot-value info 'return-type)))
	244	(vars (loop
	245	for arg in args
	246	until (eq arg '&rest)
	247	collect arg))
	248	(rest (cadr (member '&rest args)))
	249	(next (make-symbol "ARGS")))
	250
	251	`(progn
	252	(signal-override-class-closure ',name ',class
253	#'(lambda (,object ,@args)
254	(flet ((call-next-handler (&rest ,next)
255	(let ((defaults (list* ,object ,@vars ,rest)))
256	(%call-next-handler
257	,n-params ',types ,next defaults ',return-type))))
258	,@body)))
259	',name)))
260
261
3b8e5eb0	262	(defbinding %signal-stop-emission () nil
c9819f3e	263	(instance ginstance)
3b8e5eb0	264	(signal-id unsigned-int)
	265	(detail quark))
	266
	267	(defvar signal-stop-emission nil)
	268	(declaim (special signal-stop-emission))
c9819f3e	269
3b8e5eb0	270	(defun signal-stop-emission ()
	271	(if signal-stop-emission
	272	(funcall signal-stop-emission)
	273	(error "Not inside a signal handler")))
	274
	275
	276	(defbinding signal-add-emission-hook (type signal function &key (detail 0))
	277	unsigned-int
	278	((ensure-signal-id-from-type signal type) unsigned-int)
	279	(detail quark)
	280	((callback signal-emission-hook) pointer)
	281	((register-callback-function function) unsigned-int)
3d36c5d6	282	((callback user-data-destroy-func) pointer))
3b8e5eb0	283
	284	(defbinding signal-remove-emission-hook (type signal hook-id) nil
	285	((ensure-signal-id-from-type signal type) unsigned-int)
	286	(hook-id unsigned-int))
c9819f3e	287
c9819f3e	288
3f4249c7	289	(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c9819f3e	290	(instance signal-id &key detail blocked) boolean
c9819f3e	291	(instance ginstance)
7eec806d	292	((ensure-signal-id signal-id instance) unsigned-int)
c9819f3e	293	((or detail 0) quark)
3d36c5d6	294	(blocked boolean))
c9819f3e	295
3b8e5eb0	296	(defbinding %signal-connect-closure-by-id () unsigned-int
c9819f3e	297	(instance ginstance)
3b8e5eb0	298	(signal-id unsigned-int)
	299	(detail quark)
	300	(closure pointer)
c9819f3e	301	(after boolean))
c9819f3e	302
3f4249c7	303	(defbinding signal-handler-block () nil
c9819f3e	304	(instance ginstance)
3b8e5eb0	305	(handler-id unsigned-int))
c9819f3e	306
3f4249c7	307	(defbinding signal-handler-unblock () nil
c9819f3e	308	(instance ginstance)
3b8e5eb0	309	(handler-id unsigned-int))
c9819f3e	310
3f4249c7	311	(defbinding signal-handler-disconnect () nil
c9819f3e	312	(instance ginstance)
3b8e5eb0	313	(handler-id unsigned-int))
	314
	315	(defbinding signal-handler-is-connected-p () boolean
	316	(instance ginstance)
	317	(handler-id unsigned-int))
c9819f3e	318
bde4e068	319	(deftype gclosure () 'pointer)
8fd381dc	320	(register-type 'gclosure "GClosure")
bde4e068	321
bde4e068	322	(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
3b8e5eb0	323	(callback-id unsigned-int)
	324	(callback pointer)
	325	(destroy-notify pointer))
c9819f3e	326
3b8e5eb0	327	(defun make-callback-closure (function)
	328	(let ((callback-id (register-callback-function function)))
	329	(values
	330	(callback-closure-new
	331	callback-id (callback closure-marshal)
3d36c5d6	332	(callback user-data-destroy-func))
3b8e5eb0	333	callback-id)))
3b8e5eb0	334
54ea42fe	335	(defgeneric compute-signal-function (gobject signal function object))
a6e13fb0	336
54ea42fe	337	(defmethod compute-signal-function ((gobject gobject) signal function object)
54ea42fe	338	(declare (ignore signal))
3b8e5eb0	339	(cond
54ea42fe	340	((or (eq object t) (eq object gobject)) function)
54ea42fe	341	((not object)
3b8e5eb0	342	#'(lambda (&rest args) (apply function (rest args))))
3b8e5eb0	343	(t
54ea42fe	344	#'(lambda (&rest args) (apply function object (rest args))))))
	345
	346
	347	(defgeneric compute-signal-id (gobject signal))
	348
	349	(defmethod compute-signal-id ((gobject gobject) signal)
	350	(ensure-signal-id signal gobject))
	351
	352
	353	(defgeneric signal-connect (gobject signal function &key detail after object remove))
	354
	355	(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
	356	(declare (ignore gobject signal args))
	357	(when function
	358	(call-next-method)))
3b8e5eb0	359
a6e13fb0	360
3b8e5eb0	361	(defmethod signal-connect ((gobject gobject) signal function
54ea42fe	362	&key detail after object remove)
3b8e5eb0	363	"Connects a callback function to a signal for a particular object. If
	364	:OBJECT is T, the object connected to is passed as the first argument
	365	to the callback function, or if :OBJECT is any other non NIL value, it
	366	is passed as the first argument instead. If :AFTER is non NIL, the
	367	handler will be called after the default handler for the signal. If
	368	:REMOVE is non NIL, the handler will be removed after beeing invoked
	369	once."
54ea42fe	370	(let* ((signal-id (compute-signal-id gobject signal))
	371	(detail-quark (if detail (quark-intern detail) 0))
	372	(signal-stop-emission
	373	#'(lambda ()
	374	(%signal-stop-emission gobject signal-id detail-quark)))
	375	(callback (compute-signal-function gobject signal function object))
	376	(wrapper #'(lambda (&rest args)
	377	(let ((signal-stop-emission signal-stop-emission))
	378	(apply callback args)))))
3b8e5eb0	379	(multiple-value-bind (closure-id callback-id)
	380	(make-callback-closure wrapper)
	381	(let ((handler-id (%signal-connect-closure-by-id
54ea42fe	382	gobject signal-id detail-quark closure-id after)))
3b8e5eb0	383	(when remove
	384	(update-user-data callback-id
	385	#'(lambda (&rest args)
	386	(unwind-protect
	387	(let ((signal-stop-emission signal-stop-emission))
	388	(apply callback args))
	389	(signal-handler-disconnect gobject handler-id)))))
54ea42fe	390	handler-id))))
3b8e5eb0	391
	392
	393	;;;; Signal emission
	394
	395	(defbinding %signal-emitv () nil
	396	(gvalues pointer)
	397	(signal-id unsigned-int)
	398	(detail quark)
	399	(return-value gvalue))
	400
	401	(defvar signal-emit-functions (make-hash-table))
	402
	403	(defun create-signal-emit-function (signal-id)
	404	(let ((info (signal-query signal-id)))
	405	(let* ((type (type-from-number (slot-value info 'type)))
	406	(param-types (cons type (signal-param-types info)))
	407	(return-type (type-from-number (slot-value info 'return-type)))
	408	(n-params (1+ (slot-value info 'n-params)))
	409	(params (allocate-memory (* n-params +gvalue-size+))))
	410	#'(lambda (detail object &rest args)
	411	(unless (= (length args) (1- n-params))
	412	(error "Invalid number of arguments: ~A" (+ 2 (length args))))
	413	(unwind-protect
	414	(loop
	415	for arg in (cons object args)
	416	for type in param-types
	417	as tmp = params then (sap+ tmp +gvalue-size+)
	418	do (gvalue-init tmp type arg)
	419	finally
	420	(if return-type
	421	(return
	422	(with-gvalue (return-value)
	423	(%signal-emitv params signal-id detail return-value)))
	424	(%signal-emitv params signal-id detail (make-pointer 0))))
	425	(loop
	426	repeat n-params
	427	as tmp = params then (sap+ tmp +gvalue-size+)
	428	while (gvalue-p tmp)
	429	do (gvalue-unset tmp)))))))
	430
	431	(defun signal-emit-with-detail (object signal detail &rest args)
	432	(let* ((signal-id (ensure-signal-id signal object))
	433	(function (or
	434	(gethash signal-id signal-emit-functions)
	435	(setf
	436	(gethash signal-id signal-emit-functions)
	437	(create-signal-emit-function signal-id)))))
	438	(apply function detail object args)))
	439
	440	(defun signal-emit (object signal &rest args)
	441	(apply #'signal-emit-with-detail object signal 0 args))
	442
dd181a20	443
11e1e57c	444	;;;; Convenient macros
	445
	446	(defmacro def-callback-marshal (name (return-type &rest args))
	447	(let ((names (loop
	448	for arg in args
	449	collect (if (atom arg) (gensym) (first arg))))
	450	(types (loop
	451	for arg in args
	452	collect (if (atom arg) arg (second arg)))))
	453	`(defcallback ,name (,return-type ,@(mapcar #'list names types)
	454	(callback-id unsigned-int))
	455	(invoke-callback callback-id ',return-type ,@names))))
	456
	457	(defmacro with-callback-function ((id function) &body body)
	458	`(let ((,id (register-callback-function ,function)))
	459	(unwind-protect
	460	(progn ,@body)
	461	(destroy-user-data ,id))))