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

Last change on this file since 6 was 6, checked in by gb, 16 years ago

Initial revision

  • 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(def-load-pointers gtk-task ()
56  (%install-periodic-task 'gtk-task
57                          #'(lambda ()
58                              (do* ()
59                                   ((eql (#_gtk_events_pending) 0))
60                              (#_gtk_main_iteration)))
61                        10))
62
63;;; Ensure that GTK's initialized whenever this file's loaded
64;;; and whenever a saved image starts up.  (If an application
65;;; needs to defer GTK initialization, *GTK-AUTO-INITIALIZE*
66;;; can be set to nil to suppress this behavior.)
67
68;;; Used in error reporting and to provide default window titles
69(defvar *gtk-init-application-name* "OpenMCL")
70
71(defvar *gtk-init-arguments* ())
72(defvar *gtk-auto-initialize* t)
73
74(def-load-pointers initialize-gtk ()
75  (when *gtk-auto-initialize*
76    (apply #'gtk-init *gtk-init-application-name* *gtk-init-arguments*)))
77
Note: See TracBrowser for help on using the repository browser.