mdw@git.distorted.org.uk Git - 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.8 2002-03-24 15:43:16 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 (print 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 (defun after-gc-hook ()
  72   (setf
  73    (extern-alien "callback_trampoline" system-area-pointer)
  74    (make-pointer (kernel:get-lisp-obj-address #'callback-trampoline))
  75    (extern-alien "destroy_user_data" system-area-pointer)
  76    (make-pointer (kernel:get-lisp-obj-address #'destroy-user-data))))
  77
  78 (pushnew 'after-gc-hook ext:*after-gc-hooks*)
  79 (after-gc-hook)
  80
  81
  82 ;;;; Timeouts and idle functions
  83
  84 (defvar *source-callback-marshal*
  85   (system:foreign-symbol-address "source_callback_marshal"))
  86 (defvar *destroy-notify*
  87   (system:foreign-symbol-address "destroy_notify"))
  88
  89 (defbinding (timeout-add "g_timeout_add_full")
  90     (function interval &optional (priority 0)) unsigned-int
  91   (priority int)
  92   (interval unsigned-int)
  93   (*source-callback-marshal* pointer)
  94   ((register-callback-function function) unsigned-long)
  95   (*destroy-notify* pointer))
  96
  97 (defbinding (idle-add "g_idle_add_full")
  98     (function &optional (priority 0)) unsigned-int
  99   (priority int)
 100   (*source-callback-marshal* pointer)
 101   ((register-callback-function function) unsigned-long)
 102   (*destroy-notify* pointer))
 103
 104
 105
 106 ;;;; Signals
 107
 108 (defbinding signal-lookup (name itype) unsigned-int
 109   ((signal-name-to-string name) string)
 110   (itype type-number))
 111
 112 (defbinding signal-name () string
 113   (signal-id unsigned-int))
 114
 115 (defun ensure-signal-id (signal-id instance)
 116   (etypecase signal-id
 117     (integer signal-id)
 118     (string (signal-lookup signal-id (type-number-of instance)))
 119     (symbol (signal-lookup signal-id (type-number-of instance)))))
 120
 121 (defbinding signal-stop-emission (instance signal-id) nil
 122   (instance ginstance)
 123   ((ensure-signal-id signal-id instance) unsigned-int))
 124
 125 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
 126 ;     () unsigned-int
 127 ;   (signal-id unsigned-int)
 128 ;   (closure gclosure))
 129
 130 ; (defbinding signal-remove-emisson-hook () nil
 131 ;   (signal-id unsigned-int)
 132 ;   (hook-id unsigned-int))
 133
 134 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 135     (instance signal-id &key detail blocked) boolean
 136   (instance ginstance)
 137   ((ensure-signal-id signal-id instance) unsigned-int)
 138   ((or detail 0) quark)
 139   (blocked boolean))
 140
 141 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
 142     (instance signal-id closure &key detail after) unsigned-int
 143   (instance ginstance)
 144   ((ensure-signal-id signal-id instance) unsigned-int)
 145   ((or detail 0) quark)
 146   (closure gclosure)
 147   (after boolean))
 148
 149 (defbinding signal-handler-block () nil
 150   (instance ginstance)
 151   (handler unsigned-int))
 152
 153 (defbinding signal-handler-unblock () nil
 154   (instance ginstance)
 155   (handler unsigned-int))
 156
 157 (defbinding signal-handler-disconnect () nil
 158   (instance ginstance)
 159   (handler unsigned-int))
 160
 161
 162 (defmethod signal-connect ((gobject gobject) signal function &key after object)
 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)))