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.13 2004-11-07 01:23:38 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 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
  82   (callback-trampoline callback-id 0 nil (make-pointer 0)))
  83
  84 (defbinding (timeout-add "g_timeout_add_full")
  85     (function interval &optional (priority 0)) unsigned-int
  86   (priority int)
  87   (interval unsigned-int)
  88   (*source-callback-marshal* pointer)
  89   ((register-callback-function function) unsigned-long)
  90   ((callback %destroy-user-data) pointer))
  91
  92 (defbinding (idle-add "g_idle_add_full")
  93     (function &optional (priority 0)) unsigned-int
  94   (priority int)
  95   (*source-callback-marshal* pointer)
  96   ((register-callback-function function) unsigned-long)
  97   ((callback %destroy-user-data) pointer))
  98
  99
 100
 101 ;;;; Signals
 102
 103 (defbinding signal-lookup (name itype) unsigned-int
 104   ((signal-name-to-string name) string)
 105   (itype type-number))
 106
 107 (defbinding signal-name () string
 108   (signal-id unsigned-int))
 109
 110 (defun ensure-signal-id (signal-id instance)
 111   (etypecase signal-id
 112     (integer signal-id)
 113     (string (signal-lookup signal-id (type-number-of instance)))
 114     (symbol (signal-lookup signal-id (type-number-of instance)))))
 115
 116 (defbinding signal-stop-emission (instance signal-id) nil
 117   (instance ginstance)
 118   ((ensure-signal-id signal-id instance) unsigned-int))
 119
 120 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
 121 ;     () unsigned-int
 122 ;   (signal-id unsigned-int)
 123 ;   (closure gclosure))
 124
 125 ; (defbinding signal-remove-emisson-hook () nil
 126 ;   (signal-id unsigned-int)
 127 ;   (hook-id unsigned-int))
 128
 129 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 130     (instance signal-id &key detail blocked) boolean
 131   (instance ginstance)
 132   ((ensure-signal-id signal-id instance) unsigned-int)
 133   ((or detail 0) quark)
 134   (blocked boolean))
 135
 136 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
 137     (instance signal-id closure &key detail after) unsigned-int
 138   (instance ginstance)
 139   ((ensure-signal-id signal-id instance) unsigned-int)
 140   ((or detail 0) quark)
 141   (closure gclosure)
 142   (after boolean))
 143
 144 (defbinding signal-handler-block () nil
 145   (instance ginstance)
 146   (handler unsigned-int))
 147
 148 (defbinding signal-handler-unblock () nil
 149   (instance ginstance)
 150   (handler unsigned-int))
 151
 152 (defbinding signal-handler-disconnect () nil
 153   (instance ginstance)
 154   (handler unsigned-int))
 155
 156
 157 (defmethod signal-connect ((gobject gobject) signal function &key after object)
 158 "Connects a callback function to a signal for a particular object. If :OBJECT
 159  is T, the object connected to is passed as the first argument to the callback
 160  function, or if :OBJECT is any other non NIL value, it is passed as the first
 161  argument instead. If :AFTER is non NIL, the handler will be called after the
 162  default handler of the signal."
 163   (let ((callback-id
 164          (make-callback-closure
 165           (cond
 166            ((or (eq object t) (eq object gobject)) function)
 167            ((not object)
 168             #'(lambda (&rest args) (apply function (cdr args))))
 169            (t
 170             #'(lambda (&rest args) (apply function object (rest args))))))))
 171     (signal-connect-closure gobject signal callback-id :after after)))
 172
 173
 174 ;;; Message logging
 175
 176 ;; TODO: define and signal conditions based on log-level
 177 ;(defun log-handler (domain log-level message)
 178 (def-callback log-handler (c-call:void (domain c-call:c-string)
 179                                        (log-level c-call:int)
 180                                        (message c-call:c-string))
 181   (error "~A: ~A" domain message))
 182
 183 (setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))