chiark - git - mdw - clg/blob - glib/gcallback.lisp

   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
  18 ;; $Id: gcallback.lisp,v 1.16 2004-12-05 13:54:10 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24
  25 ;;;; Callback mechanism
  26
  27 (deftype gclosure () 'pointer)
  28
  29 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
  30   (callback-id unsigned-int)
  31   (callback pointer)
  32   (destroy-notify pointer))
  33
  34 (defun register-callback-function (function)
  35   (check-type function (or null symbol function))
  36   (register-user-data function))
  37
  38 (defcallback closure-callback-marshal (nil
  39                                        (gclosure pointer)
  40                                        (return-value gvalue)
  41                                        (n-params unsigned-int)
  42                                        (param-values pointer)
  43                                        (invocation-hint pointer)
  44                                        (callback-id unsigned-int))
  45   (callback-trampoline callback-id n-params param-values return-value))
  46
  47 (defcallback %destroy-user-data (nil (id unsigned-int))
  48   (destroy-user-data id))
  49
  50 (defun make-callback-closure (function)
  51   (callback-closure-new
  52    (register-callback-function function)
  53    (callback closure-callback-marshal) (callback %destroy-user-data)))
  54
  55
  56 (defun callback-trampoline (callback-id n-params param-values return-value)
  57   (let* ((return-type (unless (null-pointer-p return-value)
  58                         (gvalue-type return-value)))
  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
  66
  67 (defun invoke-callback (callback-id return-type &rest args)
  68   (restart-case
  69       (apply (find-user-data callback-id) args)
  70     (continue nil :report "Return from callback function"
  71               (when return-type
  72                 (format *query-io* "Enter return value of type ~S: " return-type)
  73                 (force-output *query-io*)
  74                 (eval (read *query-io*))))
  75     (re-invoke nil :report "Re-invoke callback function"
  76                (apply #'invoke-callback callback-id return-type args))))
  77
  78
  79 ;;;; Timeouts and idle functions
  80
  81 (defconstant +priority-high+ -100)
  82 (defconstant +priority-default+ 0)
  83 (defconstant +priority-high-idle+ 100)
  84 (defconstant +priority-default-idle+ 200)
  85 (defconstant +priority-low+ 300)
  86
  87 (defbinding source-remove () boolean
  88   (tag unsigned-int))
  89
  90 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
  91   (callback-trampoline callback-id 0 nil (make-pointer 0)))
  92
  93 (defbinding (timeout-add "g_timeout_add_full")
  94     (interval function &optional (priority +priority-default+)) unsigned-int
  95   (priority int)
  96   (interval unsigned-int)
  97   ((callback source-callback-marshal) pointer)
  98   ((register-callback-function function) unsigned-long)
  99   ((callback %destroy-user-data) pointer))
 100
 101 (defun timeout-remove (timeout)
 102   (source-remove timeout))
 103
 104 (defbinding (idle-add "g_idle_add_full")
 105     (function &optional (priority +priority-default-idle+)) unsigned-int
 106   (priority int)
 107   ((callback source-callback-marshal) pointer)
 108   ((register-callback-function function) unsigned-long)
 109   ((callback %destroy-user-data) pointer))
 110
 111 (defun idle-remove (idle)
 112   (source-remove idle))
 113
 114
 115 ;;;; Signals
 116
 117 (defbinding signal-lookup (name itype) unsigned-int
 118   ((signal-name-to-string name) string)
 119   (itype type-number))
 120
 121 (defbinding signal-name () string
 122   (signal-id unsigned-int))
 123
 124 (defun ensure-signal-id (signal-id instance)
 125   (etypecase signal-id
 126     (integer signal-id)
 127     (string (signal-lookup signal-id (type-number-of instance)))
 128     (symbol (signal-lookup signal-id (type-number-of instance)))))
 129
 130 (defbinding signal-stop-emission (instance signal-id) nil
 131   (instance ginstance)
 132   ((ensure-signal-id signal-id instance) unsigned-int))
 133
 134 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
 135 ;     () unsigned-int
 136 ;   (signal-id unsigned-int)
 137 ;   (closure gclosure))
 138
 139 ; (defbinding signal-remove-emisson-hook () nil
 140 ;   (signal-id unsigned-int)
 141 ;   (hook-id unsigned-int))
 142
 143 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 144     (instance signal-id &key detail blocked) boolean
 145   (instance ginstance)
 146   ((ensure-signal-id signal-id instance) unsigned-int)
 147   ((or detail 0) quark)
 148   (blocked boolean))
 149
 150 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
 151     (instance signal-id closure &key detail after) unsigned-int
 152   (instance ginstance)
 153   ((ensure-signal-id signal-id instance) unsigned-int)
 154   ((or detail 0) quark)
 155   (closure gclosure)
 156   (after boolean))
 157
 158 (defbinding signal-handler-block () nil
 159   (instance ginstance)
 160   (handler unsigned-int))
 161
 162 (defbinding signal-handler-unblock () nil
 163   (instance ginstance)
 164   (handler unsigned-int))
 165
 166 (defbinding signal-handler-disconnect () nil
 167   (instance ginstance)
 168   (handler unsigned-int))
 169
 170
 171 (defmethod signal-connect ((gobject gobject) signal function &key after object)
 172 "Connects a callback function to a signal for a particular object. If :OBJECT
 173  is T, the object connected to is passed as the first argument to the callback
 174  function, or if :OBJECT is any other non NIL value, it is passed as the first
 175  argument instead. If :AFTER is non NIL, the handler will be called after the
 176  default handler for the signal."
 177   (when function
 178     (let ((callback-id
 179            (make-callback-closure
 180             (cond
 181               ((or (eq object t) (eq object gobject)) function)
 182               ((not object)
 183                #'(lambda (&rest args) (apply function (cdr args))))
 184               (t
 185                #'(lambda (&rest args) (apply function object (rest args))))))))
 186       (signal-connect-closure gobject signal callback-id :after after))))
 187
 188
 189 ;;; Message logging
 190
 191 ;; TODO: define and signal conditions based on log-level
 192 ;(defun log-handler (domain log-level message)
 193 (def-callback log-handler (c-call:void (domain c-call:c-string)
 194                                        (log-level c-call:int)
 195                                        (message c-call:c-string))
 196   (error "~A: ~A" domain message))
 197
 198 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
 199
 200
 201 ;;;; Convenient macros
 202
 203 (defmacro def-callback-marshal (name (return-type &rest args))
 204   (let ((names (loop
 205                 for arg in args
 206                 collect (if (atom arg) (gensym) (first arg))))
 207         (types (loop
 208                 for arg in args
 209                 collect (if (atom arg) arg (second arg)))))
 210     `(defcallback ,name (,return-type ,@(mapcar #'list names types)
 211                          (callback-id unsigned-int))
 212       (invoke-callback callback-id ',return-type ,@names))))
 213
 214 (defmacro with-callback-function ((id function) &body body)
 215   `(let ((,id (register-callback-function ,function)))
 216     (unwind-protect
 217          (progn ,@body)
 218       (destroy-user-data ,id))))
 219
 220