gtk/gtk.main_loop_events.lisp

   1 (in-package :gtk)
   2
   3 (defcfun gtk-init-check :boolean
   4   (argc (:pointer :int))
   5   (argv (:pointer (:pointer :string))))
   6
   7 (defun gtk-init ()
   8   (gtk-init-check (foreign-alloc :int :initial-element 0)
   9                   (foreign-alloc :string :initial-contents '("/usr/bin/sbcl")))
  10   #+nil(with-foreign-objects ((argc :int)
  11                          (argv '(:pointer :string) 1))
  12     (setf (mem-ref argc :int) 0
  13           (mem-ref argv '(:pointer :string)) (foreign-alloc :string :count 1
  14                                                             :initial-element "/usr/bin/sbcl"))
  15     (unwind-protect
  16          (unless (gtk-init-check argc argv)
  17            (error "Cannot initialize Gtk+"))
  18       (foreign-free (mem-ref argv '(:pointer :string))))))
  19
  20 (at-init () (gtk-init))
  21
  22 (defcfun (%gtk-main "gtk_main") :void)
  23
  24 (defun gtk-main ()
  25   (with-gdk-threads-lock (%gtk-main)))
  26
  27 #+thread-support
  28 (progn
  29   (defvar *main-thread* nil)
  30   (defvar *main-thread-level* nil)
  31   (defvar *main-thread-lock* (bt:make-lock "*main-thread* lock"))
  32
  33   (at-finalize ()
  34     (when (and *main-thread* (bt:thread-alive-p *main-thread*))
  35       (bt:destroy-thread *main-thread*)
  36       (setf *main-thread* nil)))
  37
  38   (defun ensure-gtk-main ()
  39     (bt:with-lock-held (*main-thread-lock*)
  40       (when (and *main-thread* (not (bt:thread-alive-p *main-thread*)))
  41         (setf *main-thread* nil))
  42       (unless *main-thread*
  43         (setf *main-thread* (bt:make-thread (lambda () (gtk-main)) :name "cl-gtk2 main thread")
  44               *main-thread-level* 0))
  45       (incf *main-thread-level*))
  46     (values))
  47
  48   (defun join-gtk-main ()
  49     (when *main-thread*
  50       (bt:join-thread *main-thread*)))
  51
  52   (defun leave-gtk-main ()
  53     (bt:with-lock-held (*main-thread-lock*)
  54       (decf *main-thread-level*)
  55       (when (zerop *main-thread-level*)
  56         (gtk-main-quit)))))
  57
  58 #-thread-support
  59 (progn
  60   (defun ensure-gtk-main ()
  61     (gtk-main)
  62     (values))
  63
  64   (defun leave-gtk-main ()
  65     (gtk-main-quit))
  66
  67   (defun join-gtk-main ()))
  68
  69 (export 'ensure-gtk-main)
  70
  71 (export 'leave-gtk-main)
  72
  73 (export 'join-gtk-main)
  74
  75 (defcfun gtk-main-level :uint)
  76
  77 (defcfun gtk-main-quit :void)
  78
  79 (defcfun gtk-grab-add :void
  80   (widget g-object))
  81
  82 (defcfun gtk-grab-get-current g-object)
  83
  84 (defcfun gtk-grab-remove :void
  85   (widget g-object))