[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
112ac1d3	1	;; Common Lisp bindings for GTK+ v2.x
112ac1d3	2	;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
c8c48a4c	3	;;
112ac1d3	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:
c8c48a4c	11	;;
112ac1d3	12	;; The above copyright notice and this permission notice shall be
112ac1d3	13	;; included in all copies or substantial portions of the Software.
c8c48a4c	14	;;
112ac1d3	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
9944c385	23	;; $Id: gcallback.lisp,v 1.26 2006-02-01 14:18:49 espen Exp $
c8c48a4c	24
	25	(in-package "GLIB")
	26
	27	(use-prefix "g")
	28
	29
e0d2987b	30	;;;; Callback invokation
c8c48a4c	31
e378b861	32	(defun register-callback-function (function)
	33	(check-type function (or null symbol function))
	34	(register-user-data function))
c8c48a4c	35
e0d2987b	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))
266ca870	44	(declare (ignore gclosure invocation-hint))
e0d2987b	45	(callback-trampoline callback-id n-params param-values return-value))
c8c48a4c	46
e0d2987b	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)))
c8c48a4c	57	(let* ((return-type (unless (null-pointer-p return-value)
e378b861	58	(gvalue-type return-value)))
34f9e1d4	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
8755b1a5	66	(defun invoke-callback (callback-id return-type &rest args)
34f9e1d4	67	(restart-case
	68	(apply (find-user-data callback-id) args)
	69	(continue nil :report "Return from callback function"
8755b1a5	70	(when return-type
8755b1a5	71	(format query-io "Enter return value of type ~S: " return-type)
34f9e1d4	72	(force-output query-io)
	73	(eval (read query-io))))
	74	(re-invoke nil :report "Re-invoke callback function"
8755b1a5	75	(apply #'invoke-callback callback-id return-type args))))
c8c48a4c	76
c8c48a4c	77
e378b861	78	;;;; Timeouts and idle functions
e378b861	79
acd28982	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
8755b1a5	89	(defcallback source-callback-marshal (nil (callback-id unsigned-int))
e0d2987b	90	(callback-trampoline callback-id 0 nil))
e378b861	91
e378b861	92	(defbinding (timeout-add "g_timeout_add_full")
acd28982	93	(interval function &optional (priority +priority-default+)) unsigned-int
e378b861	94	(priority int)
e378b861	95	(interval unsigned-int)
acd28982	96	((callback source-callback-marshal) pointer)
e378b861	97	((register-callback-function function) unsigned-long)
73572c12	98	((callback user-data-destroy-func) pointer))
e378b861	99
acd28982	100	(defun timeout-remove (timeout)
	101	(source-remove timeout))
	102
e378b861	103	(defbinding (idle-add "g_idle_add_full")
acd28982	104	(function &optional (priority +priority-default-idle+)) unsigned-int
e378b861	105	(priority int)
acd28982	106	((callback source-callback-marshal) pointer)
e378b861	107	((register-callback-function function) unsigned-long)
73572c12	108	((callback user-data-destroy-func) pointer))
e378b861	109
acd28982	110	(defun idle-remove (idle)
acd28982	111	(source-remove idle))
e378b861	112
c8c48a4c	113
e0d2987b	114	;;;; Signal information querying
c8c48a4c	115
e0d2987b	116	(defbinding signal-lookup (name type) unsigned-int
c8c48a4c	117	((signal-name-to-string name) string)
e0d2987b	118	((find-type-number type t) type-number))
c8c48a4c	119
e0d2987b	120	(defbinding signal-name () (copy-of string)
c8c48a4c	121	(signal-id unsigned-int))
c8c48a4c	122
e0d2987b	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)
c8c48a4c	131	(etypecase signal-id
e0d2987b	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)))
c8c48a4c	143
e0d2987b	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
9944c385	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
e0d2987b	262	(defbinding %signal-stop-emission () nil
c8c48a4c	263	(instance ginstance)
e0d2987b	264	(signal-id unsigned-int)
	265	(detail quark))
	266
	267	(defvar signal-stop-emission nil)
	268	(declaim (special signal-stop-emission))
c8c48a4c	269
e0d2987b	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)
73572c12	282	((callback user-data-destroy-func) pointer))
e0d2987b	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))
c8c48a4c	287
c8c48a4c	288
0383dd48	289	(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c	290	(instance signal-id &key detail blocked) boolean
c8c48a4c	291	(instance ginstance)
e49e135a	292	((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c	293	((or detail 0) quark)
73572c12	294	(blocked boolean))
c8c48a4c	295
e0d2987b	296	(defbinding %signal-connect-closure-by-id () unsigned-int
c8c48a4c	297	(instance ginstance)
e0d2987b	298	(signal-id unsigned-int)
	299	(detail quark)
	300	(closure pointer)
c8c48a4c	301	(after boolean))
c8c48a4c	302
0383dd48	303	(defbinding signal-handler-block () nil
c8c48a4c	304	(instance ginstance)
e0d2987b	305	(handler-id unsigned-int))
c8c48a4c	306
0383dd48	307	(defbinding signal-handler-unblock () nil
c8c48a4c	308	(instance ginstance)
e0d2987b	309	(handler-id unsigned-int))
c8c48a4c	310
0383dd48	311	(defbinding signal-handler-disconnect () nil
c8c48a4c	312	(instance ginstance)
e0d2987b	313	(handler-id unsigned-int))
	314
	315	(defbinding signal-handler-is-connected-p () boolean
	316	(instance ginstance)
	317	(handler-id unsigned-int))
c8c48a4c	318
d75a77ff	319	(deftype gclosure () 'pointer)
2c0a3ce1	320	(register-type 'gclosure "GClosure")
d75a77ff	321
d75a77ff	322	(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
e0d2987b	323	(callback-id unsigned-int)
	324	(callback pointer)
	325	(destroy-notify pointer))
c8c48a4c	326
e0d2987b	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)
73572c12	332	(callback user-data-destroy-func))
e0d2987b	333	callback-id)))
e0d2987b	334
cd9b9e8b	335	(defgeneric compute-signal-function (gobject signal function object))
65670fe5	336
cd9b9e8b	337	(defmethod compute-signal-function ((gobject gobject) signal function object)
cd9b9e8b	338	(declare (ignore signal))
e0d2987b	339	(cond
cd9b9e8b	340	((or (eq object t) (eq object gobject)) function)
cd9b9e8b	341	((not object)
e0d2987b	342	#'(lambda (&rest args) (apply function (rest args))))
e0d2987b	343	(t
cd9b9e8b	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)))
e0d2987b	359
65670fe5	360
e0d2987b	361	(defmethod signal-connect ((gobject gobject) signal function
cd9b9e8b	362	&key detail after object remove)
e0d2987b	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."
cd9b9e8b	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)))))
e0d2987b	379	(multiple-value-bind (closure-id callback-id)
	380	(make-callback-closure wrapper)
	381	(let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b	382	gobject signal-id detail-quark closure-id after)))
e0d2987b	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)))))
cd9b9e8b	390	handler-id))))
e0d2987b	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
c0f178d0	443
fd1e4a39	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))))