source: branches/qres/ccl/library/openmcl-gtk-support.lisp @ 15278

Last change on this file since 15278 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 2.6 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2001-2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
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 :GTK2))
27
28(eval-when (:compile-toplevel :load-toplevel :execute)
29  (open-shared-library "libgnomeui-2.so"))
30
31
32;;; All arguments (including the first, required one) should
33;;; be strings.  This is supposed to be called from a C main
34;;; function; it picks off gtk+-specific arguments from the
35;;; caller's argv and deletes them from that C string vector.
36;;; I don't know how to suppress any messages that this call
37;;; might generate.
38(defun gtk-init (arg &rest args)
39  (declare (dynamic-extent args))
40  (push arg args)
41  (with-string-vector (argv args)
42    (rlet ((argvp (* t))
43           (argcp :signed))
44     (setf (%get-ptr argvp) argv
45           (%get-long argcp) (length args))
46       (#_gtk_init argcp argvp))))
47
48;;; Run this every 10 ticks.  (There seem to be about 100 ticks
49;;; per second.)
50#-openmcl-native-threads
51(def-load-pointers gtk-task ()
52  (%install-periodic-task 'gtk-task
53                          #'(lambda ()
54                              (do* ()
55                                   ((eql (#_gtk_events_pending) 0))
56                              (#_gtk_main_iteration)))
57                        10))
58
59;;; Ensure that GTK's initialized whenever this file's loaded
60;;; and whenever a saved image starts up.  (If an application
61;;; needs to defer GTK initialization, *GTK-AUTO-INITIALIZE*
62;;; can be set to nil to suppress this behavior.)
63
64;;; Used in error reporting and to provide default window titles
65(defvar *gtk-init-application-name* "Clozure CL")
66
67(defvar *gtk-init-arguments* ())
68(defvar *gtk-auto-initialize* t)
69
70(def-load-pointers initialize-gtk ()
71  (when *gtk-auto-initialize*
72    (apply #'gtk-init *gtk-init-application-name* *gtk-init-arguments*)))
73
Note: See TracBrowser for help on using the repository browser.