source: trunk/ccl/library/openmcl-gtk-support.lisp @ 5834

Last change on this file since 5834 was 5834, checked in by gb, 13 years ago

Conditionalize out the event-polling task.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 2.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2001 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   Opensourced MCL is free software; you can redistribute it and/or
7;;;   modify it under the terms of the GNU Lesser General Public
8;;;   License as published by the Free Software Foundation; either
9;;;   version 2.1 of the License, or (at your option) any later version.
10;;;
11;;;   Opensourced MCL is distributed in the hope that it will be useful,
12;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;;;   Lesser General Public License for more details.
15;;;
16;;;   You should have received a copy of the GNU Lesser General Public
17;;;   License along with this library; if not, write to the Free Software
18;;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19;;;
20;;;   The LLGPL is also available online at
21;;;   http://opensource.franz.com/preamble.html
22
23(in-package "CCL")
24
25(eval-when (:compile-toplevel :execute)
26  (use-interface-dir :GTK))
27
28(eval-when (:compile-toplevel :load-toplevel :execute)
29  ;; I don't know why it's necessary to explicitly open
30  ;; libgdk.so (which transitively opens half a dozen
31  ;; other libraries), while opening libgtk.so by itself
32  ;; would complain about unresolved symbols from libgdk.
33  (dolist (lib '("libgdk.so" "libgtk.so"))
34    (open-shared-library lib)))
35
36
37;;; All arguments (including the first, required one) should
38;;; be strings.  This is supposed to be called from a C main
39;;; function; it picks off gtk+-specific arguments from the
40;;; caller's argv and deletes them from that C string vector.
41;;; I don't know how to suppress any messages that this call
42;;; might generate.
43(defun gtk-init (arg &rest args)
44  (declare (dynamic-extent args))
45  (push arg args)
46  (with-string-vector (argv args)
47    (rlet ((argvp (* t))
48           (argcp :signed))
49     (setf (%get-ptr argvp) argv
50           (%get-long argcp) (length args))
51       (#_gtk_init argcp argvp))))
52
53;;; Run this every 10 ticks.  (There seem to be about 100 ticks
54;;; per second.)
55#-openmcl-native-threads
56(def-load-pointers gtk-task ()
57  (%install-periodic-task 'gtk-task
58                          #'(lambda ()
59                              (do* ()
60                                   ((eql (#_gtk_events_pending) 0))
61                              (#_gtk_main_iteration)))
62                        10))
63
64;;; Ensure that GTK's initialized whenever this file's loaded
65;;; and whenever a saved image starts up.  (If an application
66;;; needs to defer GTK initialization, *GTK-AUTO-INITIALIZE*
67;;; can be set to nil to suppress this behavior.)
68
69;;; Used in error reporting and to provide default window titles
70(defvar *gtk-init-application-name* "OpenMCL")
71
72(defvar *gtk-init-arguments* ())
73(defvar *gtk-auto-initialize* t)
74
75(def-load-pointers initialize-gtk ()
76  (when *gtk-auto-initialize*
77    (apply #'gtk-init *gtk-init-application-name* *gtk-init-arguments*)))
78
Note: See TracBrowser for help on using the repository browser.