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.6 2002/03/19 17:09:15 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 (defun signal-name-to-string (name)
 109   (substitute #\_ #\- (string-downcase (string name))))
 110
 111 (defbinding signal-lookup (name itype) unsigned-int
 112   ((signal-name-to-string name) string)
 113   (itype type-number))
 114
 115 (defbinding signal-name () string
 116   (signal-id unsigned-int))
 117
 118 (defun ensure-signal-id (signal-id instance)
 119   (etypecase signal-id
 120     (integer signal-id)
 121     (string (signal-lookup signal-id (type-number-of instance)))
 122     (symbol (signal-lookup signal-id (type-number-of instance)))))
 123
 124 (defbinding signal-stop-emission (instance signal-id) nil
 125   (instance ginstance)
 126   ((ensure-signal-id signal-id instance) unsigned-int))
 127
 128 ; (defbinding (signal-add-emisson-hook "g_signal_add_emission_hook_full")
 129 ;     () unsigned-int
 130 ;   (signal-id unsigned-int)
 131 ;   (closure gclosure))
 132
 133 ; (defbinding signal-remove-emisson-hook () nil
 134 ;   (signal-id unsigned-int)
 135 ;   (hook-id unsigned-int))
 136
 137 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
 138     (instance signal-id &key detail blocked) boolean
 139   (instance ginstance)
 140   ((ensure-signal-id signal-id instance) unsigned-int)
 141   ((or detail 0) quark)
 142   (blocked boolean))
 143
 144 (defbinding (signal-connect-closure "g_signal_connect_closure_by_id")
 145     (instance signal-id closure &key detail after) unsigned-int
 146   (instance ginstance)
 147   ((ensure-signal-id signal-id instance) unsigned-int)
 148   ((or detail 0) quark)
 149   (closure gclosure)
 150   (after boolean))
 151
 152 (defbinding signal-handler-block () nil
 153   (instance ginstance)
 154   (handler unsigned-int))
 155
 156 (defbinding signal-handler-unblock () nil
 157   (instance ginstance)
 158   (handler unsigned-int))
 159
 160 (defbinding signal-handler-disconnect () nil
 161   (instance ginstance)
 162   (handler unsigned-int))
 163
 164
 165 (defmethod signal-connect ((gobject gobject) signal function &rest args &key after object)
 166   (declare (ignore signal args after))
 167   (cond
 168    ((or (eq object t) (eq object gobject)) function)
 169    ((not object)
 170     #'(lambda (&rest args) (apply function (cdr args))))
 171    (t
 172     #'(lambda (&rest args) (apply function object (rest args))))))
 173
 174
 175 (defmethod signal-connect :around ((gobject gobject) signal function
 176                                    &key after object)
 177   (declare (ignore object))
 178   (let ((callback-id (make-callback-closure (call-next-method))))
 179     (signal-connect-closure gobject signal callback-id :after after)))