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.10 2004-10-30 19:26:02 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24
  25 ;;;; Closures
  26
  27 (deftype gclosure () 'pointer)
  28
  29 (defbinding lisp-callback-closure-new () gclosure
  30   (callback-id unsigned-int))
  31
  32 (defun register-callback-function (function)
  33   (check-type function (or null symbol function))
  34   (register-user-data function))
  35
  36 (defun make-callback-closure (function)
  37   (lisp-callback-closure-new (register-callback-function function)))
  38
  39
  40 ;;;; Callback mechanism
  41
  42 (defun callback-trampoline (callback-id params return-value)
  43   (let* ((return-type (unless (null-pointer-p return-value)
  44                         (gvalue-type return-value)))
  45          (args nil)
  46          (callback-function (find-user-data callback-id)))
  47
  48     (destructuring-bind (nparams . param-values) params
  49       (dotimes (n nparams)
  50         (push (gvalue-get (sap+ param-values (* n +gvalue-size+))) args)))
  51
  52     (labels ((invoke-callback ()
  53                (restart-case
  54                    (unwind-protect
  55                        (let ((result (apply callback-function (reverse args))))
  56                          (when return-type
  57                            (gvalue-set return-value result))))
  58
  59                  (continue nil :report "Return from callback function"
  60                   (when return-type
  61                     (format
  62                      *query-io*
  63                      "Enter return value of type ~S: "
  64                      return-type)
  65                     (force-output *query-io*)
  66                     (gvalue-set return-value (eval (read *query-io*)))))
  67                  (re-invoke nil :report "Re-invoke callback function"
  68                   (invoke-callback)))))
  69       (invoke-callback))))
  70
  71
  72 ;;;; Timeouts and idle functions
  73
  74 (defvar *source-callback-marshal*
  75   (system:foreign-symbol-address "source_callback_marshal"))
  76 (defvar *destroy-notify*
  77   (system:foreign-symbol-address "destroy_notify"))
  78
  79 (defbinding (timeout-add "g_timeout_add_full")
  80     (function interval &optional (priority 0)) unsigned-int
  81   (priority int)
  82   (interval unsigned-int)
  83   (*source-callback-marshal* pointer)
  84   ((register-callback-function function) unsigned-long)
  85   (*destroy-notify* pointer))
  86
  87 (defbinding (idle-add "g_idle_add_full")
  88     (function &optional (priority 0)) unsigned-int
  89   (priority int)
  90   (*source-callback-marshal* pointer)
  91   ((register-callback-function function) unsigned-long)
  92   (*destroy-notify* pointer))
  93
  94
  95
  96 ;;;; Signals
  97
  98 (defbinding signal-lookup (name itype) unsigned-int
  99   ((signal-name-to-string name) string)
 100   (itype type-number))
 101
 102 (defbinding signal-name () string
 103   (signal-id unsigned-int))
 104
 105 (defun ensure-signal-id (signal-id instance)
 106   (etypecase signal-id
 107     (integer signal-id)
 108     (string (signal-lookup signal-id (type-number-of instance)))
 109     (symbol (signal-lookup signal-id (type-number-of instance)))))
 110
 111 (defbinding signal-stop-emission (instance signal-id) nil
 112   (instance ginstance)
 113   ((ensure-signal-id signal-id instance) unsigned-int))
 114
 115 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
 116 ;     () unsigned-int
 117 ;   (signal-id unsigned-int)
 118 ;   (closure gclosure))
 119
 120 ; (defbinding signal-remove-emisson-hook () nil
 121 ;   (signal-id unsigned-int)
 122 ;   (hook-id unsigned-int))
 123
 124 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 125     (instance signal-id &key detail blocked) boolean
 126   (instance ginstance)
 127   ((ensure-signal-id signal-id instance) unsigned-int)
 128   ((or detail 0) quark)
 129   (blocked boolean))
 130
 131 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
 132     (instance signal-id closure &key detail after) unsigned-int
 133   (instance ginstance)
 134   ((ensure-signal-id signal-id instance) unsigned-int)
 135   ((or detail 0) quark)
 136   (closure gclosure)
 137   (after boolean))
 138
 139 (defbinding signal-handler-block () nil
 140   (instance ginstance)
 141   (handler unsigned-int))
 142
 143 (defbinding signal-handler-unblock () nil
 144   (instance ginstance)
 145   (handler unsigned-int))
 146
 147 (defbinding signal-handler-disconnect () nil
 148   (instance ginstance)
 149   (handler unsigned-int))
 150
 151
 152 (defmethod signal-connect ((gobject gobject) signal function &key after object)
 153 "Connects a callback function to a signal for a particular object. If :OBJECT
 154  is T, the object connected to is passed as the first argument to the callback
 155  function, or if :OBJECT is any other non NIL value, it is passed as the first
 156  argument instead. If :AFTER is non NIL, the handler will be called after the
 157  default handler of the signal."
 158   (let ((callback-id
 159          (make-callback-closure
 160           (cond
 161            ((or (eq object t) (eq object gobject)) function)
 162            ((not object)
 163             #'(lambda (&rest args) (apply function (cdr args))))
 164            (t
 165             #'(lambda (&rest args) (apply function object (rest args))))))))
 166     (signal-connect-closure gobject signal callback-id :after after)))
 167
 168
 169 ;;; Message logging
 170
 171 ;; TODO: define and signal conditions based on log-level
 172 (defun log-handler (domain log-level message)
 173   (declare (ignore log-level))
 174   (error "~A: ~A" domain message))
 175
 176
 177 ;;;
 178
 179 (defun after-gc-hook ()
 180   (setf
 181    (extern-alien "callback_trampoline" system-area-pointer)
 182    (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline))
 183    (extern-alien "destroy_user_data" system-area-pointer)
 184    (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data))
 185    (extern-alien "log_handler" system-area-pointer)
 186    (make-pointer (kernel:get-lisp-obj-address #'log-handler))))
 187
 188 (pushnew 'after-gc-hook ext:*after-gc-hooks*)
 189 (after-gc-hook)