From: Matt Birkholz Date: Fri, 15 May 2009 07:09:40 +0000 (-0700) Subject: GNOME Toolkit Interface, as released 2009-03-18. X-Git-Tag: 20090517-Gtk~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3c02d3c8f2a0907881766aba7b4f7bead015f4d7;p=mit-scheme.git GNOME Toolkit Interface, as released 2009-03-18. * doc/Makefile.in: Include gtk in SUBDIRS. * doc/configure.ac: Include gtk/Makefile. * doc/gtk/Makefile.in: Build the Users' Manual for the GTK. * doc/gtk/gtk.texinfo: The Users' Manual for the GTK. * doc/index.html: Include mit-scheme-gtk/index.html. * src/Clean.sh: Clean up new symlinks config.sub and config.guess, used by AZ_CANONICAL_HOST in configure.ac. * src/Makefile.in: Added new file category "FFIS". Include gtk in FFIS. `make generate' in FFIS before compiling their Scheme source, so they can C-include later -- much later. `make build' in FFIS after dumping the new bands, so the FFIS are compiled with the shims installed in lib/lib/. The new bands are not strictly necessary, but they complete lib/lib/, so the commandline in FFI Makefiles can be this simple: `../microcode/scheme --library ../lib'. Added similar commands to the all-liarc target, though I have yet to build a lairc-based system. Install conses.png in lib/ for the scm-layout-demo. * src/README.txt: Describe gtk as part of the core. * src/Setup.sh: Include gtk in INSTALLED_SUBDIRS. Include rcs in OTHER_SUBDIRS, so `make tags' does not fail. Symlink to microcode/config.sub and config.guess, so configure.ac can share with microcode/configure.ac. Create lib/lib/prgtkio.so and lib/gtk symlinks too. * src/configure.ac: Include AC_CANONICAL_HOST and related C compilation variables, esp. SHIM_CFLAGS and SHIM_LDFLAGS, shared with microcode/configure.ac via microcode/achost.ac. Echo the create-makefiles.sh commandline. Generate gtk/Makefile. Added gtk to liarc BUNDLEs. * src/etc/create-makefiles.sh: Include gtk in BUNDLES. * src/etc/optiondb.scm: Define loadable option GTK. * src/etc/std-makefile-prefix: Added C compilation variables, esp. COMPILE_SHIM and LINK_SHIM. * src/gtk/Clean.sh: Clean up after building the shim. * src/gtk/Includes/: cairo-xlib.cdecl, cairo.cdecl, gdk-pixbuf-core.cdecl, gdk-pixbuf-loader.cdecl, gdk-pixbuf.cdecl, gdk.cdecl, gdkcolor.cdecl, gdkcursor.cdecl, gdkdrawable.cdecl, gdkevents.cdecl, gdkfont.cdecl, gdkgc.cdecl, gdkkeys.cdecl, gdkkeysyms.cdecl, gdkrgb.cdecl, gdktypes.cdecl, gdkwindow.cdecl, genums.cdecl, gerror.cdecl, glib.cdecl, gobject.cdecl, gparam.cdecl, gparamspecs.cdecl, gquark.cdecl, gsignal.cdecl, gtk.cdecl, gtkadjustment.cdecl, gtkbox.cdecl, gtkenums.cdecl, gtkobject.cdecl, gtkstyle.cdecl, gtktypeutils.cdecl, gtkvbox.cdecl, gtkwidget.cdecl, gtype.cdecl, gtypes.cdecl, gvalue.cdecl, gvaluetypes.cdecl, pango-context.cdecl, pango-font.cdecl, pango-layout.cdecl, pango-types.cdecl, pango.cdecl, pangocairo.cdecl: C declarations corresponding to SOME of /usr/include/g{lib,tk}-2.0/**/*.h. * src/gtk/Makefile-fragment: Generate the gtk shim, and build Scheme code that uses it. Keep the ScmWidget methods in a .c.stay file so it does not get cleaned up by `Clean.sh maintainer-clean' nor `Clean.sh c-clean'. Create conses.png from conses.png.uu because I cannot distribute a binary in a patchfile. * src/gtk/Tags.sh: Include auxiliary ScmWidget code, and NOT gtk-const.scm. * src/gtk/compile.scm: Build the GTK system. Expects the shim to be available in ../lib. * src/gtk/conses.png.uu: Because I cannot distribute a binary in a patchfile. * src/gtk/: demo.scm, gtk-ev.scm, hello.scm, pango-cairo.scm: Peripheral hacks. * src/gtk/: gobject.scm, gtk-object.scm, gtk.pkg, gtk.scm, load.scm, main.scm, scm-layout.scm, scm-widget.scm: The core of the GTK system. * src/gtk/gtk.cdecl: The C types and externs needed in the GTK shim. * src/gtk/gtk-shim.h: C declarations for gtk-shim.c, gtk-const.c and scmwidget.c. Includes the ScmWidget and ScmWidgetClass struct declarations. * src/gtk/scmwidget.c.stay: ScmWidget methods. The ".stay" suffix keeps this code from being "cleaned up" by `Clean.sh maintainer-clean' or `Clean.sh c-clean'. * src/gtk/thread.scm: The Scheme thread that "runs" the toolkit. * src/microcode/configure.ac, src/microcode/achost.ac: Moved the AC_CANONICAL_HOST code from microcode/configure.ac to microcode/achost.ac, so it can be shared with configure.ac. Implement a --with-gtk argument. * src/microcode/makegen/: Makefile.in.in, files-optional.scm: Added new module prgtkio.so. * src/microcode/makegen/makeinit.sh: Use --batch-mode and `mit-scheme' instead of `scheme'. * src/microcode/osio.h, microcode/prosio.c: Changed the declarations of OS_select_registry_entry and arg_select_registry so they can be used in the new prgtkio module. * src/microcode/prgtkio.c: The prgtkio module. New primitives that arrange to run Scheme in an idle task of a GMainLoop. * src/microcode/utabmd.sh: Use --batch-mode and `mit-scheme'. Echo the commandline. * src/microcode/uxio.c: Added an OS_select_registry_entry function that extracts a file descriptor and a mode from an indexed registry entry, for prgtkio. * src/runtime/Makefile-fragment: Install runtime-*.pkd so lusers can cref imports. * src/runtime/thread.scm: Added some tracing, conditioned on a tracing? binding. --- diff --git a/doc/Makefile.in b/doc/Makefile.in index 59e772726..ebbdf71be 100644 --- a/doc/Makefile.in +++ b/doc/Makefile.in @@ -66,7 +66,7 @@ pdfdir = @pdfdir@ psdir = @psdir@ INST_TARGETS = @INST_TARGETS@ -SUBDIRS = ffi imail ref-manual sos user-manual +SUBDIRS = ffi gtk imail ref-manual sos user-manual DISTCLEAN_FILES = Makefile make-common config.log config.status all: diff --git a/doc/configure.ac b/doc/configure.ac index 908fc513d..196659f19 100644 --- a/doc/configure.ac +++ b/doc/configure.ac @@ -82,6 +82,7 @@ AC_CONFIG_FILES([ Makefile make-common ffi/Makefile + gtk/Makefile imail/Makefile ref-manual/Makefile sos/Makefile diff --git a/doc/gtk/Makefile.in b/doc/gtk/Makefile.in new file mode 100644 index 000000000..934f693b5 --- /dev/null +++ b/doc/gtk/Makefile.in @@ -0,0 +1,12 @@ +# $Id: $ +# doc/gtk/Makefile.in + +@SET_MAKE@ +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ + +SOURCES = gtk.texinfo +TARGET_ROOT = mit-scheme-gtk + +include $(top_srcdir)/make-common diff --git a/doc/gtk/gtk.texinfo b/doc/gtk/gtk.texinfo new file mode 100644 index 000000000..b9bb9794a --- /dev/null +++ b/doc/gtk/gtk.texinfo @@ -0,0 +1,764 @@ +\input texinfo @c -*-Texinfo-*- +@comment $Id: $ +@comment %**start of header +@setfilename mit-scheme-gtk +@settitle Gtk Users' Manual +@comment %**end of header + +@copying +The users' manual for a Gtk interface for MIT/GNU Scheme. + +Copyright @copyright{} 2008, 2009 Matthew Birkholz + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.2 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,'' +and with the Back-Cover Texts as in (a) below. A copy of the +license is included in the section entitled ``GNU Free Documentation +License.'' + +(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify +this GNU Manual, like GNU software. Copies published by the Free +Software Foundation raise funds for GNU development.'' +@end quotation +@end copying + +@dircategory Programming Languages +@direntry +* Gtk Users': (mit-scheme-gtk). MIT/GNU Scheme GNOME toolkit +@end direntry + +@titlepage +@title The Gtk Users' Manual +@subtitle for Schemely access to the GNOME toolkit +@subtitle for MIT/GNU Scheme version 7.7.90+ +@author by Matt Birkholz (@email{birkholz@@alum.mit.edu}) +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@ifnottex +@node Top, Introduction, (dir), (dir) +@top Gtk Users' Manual + +@insertcopying +@end ifnottex + +@menu +* Introduction:: Emphasizing how @emph{little} of GNOME is wrapped. +* Hello World:: Not your primitive ``Hello, world!'' example. +* Gtk-Event-Viewer:: A simple Scheme widget. GtkEv translated into Scheme/FFI. +* Scm-Layout:: A Scheme canvas widget. +* GNU Free Documentation License:: +@end menu + + +@node Introduction, Hello World, Top, Top +@chapter Introduction + +The Gtk system is a collection of Scheme data types and procedures +that provide a simple, Schemely interface to the GNOME toolkit(s). +Toolkit objects are represented in Scheme by instances of the +@code{} class. Toolkit functions are wrapped by Scheme +procedures that translate to and from Scheme data types. + +When the Gtk system loads it starts a toolkit main loop with Scheme +attached as an custom idle task. The main loop then re-starts Scheme, +which creates a thread to ``run'' the toolkit (actually, return to +it). Thus Scheme threads multitask with the toolkit. Scheme runs as +an idle task in the toolkit, and the toolkit runs in a Scheme thread. +A program using the Gtk system does not call @code{gtk_init} nor +@code{gtk_main}. It need only create toolkit objects and attach +signal handlers to them. The hello program is a simple example. +(@xref{Hello World}.) + +Very little of the GNOME toolkit API has been wrapped, and there is no +intention to wrap everything. The @file{gtk.so} (the shared object +shim) is intended to stay small and focused, and @emph{not} include +every convenience function fancied by a C programmer. It does not +wrap nor intern nor register a gc cleanup for every GObject pointer +accessed by Scheme. To see what is available, refer to the +@file{gtk.pkg} description. + +It is likely the user will want to extend this system with additional +wrappings. The existing wrappers are the best examples of +what needs to be done. They are written in Scheme/FFI --- Scheme +extended with the accompanying FFI. +@ifnothtml +@xref{Top,, Introduction, mit-scheme-ffi, FFI Users' Manual}. +@end ifnothtml +@ifhtml +See the @uref{../FFI/mit-scheme-ffi.html,, FFI Users' Manual}. +@end ifhtml + +@unnumberedsec Procedures + +The procedure wrappers are often trivial convenience functions that do +type checking and conversion, and hide the details of the C API. For +example, a GtkLabel's text is retrieved in two steps: a toolkit +function returns an alien address, and the C string at that address is +copied into the heap. + +@smallexample + (let ((retval (make-alien '|gchar|))) + (C-call "gtk_label_get_text" retval (gobject-alien label)) + (c-peek-cstring retval)) +@result{} "!dlrow ,olleH" +@end smallexample + +The @code{gtk-label-get-text} wrapper procedure hides these details. + +@smallexample + (gtk-label-get-text label) +@result{} "!dlrow ,olleH" +@end smallexample + +Using such wrappings, the primitive ``Hello, world!'' example in the +FFI system +@ifnothtml +(@pxref{Top,, Hello World, mit-scheme-ffi, FFI Users' Manual}) +@end ifnothtml +@ifhtml +(@uref{mit-scheme-ffi.html#Hello%20World,, here}) +@end ifhtml +can be re-written in a more pleasantly Scheme-like way +@ifnothtml +(@pxref{Hello World}). +@end ifnothtml +@ifhtml +(@uref{#Hello%20World,, here}). +@end ifhtml + +Note that the @code{C-call} syntax above cannot be expanded without +first @code{C-include}ing a declaration of @code{gtk_label_get_text} +--- something like the following. + +@smallexample + (extern (* (const gchar)) gtk_label_get_text (label (* GtkLabel))) +@end smallexample + +@unnumberedsec GObjects + +In the example call to @code{gtk-label-get-text} above, a Scheme +object represents the GtkLabel. It is a +@code{} instance, whose class is a specialization of the +abstract @code{} class. Here is the class hierarchy +for @code{}, a GtkContainer widget. + +@table @code + +@item +Wraps a GtkButton widget. + +@item +Adds a list of ``children'' to be implicitly destroyed along with +their parent. + +@item +Adds a ``parent'' slot. + +@item +Adds a ``destroyed?'' flag and the generic function +@code{gtk-object-destroy} in support of the GtkObject notion of +``destruction''. + +@item +Instances of this class have two slots. ``Alien'' is the address of +the toolkit GObject. ``Signals'' is an alist of signal handlers to be +disconnected when the gobject is finalized. + +@end table + +@unnumberedsec GObject Properties + +The @code{gobject-get-property} and @code{gobject-set-properties} +procedures are an attempt to use Glib's introspection facilities to +automatically determine the type of a property's value and construct +an appropriate reflection of its value in Scheme. They have not been +tested @emph{at all}. + +@unnumberedsec Scheme Widgets + +A Scheme widget is a @code{GtkWidget} that calls back to Scheme to +implement many of its methods. It is represented in Scheme by a +@code{}. As with other gtk-widgets, its signal +and method callbacks are tracked and de-registered when it is +destroyed (finalized). It is represented in the toolkit by a +@code{ScmWidget}, a direct subtype of @code{GtkWidget} (not a +@code{GtkContainer}, yet), which functions mainly as a big bag of +widget method callback hooks. The hooks are set via calls to +procedures like @code{set-scm-widget-expose!}. @code{} +(@pxref{Gtk-Event-Viewer}) is a simple example --- a straightforward +translation of Havoc Pennington's GtkEv (from +@uref{http://developer.gnome.org/doc/GGAD/,, GGAD}). + +@code{} (@pxref{Scm-Layout}) is a more sophisticated +Scheme widget that displays a view of a Scheme canvas. + +@unnumberedsec The @code{(gtk)} Package + +All of the Gtk system's public bindings are in the @code{(gtk)} +package --- not exported to the global environment. It is assumed +that modules mucking about with the toolkit will be loaded in a +@code{(gtk)} subpackage where they will define Gtk-specific +procedures, such as methods for generics imported from a more abstract +interface package. + +@unnumberedsec Debugging + +The Scheme machine is currently built with some debugging facilities, +including a time slice counter. To see the counter, evaluate the +following expression: + +@smallexample + (gtk-time-slice-window! #t) + (gtk-time-slice-window! #f) + (gtk-time-slice-window?) +@end smallexample + +The second and third expressions take down the small window, and +programmatically tell you whether one is active, respectively. +The window shows a running count of the number of times the toolkit has +yielded to Scheme (or vice versa), and the channels currently being +polled by Scheme. This counter can be slowed or stopped by evaluating +the first or second expression below. + +@smallexample + (set-thread-timer-interval! 1000) + (set-thread-timer-interval! #f) +@end smallexample + + +@node Hello World, Gtk-Event-Viewer, Introduction, Top +@chapter Hello World + +To run the example ``Hello, World!'' program, enter the following +command lines in the @file{src/gtk} directory of the source +distribution. + +@smallexample + mit-scheme + (load-option 'Gtk) + (ge '(gtk)) + (load "hello") + (hello) +@end smallexample + +Here is the code. + +@verbatiminclude ../../src/gtk/hello.scm + + +@node Gtk-Event-Viewer, Scm-Layout, Hello World, Top +@chapter Gtk-Event-Viewer + +The Gtk system includes a simple Scheme widget, a translation of Havoc +Pennington's GtkEv (from @uref{http://developer.gnome.org/doc/GGAD/, +GGAD}. The widget demonstrates callouts running within callbacks +running within callouts. For example, while calling out to +@code{gdk_window_show_all}, the toolkit calls the Scheme widget's +realize method, which calls out again to @code{gdk_window_new}. + +Enter these 3 lines to create this widget. + +@smallexample + mit-scheme + (load-option 'GTK) + (gtk-event-viewer) +@end smallexample + +The code can be found in @file{gtk-ev.scm}. + + +@node Scm-Layout, GNU Free Documentation License, Gtk-Event-Viewer, Top +@chapter Scm-Layout + +The Gtk system provides a canvas abstraction --- a logical space in +which items like text or boxes are drawn. This is a logical device +canvas; all positions and dimensions are in integral pixels. The +items are Scheme objects, and are ``drawn'' or ``undrawn'' by adding +or removing them from a @code{}. Each @code{} +has a position on the canvas and a position in the drawing's display +list. That latter determines the order in which the drawn item is +(re)drawn. An item can be drawn in all views or conditionally, such +that it only appears in specific views. + +A view of a drawing is displayed by a @code{} widget. +Multiple widgets can display different views of a shared drawing. +A @code{} widget is more of a GtkDrawingArea with +scrollbar support than a full-blown GtkLayout at the moment, mainly +because ScmWidget is not a GtkContainer. + +Animation (editing) is supported through the standard Gtk mechanism. +Each change to a drawing ``invalidates'' areas of affected widgets. +The toolkit batches up the damaged areas, repairing them via the +expose event handlers. + +There are just a few specializations of @code{} so far: +@code{}, @code{}, @code{}, +@code{} and @code{}. + +A demo of two @code{} widgets displaying one canvas is +provided. The canvas contains text, horizontal and vertical lines, +and an image. It also contains animated boxes that blink and follow +the mouse. Enter these 3 lines to create this widget. + +@smallexample + mit-scheme + (load-option 'Gtk) + (scm-layout-demo) +@end smallexample + +The code can be found in @file{demo.scm}. + + +@node GNU Free Documentation License, , Scm-Layout, Top +@appendix GNU Free Documentation License + +@center Version 1.2, November 2002 + +@display +Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc. +51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA + +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +@end display + +@enumerate 0 +@item +PREAMBLE + +The purpose of this License is to make a manual, textbook, or other +functional and useful document @dfn{free} in the sense of freedom: to +assure everyone the effective freedom to copy and redistribute it, +with or without modifying it, either commercially or noncommercially. +Secondarily, this License preserves for the author and publisher a way +to get credit for their work, while not being considered responsible +for modifications made by others. + +This License is a kind of ``copyleft'', which means that derivative +works of the document must themselves be free in the same sense. It +complements the GNU General Public License, which is a copyleft +license designed for free software. + +We have designed this License in order to use it for manuals for free +software, because free software needs free documentation: a free +program should come with manuals providing the same freedoms that the +software does. But this License is not limited to software manuals; +it can be used for any textual work, regardless of subject matter or +whether it is published as a printed book. We recommend this License +principally for works whose purpose is instruction or reference. + +@item +APPLICABILITY AND DEFINITIONS + +This License applies to any manual or other work, in any medium, that +contains a notice placed by the copyright holder saying it can be +distributed under the terms of this License. Such a notice grants a +world-wide, royalty-free license, unlimited in duration, to use that +work under the conditions stated herein. The ``Document'', below, +refers to any such manual or work. Any member of the public is a +licensee, and is addressed as ``you''. You accept the license if you +copy, modify or distribute the work in a way requiring permission +under copyright law. + +A ``Modified Version'' of the Document means any work containing the +Document or a portion of it, either copied verbatim, or with +modifications and/or translated into another language. + +A ``Secondary Section'' is a named appendix or a front-matter section +of the Document that deals exclusively with the relationship of the +publishers or authors of the Document to the Document's overall +subject (or to related matters) and contains nothing that could fall +directly within that overall subject. (Thus, if the Document is in +part a textbook of mathematics, a Secondary Section may not explain +any mathematics.) The relationship could be a matter of historical +connection with the subject or with related matters, or of legal, +commercial, philosophical, ethical or political position regarding +them. + +The ``Invariant Sections'' are certain Secondary Sections whose titles +are designated, as being those of Invariant Sections, in the notice +that says that the Document is released under this License. If a +section does not fit the above definition of Secondary then it is not +allowed to be designated as Invariant. The Document may contain zero +Invariant Sections. If the Document does not identify any Invariant +Sections then there are none. + +The ``Cover Texts'' are certain short passages of text that are listed, +as Front-Cover Texts or Back-Cover Texts, in the notice that says that +the Document is released under this License. A Front-Cover Text may +be at most 5 words, and a Back-Cover Text may be at most 25 words. + +A ``Transparent'' copy of the Document means a machine-readable copy, +represented in a format whose specification is available to the +general public, that is suitable for revising the document +straightforwardly with generic text editors or (for images composed of +pixels) generic paint programs or (for drawings) some widely available +drawing editor, and that is suitable for input to text formatters or +for automatic translation to a variety of formats suitable for input +to text formatters. A copy made in an otherwise Transparent file +format whose markup, or absence of markup, has been arranged to thwart +or discourage subsequent modification by readers is not Transparent. +An image format is not Transparent if used for any substantial amount +of text. A copy that is not ``Transparent'' is called ``Opaque''. + +Examples of suitable formats for Transparent copies include plain +@sc{ascii} without markup, Texinfo input format, La@TeX{} input +format, @acronym{SGML} or @acronym{XML} using a publicly available +@acronym{DTD}, and standard-conforming simple @acronym{HTML}, +PostScript or @acronym{PDF} designed for human modification. Examples +of transparent image formats include @acronym{PNG}, @acronym{XCF} and +@acronym{JPG}. Opaque formats include proprietary formats that can be +read and edited only by proprietary word processors, @acronym{SGML} or +@acronym{XML} for which the @acronym{DTD} and/or processing tools are +not generally available, and the machine-generated @acronym{HTML}, +PostScript or @acronym{PDF} produced by some word processors for +output purposes only. + +The ``Title Page'' means, for a printed book, the title page itself, +plus such following pages as are needed to hold, legibly, the material +this License requires to appear in the title page. For works in +formats which do not have any title page as such, ``Title Page'' means +the text near the most prominent appearance of the work's title, +preceding the beginning of the body of the text. + +A section ``Entitled XYZ'' means a named subunit of the Document whose +title either is precisely XYZ or contains XYZ in parentheses following +text that translates XYZ in another language. (Here XYZ stands for a +specific section name mentioned below, such as ``Acknowledgements'', +``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title'' +of such a section when you modify the Document means that it remains a +section ``Entitled XYZ'' according to this definition. + +The Document may include Warranty Disclaimers next to the notice which +states that this License applies to the Document. These Warranty +Disclaimers are considered to be included by reference in this +License, but only as regards disclaiming warranties: any other +implication that these Warranty Disclaimers may have is void and has +no effect on the meaning of this License. + +@item +VERBATIM COPYING + +You may copy and distribute the Document in any medium, either +commercially or noncommercially, provided that this License, the +copyright notices, and the license notice saying this License applies +to the Document are reproduced in all copies, and that you add no other +conditions whatsoever to those of this License. You may not use +technical measures to obstruct or control the reading or further +copying of the copies you make or distribute. However, you may accept +compensation in exchange for copies. If you distribute a large enough +number of copies you must also follow the conditions in section 3. + +You may also lend copies, under the same conditions stated above, and +you may publicly display copies. + +@item +COPYING IN QUANTITY + +If you publish printed copies (or copies in media that commonly have +printed covers) of the Document, numbering more than 100, and the +Document's license notice requires Cover Texts, you must enclose the +copies in covers that carry, clearly and legibly, all these Cover +Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on +the back cover. Both covers must also clearly and legibly identify +you as the publisher of these copies. The front cover must present +the full title with all words of the title equally prominent and +visible. You may add other material on the covers in addition. +Copying with changes limited to the covers, as long as they preserve +the title of the Document and satisfy these conditions, can be treated +as verbatim copying in other respects. + +If the required texts for either cover are too voluminous to fit +legibly, you should put the first ones listed (as many as fit +reasonably) on the actual cover, and continue the rest onto adjacent +pages. + +If you publish or distribute Opaque copies of the Document numbering +more than 100, you must either include a machine-readable Transparent +copy along with each Opaque copy, or state in or with each Opaque copy +a computer-network location from which the general network-using +public has access to download using public-standard network protocols +a complete Transparent copy of the Document, free of added material. +If you use the latter option, you must take reasonably prudent steps, +when you begin distribution of Opaque copies in quantity, to ensure +that this Transparent copy will remain thus accessible at the stated +location until at least one year after the last time you distribute an +Opaque copy (directly or through your agents or retailers) of that +edition to the public. + +It is requested, but not required, that you contact the authors of the +Document well before redistributing any large number of copies, to give +them a chance to provide you with an updated version of the Document. + +@item +MODIFICATIONS + +You may copy and distribute a Modified Version of the Document under +the conditions of sections 2 and 3 above, provided that you release +the Modified Version under precisely this License, with the Modified +Version filling the role of the Document, thus licensing distribution +and modification of the Modified Version to whoever possesses a copy +of it. In addition, you must do these things in the Modified Version: + +@enumerate A +@item +Use in the Title Page (and on the covers, if any) a title distinct +from that of the Document, and from those of previous versions +(which should, if there were any, be listed in the History section +of the Document). You may use the same title as a previous version +if the original publisher of that version gives permission. + +@item +List on the Title Page, as authors, one or more persons or entities +responsible for authorship of the modifications in the Modified +Version, together with at least five of the principal authors of the +Document (all of its principal authors, if it has fewer than five), +unless they release you from this requirement. + +@item +State on the Title page the name of the publisher of the +Modified Version, as the publisher. + +@item +Preserve all the copyright notices of the Document. + +@item +Add an appropriate copyright notice for your modifications +adjacent to the other copyright notices. + +@item +Include, immediately after the copyright notices, a license notice +giving the public permission to use the Modified Version under the +terms of this License, in the form shown in the Addendum below. + +@item +Preserve in that license notice the full lists of Invariant Sections +and required Cover Texts given in the Document's license notice. + +@item +Include an unaltered copy of this License. + +@item +Preserve the section Entitled ``History'', Preserve its Title, and add +to it an item stating at least the title, year, new authors, and +publisher of the Modified Version as given on the Title Page. If +there is no section Entitled ``History'' in the Document, create one +stating the title, year, authors, and publisher of the Document as +given on its Title Page, then add an item describing the Modified +Version as stated in the previous sentence. + +@item +Preserve the network location, if any, given in the Document for +public access to a Transparent copy of the Document, and likewise +the network locations given in the Document for previous versions +it was based on. These may be placed in the ``History'' section. +You may omit a network location for a work that was published at +least four years before the Document itself, or if the original +publisher of the version it refers to gives permission. + +@item +For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve +the Title of the section, and preserve in the section all the +substance and tone of each of the contributor acknowledgements and/or +dedications given therein. + +@item +Preserve all the Invariant Sections of the Document, +unaltered in their text and in their titles. Section numbers +or the equivalent are not considered part of the section titles. + +@item +Delete any section Entitled ``Endorsements''. Such a section +may not be included in the Modified Version. + +@item +Do not retitle any existing section to be Entitled ``Endorsements'' or +to conflict in title with any Invariant Section. + +@item +Preserve any Warranty Disclaimers. +@end enumerate + +If the Modified Version includes new front-matter sections or +appendices that qualify as Secondary Sections and contain no material +copied from the Document, you may at your option designate some or all +of these sections as invariant. To do this, add their titles to the +list of Invariant Sections in the Modified Version's license notice. +These titles must be distinct from any other section titles. + +You may add a section Entitled ``Endorsements'', provided it contains +nothing but endorsements of your Modified Version by various +parties---for example, statements of peer review or that the text has +been approved by an organization as the authoritative definition of a +standard. + +You may add a passage of up to five words as a Front-Cover Text, and a +passage of up to 25 words as a Back-Cover Text, to the end of the list +of Cover Texts in the Modified Version. Only one passage of +Front-Cover Text and one of Back-Cover Text may be added by (or +through arrangements made by) any one entity. If the Document already +includes a cover text for the same cover, previously added by you or +by arrangement made by the same entity you are acting on behalf of, +you may not add another; but you may replace the old one, on explicit +permission from the previous publisher that added the old one. + +The author(s) and publisher(s) of the Document do not by this License +give permission to use their names for publicity for or to assert or +imply endorsement of any Modified Version. + +@item +COMBINING DOCUMENTS + +You may combine the Document with other documents released under this +License, under the terms defined in section 4 above for modified +versions, provided that you include in the combination all of the +Invariant Sections of all of the original documents, unmodified, and +list them all as Invariant Sections of your combined work in its +license notice, and that you preserve all their Warranty Disclaimers. + +The combined work need only contain one copy of this License, and +multiple identical Invariant Sections may be replaced with a single +copy. If there are multiple Invariant Sections with the same name but +different contents, make the title of each such section unique by +adding at the end of it, in parentheses, the name of the original +author or publisher of that section if known, or else a unique number. +Make the same adjustment to the section titles in the list of +Invariant Sections in the license notice of the combined work. + +In the combination, you must combine any sections Entitled ``History'' +in the various original documents, forming one section Entitled +``History''; likewise combine any sections Entitled ``Acknowledgements'', +and any sections Entitled ``Dedications''. You must delete all +sections Entitled ``Endorsements.'' + +@item +COLLECTIONS OF DOCUMENTS + +You may make a collection consisting of the Document and other documents +released under this License, and replace the individual copies of this +License in the various documents with a single copy that is included in +the collection, provided that you follow the rules of this License for +verbatim copying of each of the documents in all other respects. + +You may extract a single document from such a collection, and distribute +it individually under this License, provided you insert a copy of this +License into the extracted document, and follow this License in all +other respects regarding verbatim copying of that document. + +@item +AGGREGATION WITH INDEPENDENT WORKS + +A compilation of the Document or its derivatives with other separate +and independent documents or works, in or on a volume of a storage or +distribution medium, is called an ``aggregate'' if the copyright +resulting from the compilation is not used to limit the legal rights +of the compilation's users beyond what the individual works permit. +When the Document is included an aggregate, this License does not +apply to the other works in the aggregate which are not themselves +derivative works of the Document. + +If the Cover Text requirement of section 3 is applicable to these +copies of the Document, then if the Document is less than one half of +the entire aggregate, the Document's Cover Texts may be placed on +covers that bracket the Document within the aggregate, or the +electronic equivalent of covers if the Document is in electronic form. +Otherwise they must appear on printed covers that bracket the whole +aggregate. + +@item +TRANSLATION + +Translation is considered a kind of modification, so you may +distribute translations of the Document under the terms of section 4. +Replacing Invariant Sections with translations requires special +permission from their copyright holders, but you may include +translations of some or all Invariant Sections in addition to the +original versions of these Invariant Sections. You may include a +translation of this License, and all the license notices in the +Document, and any Warrany Disclaimers, provided that you also include +the original English version of this License and the original versions +of those notices and disclaimers. In case of a disagreement between +the translation and the original version of this License or a notice +or disclaimer, the original version will prevail. + +If a section in the Document is Entitled ``Acknowledgements'', +``Dedications'', or ``History'', the requirement (section 4) to Preserve +its Title (section 1) will typically require changing the actual +title. + +@item +TERMINATION + +You may not copy, modify, sublicense, or distribute the Document except +as expressly provided for under this License. Any other attempt to +copy, modify, sublicense or distribute the Document is void, and will +automatically terminate your rights under this License. However, +parties who have received copies, or rights, from you under this +License will not have their licenses terminated so long as such +parties remain in full compliance. + +@item +FUTURE REVISIONS OF THIS LICENSE + +The Free Software Foundation may publish new, revised versions +of the GNU Free Documentation License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. See +@uref{http://www.gnu.org/copyleft/}. + +Each version of the License is given a distinguishing version number. +If the Document specifies that a particular numbered version of this +License ``or any later version'' applies to it, you have the option of +following the terms and conditions either of that specified version or +of any later version that has been published (not as a draft) by the +Free Software Foundation. If the Document does not specify a version +number of this License, you may choose any version ever published (not +as a draft) by the Free Software Foundation. +@end enumerate + +@page +@appendixsec ADDENDUM: How to use this License for your documents + +To use this License in a document you have written, include a copy of +the License in the document and put the following copyright and +license notices just after the title page: + +@smallexample +@group + Copyright (C) @var{year} @var{your name}. + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.2 + or any later version published by the Free Software Foundation; + with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. + A copy of the license is included in the section entitled ``GNU + Free Documentation License''. +@end group +@end smallexample + +If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts, +replace the ``with...Texts.'' line with this: + +@smallexample +@group + with the Invariant Sections being @var{list their titles}, with + the Front-Cover Texts being @var{list}, and with the Back-Cover Texts + being @var{list}. +@end group +@end smallexample + +If you have Invariant Sections without Cover Texts, or some other +combination of the three, merge those two alternatives to suit the +situation. + +If your document contains nontrivial examples of program code, we +recommend releasing these examples in parallel under your choice of +free software license, such as the GNU General Public License, +to permit their use in free software. + +@bye diff --git a/doc/index.html b/doc/index.html index 0310a055e..f0e2ba320 100644 --- a/doc/index.html +++ b/doc/index.html @@ -17,6 +17,7 @@ The following MIT/GNU Scheme manuals are available here:
  • SOS Reference Manual
  • IMAIL User's Manual
  • FFI User's Manual
    • +
  • GTK User's Manual
    • diff --git a/src/Clean.sh b/src/Clean.sh index 9e4f82f89..54ecc2104 100755 --- a/src/Clean.sh +++ b/src/Clean.sh @@ -75,6 +75,7 @@ fi if [ ${MAINTAINER} = yes ]; then maybe_rm autom4te.cache configure lib stamp_* boot-root makefiles_created + maybe_rm config.sub config.guess fi for SUBDIR in ${SUBDIRS}; do diff --git a/src/Makefile.in b/src/Makefile.in index 561c0c2e8..3c9301bbf 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -62,7 +62,8 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs # **** END BOILERPLATE **** LIARC_BOOT_BUNDLES = compiler cref sf star-parser -LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml +LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml $(FFIS) +FFIS = gtk SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES) @@ -73,12 +74,16 @@ EDDIR = $(AUXDIR)/edwin all: @ALL_TARGET@ all-native: compile-microcode + etc/make-in-subdirs.sh generate $(FFIS) @$(top_srcdir)/etc/compile.sh mit-scheme-native --compiler --batch-mode $(MAKE) build-bands + etc/make-in-subdirs.sh build $(FFIS) all-liarc: + etc/make-in-subdirs.sh generate $(FFIS) @$(top_srcdir)/etc/c-compile.sh mit-scheme-c --compiler --batch-mode $(MAKE) compile-liarc-bundles build-bands + etc/make-in-subdirs.sh build $(FFIS) compile-microcode: (cd microcode && $(MAKE) all) @@ -166,6 +171,7 @@ install-auxdir-top: $(mkinstalldirs) $(DESTDIR)$(AUXDIR) $(INSTALL_DATA) $(top_srcdir)/etc/optiondb.scm $(DESTDIR)$(AUXDIR)/. $(INSTALL_DATA) lib/*.com $(DESTDIR)$(AUXDIR)/. + $(INSTALL_DATA) lib/*.png $(DESTDIR)$(AUXDIR)/. .PHONY: all compile-microcode build-bands all-native all-liarc .PHONY: liarc-dist compile-liarc-bundles install-liarc-bundles native diff --git a/src/README.txt b/src/README.txt index 9858d9eee..d4cfa1bca 100644 --- a/src/README.txt +++ b/src/README.txt @@ -36,6 +36,9 @@ The core subsystem consists of these directories: * "ffi" provides syntax for calling foreign (C) functions and manipulating alien (C) data. +* "gtk" uses the FFI to provide a nice interface to GNOME. Features a + Scheme canvas widget. + The compiler subsystem consists of these three directories: * "sf" contains a program that translates Scheme source code to an diff --git a/src/Setup.sh b/src/Setup.sh index 83a6f68ca..fb5de18ac 100755 --- a/src/Setup.sh +++ b/src/Setup.sh @@ -35,8 +35,8 @@ fi . etc/functions.sh -INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml" -OTHER_SUBDIRS="6001 compiler runtime win32 xdoc microcode" +INSTALLED_SUBDIRS="cref edwin ffi gtk imail sf sos ssp star-parser xml" +OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode" # lib maybe_mkdir lib @@ -48,6 +48,10 @@ maybe_link lib/runtime ../runtime maybe_link lib/utabmd.bin ../microcode/utabmd.bin maybe_link lib/mit-scheme.h ../microcode/pruxffi.h maybe_link lib/ffi ../ffi +maybe_link lib/lib/prgtkio.so ../../microcode/prgtkio.so +maybe_link lib/gtk ../gtk +maybe_link config.sub microcode/config.sub +maybe_link config.guess microcode/config.guess for SUBDIR in ${INSTALLED_SUBDIRS} ${OTHER_SUBDIRS}; do echo "setting up ${SUBDIR}" diff --git a/src/configure.ac b/src/configure.ac index 92887611a..9f0d56679 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -61,8 +61,19 @@ then INSTALL="${INSTALL} --preserve-timestamps" fi +echo etc/create-makefiles.sh "${enable_native_code}" etc/create-makefiles.sh "${enable_native_code}" +m4_include(microcode/achost.ac) + +AC_SUBST([CCLD]) +AC_SUBST([DEFS]) +AC_SUBST([CFLAGS]) +AC_SUBST([CPPFLAGS]) +AC_SUBST([LDFLAGS]) +AC_SUBST([SHIM_CFLAGS]) +AC_SUBST([SHIM_LDFLAGS]) + AC_CONFIG_SUBDIRS([microcode compiler]) AC_CONFIG_FILES([ Makefile @@ -71,6 +82,7 @@ compiler/Makefile cref/Makefile edwin/Makefile ffi/Makefile +gtk/Makefile imail/Makefile runtime/Makefile sf/Makefile @@ -91,7 +103,7 @@ if test x${enable_native_code} = xc; then for BN in star-parser; do (cd lib; rm -f ${BN}; ${LN_S} ../${BN} .) done - for BUNDLE in 6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml; do + for BUNDLE in 6001 compiler cref edwin ffi gtk imail sf sos ssp star-parser xdoc xml; do SO=${BUNDLE}.so (cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .) done diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh index 20f8e2dc5..f9db0dca7 100755 --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@ -48,7 +48,7 @@ run_cmd rm -f compiler/machine compiler/compiler.pkg run_cmd ln -s machines/"${MDIR}" compiler/machine run_cmd ln -s machine/compiler.pkg compiler/. -BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml" +BUNDLES="6001 compiler cref edwin ffi gtk imail sf sos ssp star-parser xdoc xml" : ${MIT_SCHEME_EXE='mit-scheme'} diff --git a/src/etc/make-in-subdirs.sh b/src/etc/make-in-subdirs.sh index f2e6a2515..4d9ee57f9 100755 --- a/src/etc/make-in-subdirs.sh +++ b/src/etc/make-in-subdirs.sh @@ -30,5 +30,5 @@ set -e TARGET=${1} shift for SUBDIR in "${@}"; do - run_cmd_in_dir "${SUBDIR}" make "${TARGET}" + run_cmd_in_dir "${SUBDIR}" make "${TARGET}" || exit $? done diff --git a/src/etc/optiondb.scm b/src/etc/optiondb.scm index 40af3d62f..d80aaa7b5 100644 --- a/src/etc/optiondb.scm +++ b/src/etc/optiondb.scm @@ -97,6 +97,9 @@ USA. (define-load-option 'FFI (guarded-system-loader '(ffi) "ffi")) +(define-load-option 'GTK + (guarded-system-loader '(gtk) "gtk")) + (define-load-option 'IMAIL (guarded-system-loader '(edwin imail) "imail")) diff --git a/src/etc/std-makefile-prefix b/src/etc/std-makefile-prefix index 62e0a5f91..033529dda 100644 --- a/src/etc/std-makefile-prefix +++ b/src/etc/std-makefile-prefix @@ -1,3 +1,4 @@ +# -*-Makefile-*- # $Id: std-makefile-prefix,v 1.4 2008/01/30 20:02:09 cph Exp $ # # Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, @@ -67,6 +68,22 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs # **** END BOILERPLATE **** +CC = @CC@ +CCLD = @CCLD@ + +DEFS = @DEFS@ +CFLAGS = @CFLAGS@ +CPPFLAGS = @CPPFLAGS@ -I../lib +LDFLAGS = @LDFLAGS@ + +COMPILE = $(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS) +LINK = $(CCLD) $(LDFLAGS) -o $@ + +SHIM_CFLAGS = @SHIM_CFLAGS@ +SHIM_LDFLAGS = @SHIM_LDFLAGS@ +COMPILE_SHIM = $(COMPILE) $(SHIM_CFLAGS) +LINK_SHIM = $(LINK) $(SHIM_LDFLAGS) + AUXDIR = @AUXDIR@ all: diff --git a/src/gtk/Clean.sh b/src/gtk/Clean.sh new file mode 100644 index 000000000..9bdc39309 --- /dev/null +++ b/src/gtk/Clean.sh @@ -0,0 +1,19 @@ +#!/bin/sh +# +# $Id: $ + +set -e + +if [ ${#} -ne 1 ]; then + echo "usage: ${0} " + exit 1 +fi + +../etc/Clean.sh "${1}" +. ../etc/functions.sh + +maybe_rm gtk-shim.c gtk-const* gtk-types* +maybe_rm conses.png ../lib/conses.png +maybe_rm ../lib/lib/gtk-* ../lib/lib/prgtkio.so +# And, just because the maintainer- and c-clean targets nail this one anyway: +maybe_rm scmwidget.c diff --git a/src/gtk/Includes/cairo-xlib.cdecl b/src/gtk/Includes/cairo-xlib.cdecl new file mode 100644 index 000000000..95372beca --- /dev/null +++ b/src/gtk/Includes/cairo-xlib.cdecl @@ -0,0 +1,40 @@ +#| -*-Scheme-*- + +cairo/cairo-xlib.h (v1.4) |# + +(include "cairo") + +(extern (* cairo_surface_t) cairo_xlib_surface_create + (dpy (* Display)) + (drawable Drawable) + (visual (* Visual)) + (width int) (height int)) + +;(extern (* cairo_surface_t) cairo_xlib_surface_create_for_bitmap +; (dpy (* Display)) +; (bitmap Pixmap) +; (screen (* Screen)) +; (width int) (height int)) + +(extern void cairo_xlib_surface_set_size + (surface (* cairo_surface_t)) + (width int) (height int)) + +;(extern void cairo_xlib_surface_set_drawable +; (surface (* cairo_surface_t)) +; (drawable Drawable) +; (width int) (height int)) + +;(extern (* Display) cairo_xlib_surface_get_display(surface(* cairo_surface_t))) + +;(extern Drawable cairo_xlib_surface_get_drawable (surface (* cairo_surface_t))) + +;(extern (* Screen) cairo_xlib_surface_get_screen (surface (* cairo_surface_t))) + +;(extern (* Visual) cairo_xlib_surface_get_visual (surface (* cairo_surface_t))) + +;(extern int cairo_xlib_surface_get_depth (surface (* cairo_surface_t))) + +;(extern int cairo_xlib_surface_get_width (surface (* cairo_surface_t))) + +;(extern int cairo_xlib_surface_get_height (surface (* cairo_surface_t))) diff --git a/src/gtk/Includes/cairo.cdecl b/src/gtk/Includes/cairo.cdecl new file mode 100644 index 000000000..2944ccfd5 --- /dev/null +++ b/src/gtk/Includes/cairo.cdecl @@ -0,0 +1,1010 @@ +#| -*-Scheme-*- + +cairo/cairo.h (v1.4) |# + +;(include "cairo-features") +;(include "cairo-deprecated") + +;(extern int cairo_version) +;(extern (const (* char)) cairo_version_string) +;(typedef cairo_bool_t int) +;(typedef cairo_t (struct _cairo)) +;(typedef cairo_surface_t (struct _cairo_surface)) + +;(typedef cairo_matrix_t +; (struct _cairo_matrix +; (xx double) +; (yx double) +; (xy double) +; (yy double) +; (x0 double) +; (y0 double))) + +;(typedef cairo_pattern_t (struct _cairo_pattern)) + +;(typedef cairo_destroy_func_t (* (function void (data (* void))))) +;(typedef cairo_user_data_key_t (struct _cairo_user_data_key (unused int))) + +(typedef cairo_status_t + (enum _cairo_status + (CAIRO_STATUS_SUCCESS) + (CAIRO_STATUS_NO_MEMORY) + (CAIRO_STATUS_INVALID_RESTORE) + (CAIRO_STATUS_INVALID_POP_GROUP) + (CAIRO_STATUS_NO_CURRENT_POINT) + (CAIRO_STATUS_INVALID_MATRIX) + (CAIRO_STATUS_INVALID_STATUS) + (CAIRO_STATUS_NULL_POINTER) + (CAIRO_STATUS_INVALID_STRING) + (CAIRO_STATUS_INVALID_PATH_DATA) + (CAIRO_STATUS_READ_ERROR) + (CAIRO_STATUS_WRITE_ERROR) + (CAIRO_STATUS_SURFACE_FINISHED) + (CAIRO_STATUS_SURFACE_TYPE_MISMATCH) + (CAIRO_STATUS_PATTERN_TYPE_MISMATCH) + (CAIRO_STATUS_INVALID_CONTENT) + (CAIRO_STATUS_INVALID_FORMAT) + (CAIRO_STATUS_INVALID_VISUAL) + (CAIRO_STATUS_FILE_NOT_FOUND) + (CAIRO_STATUS_INVALID_DASH) + (CAIRO_STATUS_INVALID_DSC_COMMENT) + (CAIRO_STATUS_INVALID_INDEX) + (CAIRO_STATUS_CLIP_NOT_REPRESENTABLE))) + +;(typedef cairo_content_t +; (enum _cairo_content +; (CAIRO_CONTENT_COLOR) +; (CAIRO_CONTENT_ALPHA) +; (CAIRO_CONTENT_COLOR_ALPHA))) + +;typedef cairo_status_t (*cairo_write_func_t) +; (void *closure, const unsigned char *data, unsigned int length); + +;typedef cairo_status_t (*cairo_read_func_t) +; (void *closure, unsigned char *data, unsigned int length); + + +;;; Functions for manipulating state objects + +(extern (* cairo_t) cairo_create (target (* cairo_surface_t))) + +;(extern (* cairo_t) cairo_reference (cr (* cairo_t))) + +(extern void cairo_destroy (cr (* cairo_t))) + +;(extern (unsigned int) cairo_get_reference_count (cr (* cairo_t))) + +;(extern (* void) cairo_get_user_data +; (cr (* cairo_t)) +; (key (const (* cairo_user_data_key_t)))) + +;(extern cairo_status_t cairo_set_user_data +; (cr (* cairo_t)) +; (key (const (* cairo_user_data_key_t))) +; (user_date (* void)) +; (destroy cairo_destroy_func_t)) + +(extern void cairo_save (cr (* cairo_t))) + +(extern void cairo_restore (cr (* cairo_t))) + +;(extern void cairo_push_group (cr (* cairo_t))) + +;(extern void cairo_push_group_with_content +; (cr (* cairo_t)) +; (content cairo_content_t)) + +;(extern (* cairo_pattern_t) cairo_pop_group (cr (* cairo_t))) + +;(extern void cairo_pop_group_to_source (cr (* cairo_t))) + + +;;; Modify state + +;(typedef cairo_operator_t +; (enum _cairo_operator +; (CAIRO_OPERATOR_CLEAR) +; +; (CAIRO_OPERATOR_SOURCE) +; (CAIRO_OPERATOR_OVER) +; (CAIRO_OPERATOR_IN) +; (CAIRO_OPERATOR_OUT) +; (CAIRO_OPERATOR_ATOP) +; +; (CAIRO_OPERATOR_DEST) +; (CAIRO_OPERATOR_DEST_OVER) +; (CAIRO_OPERATOR_DEST_IN) +; (CAIRO_OPERATOR_DEST_OUT) +; (CAIRO_OPERATOR_DEST_ATOP) +; +; (CAIRO_OPERATOR_XOR) +; (CAIRO_OPERATOR_ADD) +; (CAIRO_OPERATOR_SATURATE))) + +;(extern void cairo_set_operator (cr (* cairo_t)) (op cairo_operator_t)) + +;(extern void cairo_set_source (cr (* cairo_t)) (source (* cairo_pattern_t))) + +(extern void cairo_set_source_rgb + (cr (* cairo_t)) (red double)(green double)(blue double)) + +;(extern void cairo_set_source_rgba +; (cr (* cairo_t)) (red double)(green double)(blue double)(alpha double)) + +;(extern void cairo_set_source_surface +; (cr (* cairo_t)) (surface (* cairo_surface_t)) (x double) (y double)) + +;(extern void cairo_set_tolerance (cr (* cairo_t)) (tolerance double)) + +;(typedef cairo_antialias_t +; (enum _cairo_antialias +; (CAIRO_ANTIALIAS_DEFAULT) +; (CAIRO_ANTIALIAS_NONE) +; (CAIRO_ANTIALIAS_GRAY) +; (CAIRO_ANTIALIAS_SUBPIXEL))) + +;(extern void cairo_set_antialias +; (cr (* cairo_t)) (antialias cairo_antialias_t)) + +;(typedef cairo_fill_rule_t +; (enum _cairo_fill_rule +; (CAIRO_FILL_RULE_WINDING) +; (CAIRO_FILL_RULE_EVEN_ODD))) + +;(extern void cairo_set_fill_rule (cr (* cairo_t)) (fill_rule cairo_fill_rule_t)) + +;(extern void cairo_set_line_width (cr (* cairo_t)) (width double)) + +;(typedef cairo_line_cap_t +; (enum _cairo_line_cap +; (CAIRO_LINE_CAP_BUTT) +; (CAIRO_LINE_CAP_ROUND) +; (CAIRO_LINE_CAP_SQUARE))) + +;(extern void cairo_set_line_cap (cr (* cairo_t)) (line_cap cairo_line_cap_t)) + +;(typedef cairo_line_join_t +; (enum _cairo_line_join +; (CAIRO_LINE_JOIN_MITER) +; (CAIRO_LINE_JOIN_ROUND) +; (CAIRO_LINE_JOIN_BEVEL))) + +;(extern void cairo_set_line_join (cr (* cairo_t)) (line_join cairo_line_join_t)) + +;(extern void cairo_set_dash +; (cr (* cairo_t)) +; (dashes (const (* double))) +; (num_dashes int) +; (offset double)) + +;(extern void cairo_set_miter_limit (cr (* cairo_t)) (limit double)) + +(extern void cairo_translate (cr (* cairo_t)) (tx double) (ty double)) + +;(extern void cairo_scale (cr (* cairo_t)) (sx double) (sy double)) + +(extern void cairo_rotate (cr (* cairo_t)) (angle double)) + +;(extern void cairo_transform +; (cr (* cairo_t)) (matrix (const (* cairo_matrix_t)))) + +;(extern void cairo_set_matrix +; (cr (* cairo_t)) (matrix (const (* cairo_matrix_t)))) + +;(extern void cairo_identity_matrix (cr (* cairo_t))) + +;(extern void cairo_user_to_device +; (cr (* cairo_t)) (x (* double)) (y (* double))) + +;(extern void cairo_user_to_device_distance +; (cr (* cairo_t)) (dx (* double)) (dy (* double))) + +;(extern void cairo_device_to_user +; (cr (* cairo_t)) (x (* double)) (x (* double))) + +;(extern void cairo_device_to_user_distance +; (cr (* cairo_t)) (dx (* double)) (dy (* double))) + + +;;; Path creation functions + +;(extern void cairo_new_path (cairo_t *cr); + +(extern void cairo_move_to (cr (* cairo_t)) (x double) (y double)) + +;(extern void cairo_new_sub_path (cairo_t *cr); + +;(extern void cairo_line_to (cr (* cairo_t)) double x, double y); + +;(extern void cairo_curve_to (cr (* cairo_t)) +; double x1, double y1, +; double x2, double y2, +; double x3, double y3); + +;(extern void cairo_arc (cr (* cairo_t)) +; double xc, double yc, +; double radius, +; double angle1, double angle2); + +;(extern void cairo_arc_negative (cr (* cairo_t)) +; double xc, double yc, +; double radius, +; double angle1, double angle2); + +;(extern void cairo_rel_move_to (cr (* cairo_t)) double dx, double dy); + +;(extern void cairo_rel_line_to (cr (* cairo_t)) double dx, double dy); + +;(extern void cairo_rel_curve_to (cr (* cairo_t)) +; double dx1, double dy1, +; double dx2, double dy2, +; double dx3, double dy3); + +;(extern void cairo_rectangle (cr (* cairo_t)) +; double x, double y, +; double width, double height); + +;(extern void cairo_close_path (cairo_t *cr); + + +;;; Painting functions + +(extern void cairo_paint (cr (* cairo_t))) + +#| + + (extern void cairo_paint_with_alpha (cr (* cairo_t)) + double alpha); + + (extern void cairo_mask (cairo_t *cr, + cairo_pattern_t *pattern); + + (extern void cairo_mask_surface (cairo_t *cr, + cairo_surface_t *surface, + double surface_x, + double surface_y); + + (extern void cairo_stroke (cairo_t *cr); + + (extern void cairo_stroke_preserve (cairo_t *cr); + + (extern void cairo_fill (cairo_t *cr); + + (extern void cairo_fill_preserve (cairo_t *cr); + + (extern void cairo_copy_page (cairo_t *cr); + + (extern void cairo_show_page (cairo_t *cr); + +;; Insideness testing + + (extern cairo_bool_t cairo_in_stroke (cr (* cairo_t)) double x, double y); + + (extern cairo_bool_t cairo_in_fill (cr (* cairo_t)) double x, double y); + +;; Rectangular extents + + (extern void cairo_stroke_extents (cr (* cairo_t)) + double *x1, double *y1, + double *x2, double *y2); + + (extern void cairo_fill_extents (cr (* cairo_t)) + double *x1, double *y1, + double *x2, double *y2); + +;; Clipping + + (extern void cairo_reset_clip (cairo_t *cr); + + (extern void cairo_clip (cairo_t *cr); + + (extern void cairo_clip_preserve (cairo_t *cr); + + (extern void cairo_clip_extents (cr (* cairo_t)) + double *x1, double *y1, + double *x2, double *y2); + + (typedef struct _cairo_rectangle { + double x, y, width, height; +} cairo_rectangle_t; + +typedef struct _cairo_rectangle_list { + cairo_status_t status; + cairo_rectangle_t *rectangles; + int num_rectangles; +} cairo_rectangle_list_t; + + (extern cairo_rectangle_list_t * cairo_copy_clip_rectangle_list (cairo_t *cr); + + (extern void cairo_rectangle_list_destroy (cairo_rectangle_list_t *rectangle_list); + + +;;; Font/Text functions + +typedef struct _cairo_scaled_font cairo_scaled_font_t; + +typedef struct _cairo_font_face cairo_font_face_t; + +typedef struct { + unsigned long index; + double x; + double y; +} cairo_glyph_t; + +typedef struct { + double x_bearing; + double y_bearing; + double width; + double height; + double x_advance; + double y_advance; +} cairo_text_extents_t; + +typedef struct { + double ascent; + double descent; + double height; + double max_x_advance; + double max_y_advance; +} cairo_font_extents_t; + +typedef enum _cairo_font_slant { + CAIRO_FONT_SLANT_NORMAL, + CAIRO_FONT_SLANT_ITALIC, + CAIRO_FONT_SLANT_OBLIQUE +} cairo_font_slant_t; + +typedef enum _cairo_font_weight { + CAIRO_FONT_WEIGHT_NORMAL, + CAIRO_FONT_WEIGHT_BOLD +} cairo_font_weight_t; + +typedef enum _cairo_subpixel_order { + CAIRO_SUBPIXEL_ORDER_DEFAULT, + CAIRO_SUBPIXEL_ORDER_RGB, + CAIRO_SUBPIXEL_ORDER_BGR, + CAIRO_SUBPIXEL_ORDER_VRGB, + CAIRO_SUBPIXEL_ORDER_VBGR +} cairo_subpixel_order_t; + +typedef enum _cairo_hint_style { + CAIRO_HINT_STYLE_DEFAULT, + CAIRO_HINT_STYLE_NONE, + CAIRO_HINT_STYLE_SLIGHT, + CAIRO_HINT_STYLE_MEDIUM, + CAIRO_HINT_STYLE_FULL +} cairo_hint_style_t; + +typedef enum _cairo_hint_metrics { + CAIRO_HINT_METRICS_DEFAULT, + CAIRO_HINT_METRICS_OFF, + CAIRO_HINT_METRICS_ON +} cairo_hint_metrics_t; + +typedef struct _cairo_font_options cairo_font_options_t; + + (extern cairo_font_options_t * cairo_font_options_create (void); + + (extern cairo_font_options_t * cairo_font_options_copy (const cairo_font_options_t *original); + + (extern void cairo_font_options_destroy (cairo_font_options_t *options); + + (extern cairo_status_t cairo_font_options_status (cairo_font_options_t *options); + + (extern void cairo_font_options_merge (cairo_font_options_t *options, + const cairo_font_options_t *other); + (extern cairo_bool_t cairo_font_options_equal (const cairo_font_options_t *options, + const cairo_font_options_t *other); + + (extern unsigned long +cairo_font_options_hash (const cairo_font_options_t *options); + + (extern void +cairo_font_options_set_antialias (cairo_font_options_t *options, + cairo_antialias_t antialias); + (extern cairo_antialias_t +cairo_font_options_get_antialias (const cairo_font_options_t *options); + + (extern void +cairo_font_options_set_subpixel_order (cairo_font_options_t *options, + cairo_subpixel_order_t subpixel_order); + (extern cairo_subpixel_order_t +cairo_font_options_get_subpixel_order (const cairo_font_options_t *options); + + (extern void +cairo_font_options_set_hint_style (cairo_font_options_t *options, + cairo_hint_style_t hint_style); + (extern cairo_hint_style_t +cairo_font_options_get_hint_style (const cairo_font_options_t *options); + + (extern void +cairo_font_options_set_hint_metrics (cairo_font_options_t *options, + cairo_hint_metrics_t hint_metrics); + (extern cairo_hint_metrics_t +cairo_font_options_get_hint_metrics (const cairo_font_options_t *options); + +/* This interface is for dealing with text as text, not caring about the + font object inside the the cairo_t. */ + + (extern void +cairo_select_font_face (cairo_t *cr, + const char *family, + cairo_font_slant_t slant, + cairo_font_weight_t weight); + + (extern void +cairo_set_font_size (cr (* cairo_t)) double size); + + (extern void +cairo_set_font_matrix (cairo_t *cr, + const cairo_matrix_t *matrix); + + (extern void +cairo_get_font_matrix (cr (* cairo_t)) + cairo_matrix_t *matrix); + + (extern void +cairo_set_font_options (cairo_t *cr, + const cairo_font_options_t *options); + + (extern void +cairo_get_font_options (cairo_t *cr, + cairo_font_options_t *options); + + (extern void +cairo_set_font_face (cr (* cairo_t)) cairo_font_face_t *font_face); + + (extern cairo_font_face_t * +cairo_get_font_face (cairo_t *cr); + + (extern void +cairo_set_scaled_font (cairo_t *cr, + const cairo_scaled_font_t *scaled_font); + + (extern cairo_scaled_font_t * +cairo_get_scaled_font (cairo_t *cr); + + (extern void +cairo_show_text (cr (* cairo_t)) const char *utf8); + + (extern void +cairo_show_glyphs (cr (* cairo_t)) const cairo_glyph_t *glyphs, int num_glyphs); + + (extern void +cairo_text_path (cr (* cairo_t)) const char *utf8); + + (extern void +cairo_glyph_path (cr (* cairo_t)) const cairo_glyph_t *glyphs, int num_glyphs); + + (extern void +cairo_text_extents (cairo_t *cr, + const char *utf8, + cairo_text_extents_t *extents); + + (extern void +cairo_glyph_extents (cairo_t *cr, + const cairo_glyph_t *glyphs, + int num_glyphs, + cairo_text_extents_t *extents); + + (extern void +cairo_font_extents (cairo_t *cr, + cairo_font_extents_t *extents); + +/* Generic identifier for a font style */ + + (extern cairo_font_face_t * +cairo_font_face_reference (cairo_font_face_t *font_face); + + (extern void +cairo_font_face_destroy (cairo_font_face_t *font_face); + + (extern unsigned int +cairo_font_face_get_reference_count (cairo_font_face_t *font_face); + + (extern cairo_status_t +cairo_font_face_status (cairo_font_face_t *font_face); + +typedef enum _cairo_font_type { + CAIRO_FONT_TYPE_TOY, + CAIRO_FONT_TYPE_FT, + CAIRO_FONT_TYPE_WIN32, + CAIRO_FONT_TYPE_ATSUI +} cairo_font_type_t; + + (extern cairo_font_type_t +cairo_font_face_get_type (cairo_font_face_t *font_face); + + (extern void * +cairo_font_face_get_user_data (cairo_font_face_t *font_face, + const cairo_user_data_key_t *key); + + (extern cairo_status_t +cairo_font_face_set_user_data (cairo_font_face_t *font_face, + const cairo_user_data_key_t *key, + void *user_data, + cairo_destroy_func_t destroy); + +/* Portable interface to general font features. */ + + (extern cairo_scaled_font_t * +cairo_scaled_font_create (cairo_font_face_t *font_face, + const cairo_matrix_t *font_matrix, + const cairo_matrix_t *ctm, + const cairo_font_options_t *options); + + (extern cairo_scaled_font_t * +cairo_scaled_font_reference (cairo_scaled_font_t *scaled_font); + + (extern void +cairo_scaled_font_destroy (cairo_scaled_font_t *scaled_font); + + (extern unsigned int +cairo_scaled_font_get_reference_count (cairo_scaled_font_t *scaled_font); + + (extern cairo_status_t +cairo_scaled_font_status (cairo_scaled_font_t *scaled_font); + + (extern cairo_font_type_t +cairo_scaled_font_get_type (cairo_scaled_font_t *scaled_font); + + (extern void * +cairo_scaled_font_get_user_data (cairo_scaled_font_t *scaled_font, + const cairo_user_data_key_t *key); + + (extern cairo_status_t +cairo_scaled_font_set_user_data (cairo_scaled_font_t *scaled_font, + const cairo_user_data_key_t *key, + void *user_data, + cairo_destroy_func_t destroy); + + (extern void +cairo_scaled_font_extents (cairo_scaled_font_t *scaled_font, + cairo_font_extents_t *extents); + + (extern void +cairo_scaled_font_text_extents (cairo_scaled_font_t *scaled_font, + const char *utf8, + cairo_text_extents_t *extents); + + (extern void +cairo_scaled_font_glyph_extents (cairo_scaled_font_t *scaled_font, + const cairo_glyph_t *glyphs, + int num_glyphs, + cairo_text_extents_t *extents); + + (extern cairo_font_face_t * +cairo_scaled_font_get_font_face (cairo_scaled_font_t *scaled_font); + + (extern void +cairo_scaled_font_get_font_matrix (cairo_scaled_font_t *scaled_font, + cairo_matrix_t *font_matrix); + + (extern void +cairo_scaled_font_get_ctm (cairo_scaled_font_t *scaled_font, + cairo_matrix_t *ctm); + + (extern void +cairo_scaled_font_get_font_options (cairo_scaled_font_t *scaled_font, + cairo_font_options_t *options); + + +;;; Query functions + + (extern cairo_operator_t +cairo_get_operator (cairo_t *cr); + + (extern cairo_pattern_t * +cairo_get_source (cairo_t *cr); + + (extern double +cairo_get_tolerance (cairo_t *cr); + + (extern cairo_antialias_t +cairo_get_antialias (cairo_t *cr); + + (extern void +cairo_get_current_point (cr (* cairo_t)) double *x, double *y); + + (extern cairo_fill_rule_t +cairo_get_fill_rule (cairo_t *cr); + + (extern double +cairo_get_line_width (cairo_t *cr); + + (extern cairo_line_cap_t +cairo_get_line_cap (cairo_t *cr); + + (extern cairo_line_join_t +cairo_get_line_join (cairo_t *cr); + + (extern double +cairo_get_miter_limit (cairo_t *cr); + + (extern int +cairo_get_dash_count (cairo_t *cr); + + (extern void +cairo_get_dash (cr (* cairo_t)) double *dashes, double *offset); + + (extern void +cairo_get_matrix (cr (* cairo_t)) cairo_matrix_t *matrix); + + (extern cairo_surface_t * +cairo_get_target (cairo_t *cr); + + (extern cairo_surface_t * +cairo_get_group_target (cairo_t *cr); + +typedef enum _cairo_path_data_type { + CAIRO_PATH_MOVE_TO, + CAIRO_PATH_LINE_TO, + CAIRO_PATH_CURVE_TO, + CAIRO_PATH_CLOSE_PATH +} cairo_path_data_type_t; + +typedef union _cairo_path_data_t cairo_path_data_t; +union _cairo_path_data_t { + struct { + cairo_path_data_type_t type; + int length; + } header; + struct { + double x, y; + } point; +}; + +typedef struct cairo_path { + cairo_status_t status; + cairo_path_data_t *data; + int num_data; +} cairo_path_t; + + (extern cairo_path_t * +cairo_copy_path (cairo_t *cr); + + (extern cairo_path_t * +cairo_copy_path_flat (cairo_t *cr); + + (extern void +cairo_append_path (cairo_t *cr, + const cairo_path_t *path); + + (extern void +cairo_path_destroy (cairo_path_t *path); + + +;;; Error status queries + + (extern cairo_status_t +cairo_status (cairo_t *cr); + + (extern const char * +cairo_status_to_string (cairo_status_t status); + +;;; Surface manipulation + + (extern cairo_surface_t * +cairo_surface_create_similar (cairo_surface_t *other, + cairo_content_t content, + int width, + int height); + + (extern cairo_surface_t * +cairo_surface_reference (cairo_surface_t *surface); + + (extern void +cairo_surface_finish (cairo_surface_t *surface); +|# +(extern void cairo_surface_destroy (surface (* cairo_surface_t))) +#| + (extern unsigned int +cairo_surface_get_reference_count (cairo_surface_t *surface); + + (extern cairo_status_t +cairo_surface_status (cairo_surface_t *surface); + +typedef enum _cairo_surface_type { + CAIRO_SURFACE_TYPE_IMAGE, + CAIRO_SURFACE_TYPE_PDF, + CAIRO_SURFACE_TYPE_PS, + CAIRO_SURFACE_TYPE_XLIB, + CAIRO_SURFACE_TYPE_XCB, + CAIRO_SURFACE_TYPE_GLITZ, + CAIRO_SURFACE_TYPE_QUARTZ, + CAIRO_SURFACE_TYPE_WIN32, + CAIRO_SURFACE_TYPE_BEOS, + CAIRO_SURFACE_TYPE_DIRECTFB, + CAIRO_SURFACE_TYPE_SVG, + CAIRO_SURFACE_TYPE_OS2 +} cairo_surface_type_t; + + (extern cairo_surface_type_t +cairo_surface_get_type (cairo_surface_t *surface); + + (extern cairo_content_t +cairo_surface_get_content (cairo_surface_t *surface); + +#if CAIRO_HAS_PNG_FUNCTIONS +|# +(extern cairo_status_t cairo_surface_write_to_png + (surface (* cairo_surface_t)) + (filename (const (* char)))) +#| + (extern cairo_status_t +cairo_surface_write_to_png_stream (cairo_surface_t *surface, + cairo_write_func_t write_func, + void *closure); + +#endif + + (extern void * +cairo_surface_get_user_data (cairo_surface_t *surface, + const cairo_user_data_key_t *key); + + (extern cairo_status_t +cairo_surface_set_user_data (cairo_surface_t *surface, + const cairo_user_data_key_t *key, + void *user_data, + cairo_destroy_func_t destroy); + + (extern void +cairo_surface_get_font_options (cairo_surface_t *surface, + cairo_font_options_t *options); + + (extern void +cairo_surface_flush (cairo_surface_t *surface); + + (extern void +cairo_surface_mark_dirty (cairo_surface_t *surface); + + (extern void +cairo_surface_mark_dirty_rectangle (cairo_surface_t *surface, + int x, + int y, + int width, + int height); + + (extern void +cairo_surface_set_device_offset (cairo_surface_t *surface, + double x_offset, + double y_offset); + + (extern void +cairo_surface_get_device_offset (cairo_surface_t *surface, + double *x_offset, + double *y_offset); + + (extern void +cairo_surface_set_fallback_resolution (cairo_surface_t *surface, + double x_pixels_per_inch, + double y_pixels_per_inch); +|# + +(typedef cairo_format_t + (enum _cairo_format + (CAIRO_FORMAT_ARGB32) + (CAIRO_FORMAT_RGB24) + (CAIRO_FORMAT_A8) + (CAIRO_FORMAT_A1) + ;; Obsolete: CAIRO_FORMAT_RGB16_565 = 4 + )) + + (extern (* cairo_surface_t) + cairo_image_surface_create + (format cairo_format_t) + (width int)(height int)) +#| + (extern cairo_surface_t * +cairo_image_surface_create_for_data (unsigned char *data, + cairo_format_t format, + int width, + int height, + int stride); + + (extern unsigned char * +cairo_image_surface_get_data (cairo_surface_t *surface); + + (extern cairo_format_t +cairo_image_surface_get_format (cairo_surface_t *surface); + + (extern int +cairo_image_surface_get_width (cairo_surface_t *surface); + + (extern int +cairo_image_surface_get_height (cairo_surface_t *surface); + + (extern int +cairo_image_surface_get_stride (cairo_surface_t *surface); + +#if CAIRO_HAS_PNG_FUNCTIONS + + (extern cairo_surface_t * +cairo_image_surface_create_from_png (const char *filename); + + (extern cairo_surface_t * +cairo_image_surface_create_from_png_stream (cairo_read_func_t read_func, + void *closure); + +#endif + + +;;; Pattern creation functions + + (extern cairo_pattern_t * +cairo_pattern_create_rgb (double red, double green, double blue); + + (extern cairo_pattern_t * +cairo_pattern_create_rgba (double red, double green, double blue, + double alpha); + + (extern cairo_pattern_t * +cairo_pattern_create_for_surface (cairo_surface_t *surface); + + (extern cairo_pattern_t * +cairo_pattern_create_linear (double x0, double y0, + double x1, double y1); + + (extern cairo_pattern_t * +cairo_pattern_create_radial (double cx0, double cy0, double radius0, + double cx1, double cy1, double radius1); + + (extern cairo_pattern_t * +cairo_pattern_reference (cairo_pattern_t *pattern); + + (extern void +cairo_pattern_destroy (cairo_pattern_t *pattern); + + (extern unsigned int +cairo_pattern_get_reference_count (cairo_pattern_t *pattern); + + (extern cairo_status_t +cairo_pattern_status (cairo_pattern_t *pattern); + + (extern void * +cairo_pattern_get_user_data (cairo_pattern_t *pattern, + const cairo_user_data_key_t *key); + + (extern cairo_status_t +cairo_pattern_set_user_data (cairo_pattern_t *pattern, + const cairo_user_data_key_t *key, + void *user_data, + cairo_destroy_func_t destroy); + +typedef enum _cairo_pattern_type { + CAIRO_PATTERN_TYPE_SOLID, + CAIRO_PATTERN_TYPE_SURFACE, + CAIRO_PATTERN_TYPE_LINEAR, + CAIRO_PATTERN_TYPE_RADIAL +} cairo_pattern_type_t; + + (extern cairo_pattern_type_t +cairo_pattern_get_type (cairo_pattern_t *pattern); + + (extern void +cairo_pattern_add_color_stop_rgb (cairo_pattern_t *pattern, + double offset, + double red, double green, double blue); + + (extern void +cairo_pattern_add_color_stop_rgba (cairo_pattern_t *pattern, + double offset, + double red, double green, double blue, + double alpha); + + (extern void +cairo_pattern_set_matrix (cairo_pattern_t *pattern, + const cairo_matrix_t *matrix); + + (extern void +cairo_pattern_get_matrix (cairo_pattern_t *pattern, + cairo_matrix_t *matrix); + +typedef enum _cairo_extend { + CAIRO_EXTEND_NONE, + CAIRO_EXTEND_REPEAT, + CAIRO_EXTEND_REFLECT, + CAIRO_EXTEND_PAD +} cairo_extend_t; + + (extern void +cairo_pattern_set_extend (cairo_pattern_t *pattern, cairo_extend_t extend); + + (extern cairo_extend_t +cairo_pattern_get_extend (cairo_pattern_t *pattern); + +typedef enum _cairo_filter { + CAIRO_FILTER_FAST, + CAIRO_FILTER_GOOD, + CAIRO_FILTER_BEST, + CAIRO_FILTER_NEAREST, + CAIRO_FILTER_BILINEAR, + CAIRO_FILTER_GAUSSIAN +} cairo_filter_t; + + (extern void +cairo_pattern_set_filter (cairo_pattern_t *pattern, cairo_filter_t filter); + + (extern cairo_filter_t +cairo_pattern_get_filter (cairo_pattern_t *pattern); + + (extern cairo_status_t +cairo_pattern_get_rgba (cairo_pattern_t *pattern, + double *red, double *green, + double *blue, double *alpha); + + (extern cairo_status_t +cairo_pattern_get_surface (cairo_pattern_t *pattern, + cairo_surface_t **surface); + + (extern cairo_status_t +cairo_pattern_get_color_stop_rgba (cairo_pattern_t *pattern, + int index, double *offset, + double *red, double *green, + double *blue, double *alpha); + + (extern cairo_status_t +cairo_pattern_get_color_stop_count (cairo_pattern_t *pattern, + int *count); + + (extern cairo_status_t +cairo_pattern_get_linear_points (cairo_pattern_t *pattern, + double *x0, double *y0, + double *x1, double *y1); + + (extern cairo_status_t +cairo_pattern_get_radial_circles (cairo_pattern_t *pattern, + double *x0, double *y0, double *r0, + double *x1, double *y1, double *r1); + + +;;; Matrix functions + + (extern void +cairo_matrix_init (cairo_matrix_t *matrix, + double xx, double yx, + double xy, double yy, + double x0, double y0); + + (extern void +cairo_matrix_init_identity (cairo_matrix_t *matrix); + + (extern void +cairo_matrix_init_translate (cairo_matrix_t *matrix, + double tx, double ty); + + (extern void +cairo_matrix_init_scale (cairo_matrix_t *matrix, + double sx, double sy); + + (extern void +cairo_matrix_init_rotate (cairo_matrix_t *matrix, + double radians); + + (extern void +cairo_matrix_translate (cairo_matrix_t *matrix, double tx, double ty); + + (extern void +cairo_matrix_scale (cairo_matrix_t *matrix, double sx, double sy); + + (extern void +cairo_matrix_rotate (cairo_matrix_t *matrix, double radians); + + (extern cairo_status_t +cairo_matrix_invert (cairo_matrix_t *matrix); + + (extern void +cairo_matrix_multiply (cairo_matrix_t *result, + const cairo_matrix_t *a, + const cairo_matrix_t *b); + + (extern void +cairo_matrix_transform_distance (const cairo_matrix_t *matrix, + double *dx, double *dy); +|# + +;(extern void cairo_matrix_transform_point +; (matrix (const (* cairo_matrix_t))) +; (x (* double)) (y (* double))) + +;(extern void cairo_debug_reset_static_data) diff --git a/src/gtk/Includes/gdk-pixbuf-core.cdecl b/src/gtk/Includes/gdk-pixbuf-core.cdecl new file mode 100644 index 000000000..2a5d8b64b --- /dev/null +++ b/src/gtk/Includes/gdk-pixbuf-core.cdecl @@ -0,0 +1,12 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk-pixbuf/gdk-pixbuf-core.h |# + +(extern int gdk_pixbuf_get_width (pixbuf (* (const GdkPixbuf)))) + +(extern int gdk_pixbuf_get_height (pixbuf (* (const GdkPixbuf)))) + +;(extern (* GdkPixbuf) +; gdk_pixbuf_new_from_file +; (filename (* (const char))) +; (error (* (* GError)))) \ No newline at end of file diff --git a/src/gtk/Includes/gdk-pixbuf-loader.cdecl b/src/gtk/Includes/gdk-pixbuf-loader.cdecl new file mode 100644 index 000000000..987c7a201 --- /dev/null +++ b/src/gtk/Includes/gdk-pixbuf-loader.cdecl @@ -0,0 +1,54 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk-pixbuf/gdk-pixbuf-loader.h |# + +(include "glib") +;(include "glib-object") +;(include "gdk-pixbuf-core") +;(include "gdk-pixbuf/gdk-pixbuf-animation") +;(include "gdk-pixbuf/gdk-pixbuf-io") + +(typedef GdkPixbufLoader (struct _GdkPixbufLoader)) + +(struct _GdkPixbufLoader + (parent_instance GObject) + ;; < private > + (priv gpointer)) + +;(typedef GdkPixbufLoaderClass (struct _GdkPixbufLoaderClass)) + +;(struct _GdkPixbufLoaderClass ...) + +(extern (* GdkPixbufLoader) gdk_pixbuf_loader_new) + +;(extern (* GdkPixbufLoader) gdk_pixbuf_loader_new_with_type +; (image_type (const (* char))) +; (error (* (* GError)))) + +;(extern (* GdkPixbufLoader) gdk_pixbuf_loader_new_with_mime_type +; (mime_type (const (* char))) +; (error (* (* GError)))) + +;(extern void gdk_pixbuf_loader_set_size +; (loader (* GdkPixbufLoader)) +; (width int) +; (height int)) + +(extern gboolean gdk_pixbuf_loader_write + (loader (* GdkPixbufLoader)) + (buf (const (* guchar))) + (count gsize) + (error (* (* GError)))) + +(extern (* GdkPixbuf) gdk_pixbuf_loader_get_pixbuf + (loader (* GdkPixbufLoader))) + +;(extern (* GdkPixbufAnimation) gdk_pixbuf_loader_get_animation +; (loader (* GdkPixbufLoader))) + +(extern gboolean gdk_pixbuf_loader_close + (loader (* GdkPixbufLoader)) + (error (* (* GError)))) + +;(extern (* GdkPixbufFormat) gdk_pixbuf_loader_get_format +; (loader (* GdkPixbufLoader))) \ No newline at end of file diff --git a/src/gtk/Includes/gdk-pixbuf.cdecl b/src/gtk/Includes/gdk-pixbuf.cdecl new file mode 100644 index 000000000..c83c253bb --- /dev/null +++ b/src/gtk/Includes/gdk-pixbuf.cdecl @@ -0,0 +1,15 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk-pixbuf/gdk-pixbuf.h |# + +(include "glib") +;(include "gdk-pixbuf-features") +;(include "glib-object") + +(include "gdk-pixbuf-core") +;(include "gdk-pixbuf-transform") +;(include "gdk-pixbuf-animation") +;(include "gdk-pixbuf-simple-anim") +;(include "gdk-pixbuf-io") +(include "gdk-pixbuf-loader") +;(include "gdk-pixbuf-enum-types") \ No newline at end of file diff --git a/src/gtk/Includes/gdk.cdecl b/src/gtk/Includes/gdk.cdecl new file mode 100644 index 000000000..18e1e62f5 --- /dev/null +++ b/src/gtk/Includes/gdk.cdecl @@ -0,0 +1,51 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdk.h |# + +(include "gtypes") +;; gtypes.scm does not seem to be the place for this. +(include "gtype") +(include "gquark") +(include "genums") +(include "gobject") +(include "gvalue") +(include "gvaluetypes") +(include "gparam") +(include "gparamspecs") +(include "gsignal") + +;(include "gdkcairo") +(include "gdkcolor") +(include "gdkcursor") +;(include "gdkdisplay") +;(include "gdkdnd") +(include "gdkdrawable") +;(include "gdkenumtypes") +(include "gdkevents") +;(include "gdkfont") +(include "gdkgc") +;(include "gdkimage") +;(include "gdkinput") +(include "gdkkeys") +;(include "gdkdisplaymanager") +;(include "gdkpango") +;(include "gdkpixbuf") +;(include "gdkpixmap") +;(include "gdkproperty") +;(include "gdkregion") +(include "gdkrgb") +;(include "gdkscreen") +;(include "gdkselection") +;(include "gdkspawn") +(include "gdktypes") +;(include "gdkvisual") +(include "gdkwindow") + +(extern gboolean gdk_rectangle_intersect + (src1 (* GdkRectangle)) + (src2 (* GdkRectangle)) + (dest (* GdkRectangle))) +(extern void gdk_rectangle_union + (src1 (* GdkRectangle)) + (src2 (* GdkRectangle)) + (dest (* GdkRectangle))) \ No newline at end of file diff --git a/src/gtk/Includes/gdkcolor.cdecl b/src/gtk/Includes/gdkcolor.cdecl new file mode 100644 index 000000000..9535948dd --- /dev/null +++ b/src/gtk/Includes/gdkcolor.cdecl @@ -0,0 +1,63 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkcolor.h |# + +;(include "cairo") +;(include "gdktypes") + +(struct _GdkColor + (pixel guint32) + (red guint16) + (green guint16) + (blue guint16)) + +;(typedef GdkColormapClass (struct _GdkColormapClass)) + +(struct _GdkColormap + (parent_instance GObject) + (size gint) + (colors (* GdkColor)) + (visual (* GdkVisual)) + (windowing_data gpointer)) + +;(struct _GdkColormapClass +; (parent_class GObjectClass)) +; +;(extern GType gdk_colormap_get_type) +; +;(extern (* GdkColormap) gdk_colormap_new +; (visual (* GdkVisual)) (allocate gboolean)) +;(extern (* GdkScreen) gdk_colormap_get_screen +; (cmap (* GdkColormap))) +;(extern gint gdk_colormap_alloc_colors +; (colormap (* GdkColormap)) +; (colors (* GdkColor)) (ncolors gint) +; (writeable gboolean) (best_match gboolean) (success (* gboolean))) +;(extern gboolean gdk_colormap_alloc_color +; (colormap (* GdkColormap)) +; (color (* GdkColor)) +; (writeable gboolean) +; (best_match gboolean)) +;(extern void gdk_colormap_free_colors +; (colormap (* GdkColormap)) +; (colors (* GdkColor)) +; (ncolors gint)) +;(extern void gdk_colormap_query_color +; (colormap (* GdkColormap)) +; (pixel gulong) +; (result (* GdkColor))) +; +;(extern (* GdkVisual) gdk_colormap_get_visual +; (colormap (* GdkColormap))) +;(extern (* GdkColor) gdk_color_copy +; (color (const (* GdkColor)))) +;(extern void gdk_color_free +; (color (* GdkColor))) +;(extern gint gdk_color_parse +; (spec (const (* gchar))) +; (color (* GdkColor))) +;(extern guint gdk_color_hash +; (colora (const (* GdkColor)))) +;(extern gboolean gdk_color_equal +; (colora (const (* GdkColor))) +; (colorb (const (* GdkColor)))) \ No newline at end of file diff --git a/src/gtk/Includes/gdkcursor.cdecl b/src/gtk/Includes/gdkcursor.cdecl new file mode 100644 index 000000000..ed2f60634 --- /dev/null +++ b/src/gtk/Includes/gdkcursor.cdecl @@ -0,0 +1,99 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkcursor.h |# + +;(include "gdktypes") +;(include "gdk-pixbuf") + +(typedef GdkCursorType + (enum + (GDK_X_CURSOR) + (GDK_ARROW) + (GDK_BASED_ARROW_DOWN) + (GDK_BASED_ARROW_UP) + (GDK_BOAT) + (GDK_BOGOSITY) + (GDK_BOTTOM_LEFT_CORNER) + (GDK_BOTTOM_RIGHT_CORNER) + (GDK_BOTTOM_SIDE) + (GDK_BOTTOM_TEE) + (GDK_BOX_SPIRAL) + (GDK_CENTER_PTR) + (GDK_CIRCLE) + (GDK_CLOCK) + (GDK_COFFEE_MUG) + (GDK_CROSS) + (GDK_CROSS_REVERSE) + (GDK_CROSSHAIR) + (GDK_DIAMOND_CROSS) + (GDK_DOT) + (GDK_DOTBOX) + (GDK_DOUBLE_ARROW) + (GDK_DRAFT_LARGE) + (GDK_DRAFT_SMALL) + (GDK_DRAPED_BOX) + (GDK_EXCHANGE) + (GDK_FLEUR) + (GDK_GOBBLER) + (GDK_GUMBY) + (GDK_HAND1) + (GDK_HAND2) + (GDK_HEART) + (GDK_ICON) + (GDK_IRON_CROSS) + (GDK_LEFT_PTR) + (GDK_LEFT_SIDE) + (GDK_LEFT_TEE) + (GDK_LEFTBUTTON) + (GDK_LL_ANGLE) + (GDK_LR_ANGLE) + (GDK_MAN) + (GDK_MIDDLEBUTTON) + (GDK_MOUSE) + (GDK_PENCIL) + (GDK_PIRATE) + (GDK_PLUS) + (GDK_QUESTION_ARROW) + (GDK_RIGHT_PTR) + (GDK_RIGHT_SIDE) + (GDK_RIGHT_TEE) + (GDK_RIGHTBUTTON) + (GDK_RTL_LOGO) + (GDK_SAILBOAT) + (GDK_SB_DOWN_ARROW) + (GDK_SB_H_DOUBLE_ARROW) + (GDK_SB_LEFT_ARROW) + (GDK_SB_RIGHT_ARROW) + (GDK_SB_UP_ARROW) + (GDK_SB_V_DOUBLE_ARROW) + (GDK_SHUTTLE) + (GDK_SIZING) + (GDK_SPIDER) + (GDK_SPRAYCAN) + (GDK_STAR) + (GDK_TARGET) + (GDK_TCROSS) + (GDK_TOP_LEFT_ARROW) + (GDK_TOP_LEFT_CORNER) + (GDK_TOP_RIGHT_CORNER) + (GDK_TOP_SIDE) + (GDK_TOP_TEE) + (GDK_TREK) + (GDK_UL_ANGLE) + (GDK_UMBRELLA) + (GDK_UR_ANGLE) + (GDK_WATCH) + (GDK_XTERM) + (GDK_LAST_CURSOR) + (GDK_CURSOR_IS_PIXMAP))) + +(struct _GdkCursor + (type GdkCursorType) + ;; < private > + (ref_count guint)) + +(extern (* GdkCursor) gdk_cursor_new + (cursor_type GdkCursorType)) + +(extern void gdk_cursor_destroy + (cursor (* GdkCursor))) \ No newline at end of file diff --git a/src/gtk/Includes/gdkdrawable.cdecl b/src/gtk/Includes/gdkdrawable.cdecl new file mode 100644 index 000000000..9cbd6e010 --- /dev/null +++ b/src/gtk/Includes/gdkdrawable.cdecl @@ -0,0 +1,93 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkdrawable.h |# + +;(include "gdktypes") +;(include "gdkgc") +;(include "gdkrgb") +;(include "gdk-pixbuf") +;(include "cairo") + +(typedef GdkDrawableClass (struct _GdkDrawableClass)) +(typedef GdkTrapezoid (struct _GdkTrapezoid)) + +(struct _GdkDrawable + (parent_instance GObject)) + +(struct _GdkDrawableClass + (parent_class GObjectClass) + (create_gc + (* (function (* GdkGC) + (drawable (* GdkDrawable)) + (values (* GdkGCValues)) + (mask GdkGCValuesMask)))) + (draw_rectangle (* mumble)) + (draw_arc (* mumble)) + (draw_polygon (* mumble)) + (draw_text (* mumble)) + (draw_text_wc (* mumble)) + (draw_drawable (* mumble)) + (draw_points (* mumble)) + (draw_segments (* mumble)) + (draw_lines (* mumble)) + (draw_glyphs (* mumble)) + (draw_image (* mumble)) + + (get_depth (* mumble)) + (get_size (* mumble)) + (set_colormap (* mumble)) + (get_colormap (* mumble)) + (get_visual (* mumble)) + (get_screen (* mumble)) + (get_image (* mumble)) + (get_clip_region (* mumble)) + (get_visible_region (* mumble)) + (get_composite_drawable (* mumble)) + (draw_pixbuf (* mumble)) + (_copy_to_image (* mumble)) + (draw_glyphs_transformed (* mumble)) + (draw_trapezoids (* mumble)) + (ref_cairo_surface (* mumble)) + (_gdk_reserved4 (* mumble)) + (_gdk_reserved5 (* mumble)) + (_gdk_reserved6 (* mumble)) + (_gdk_reserved7 (* mumble)) + (_gdk_reserved9 (* mumble)) + (_gdk_reserved10 (* mumble)) + (_gdk_reserved11 (* mumble)) + (_gdk_reserved12 (* mumble)) + (_gdk_reserved13 (* mumble)) + (_gdk_reserved14 (* mumble)) + (_gdk_reserved15 (* mumble)) + (_gdk_reserved16 (* mumble))) + +(struct _GdkTrapezoid + (y1 double) + (x11 double) + (x21 double) + (y2 double) + (x12 double) + (x22 double)) + +(extern void gdk_draw_rectangle + (drawable (* GdkDrawable)) + (gc (* GdkGC)) + (filled gboolean) + (x gint) + (y gint) + (width gint) + (height gint)) + +(extern void gdk_draw_pixbuf + (drawable (* GdkDrawable)) + (gc (* GdkGC)) + (pixbuf (* GdkPixbuf)) + (src_x gint) + (src_y gint) + (dest_x gint) + (dest_y gint) + (width gint) + (height gint) + (dither GdkRgbDither) + (x_dither gint) + (y_dither gint)) \ No newline at end of file diff --git a/src/gtk/Includes/gdkevents.cdecl b/src/gtk/Includes/gdkevents.cdecl new file mode 100644 index 000000000..6a2c627f9 --- /dev/null +++ b/src/gtk/Includes/gdkevents.cdecl @@ -0,0 +1,428 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkevents.h |# + +;(include "gdkcolor") +;(include "gdktypes") +;(include "gdkdnd") +;(include "gdkinput") + +;(enum (GDK_PRIORITY_EVENTS) +; (GDK_PRIORITY_REDRAW)) + +(typedef GdkEventAny (struct _GdkEventAny)) +(typedef GdkEventExpose (struct _GdkEventExpose)) +(typedef GdkEventNoExpose (struct _GdkEventNoExpose)) +(typedef GdkEventVisibility (struct _GdkEventVisibility)) +(typedef GdkEventMotion (struct _GdkEventMotion)) +(typedef GdkEventButton (struct _GdkEventButton)) +(typedef GdkEventScroll (struct _GdkEventScroll)) +(typedef GdkEventKey (struct _GdkEventKey)) +(typedef GdkEventFocus (struct _GdkEventFocus)) +(typedef GdkEventCrossing (struct _GdkEventCrossing)) +(typedef GdkEventConfigure (struct _GdkEventConfigure)) +(typedef GdkEventProperty (struct _GdkEventProperty)) +(typedef GdkEventSelection (struct _GdkEventSelection)) +(typedef GdkEventOwnerChange (struct _GdkEventOwnerChange)) +(typedef GdkEventProximity (struct _GdkEventProximity)) +(typedef GdkEventClient (struct _GdkEventClient)) +(typedef GdkEventDND (struct _GdkEventDND)) +(typedef GdkEventWindowState (struct _GdkEventWindowState)) +(typedef GdkEventSetting (struct _GdkEventSetting)) +(typedef GdkEventGrabBroken (struct _GdkEventGrabBroken)) + +(typedef GdkEvent (union _GdkEvent)) + +(typedef GdkEventFunc (* (function void + (event (* GdkEvent)) + (data gpointer)))) + +;(typedef GdkXEvent void) + +(typedef GdkFilterReturn + (enum + (GDK_FILTER_CONTINUE) + (GDK_FILTER_TRANSLATE) + (GDK_FILTER_REMOVE))) + +(typedef GdkFilterFunc + (* (function GdkFilterReturn + (xevent (* GdkXEvent)) + (event (* GdkEvent)) + (data gpointer)))) + +(typedef GdkEventType + (enum + (GDK_NOTHING) + (GDK_DELETE) + (GDK_DESTROY) + (GDK_EXPOSE) + (GDK_MOTION_NOTIFY) + (GDK_BUTTON_PRESS) + (GDK_2BUTTON_PRESS) + (GDK_3BUTTON_PRESS) + (GDK_BUTTON_RELEASE) + (GDK_KEY_PRESS) + (GDK_KEY_RELEASE) + (GDK_ENTER_NOTIFY) + (GDK_LEAVE_NOTIFY) + (GDK_FOCUS_CHANGE) + (GDK_CONFIGURE) + (GDK_MAP) + (GDK_UNMAP) + (GDK_PROPERTY_NOTIFY) + (GDK_SELECTION_CLEAR) + (GDK_SELECTION_REQUEST) + (GDK_SELECTION_NOTIFY) + (GDK_PROXIMITY_IN) + (GDK_PROXIMITY_OUT) + (GDK_DRAG_ENTER) + (GDK_DRAG_LEAVE) + (GDK_DRAG_MOTION) + (GDK_DRAG_STATUS) + (GDK_DROP_START) + (GDK_DROP_FINISHED) + (GDK_CLIENT_EVENT) + (GDK_VISIBILITY_NOTIFY) + (GDK_NO_EXPOSE) + (GDK_SCROLL) + (GDK_WINDOW_STATE) + (GDK_SETTING) + (GDK_OWNER_CHANGE))) + +(typedef GdkEventMask + (enum + (GDK_EXPOSURE_MASK) + (GDK_POINTER_MOTION_MASK) + (GDK_POINTER_MOTION_HINT_MASK) + (GDK_BUTTON_MOTION_MASK) + (GDK_BUTTON1_MOTION_MASK) + (GDK_BUTTON2_MOTION_MASK) + (GDK_BUTTON3_MOTION_MASK) + (GDK_BUTTON_PRESS_MASK) + (GDK_BUTTON_RELEASE_MASK) + (GDK_KEY_PRESS_MASK) + (GDK_KEY_RELEASE_MASK) + (GDK_ENTER_NOTIFY_MASK) + (GDK_LEAVE_NOTIFY_MASK) + (GDK_FOCUS_CHANGE_MASK) + (GDK_STRUCTURE_MASK) + (GDK_PROPERTY_CHANGE_MASK) + (GDK_VISIBILITY_NOTIFY_MASK) + (GDK_PROXIMITY_IN_MASK) + (GDK_PROXIMITY_OUT_MASK) + (GDK_SUBSTRUCTURE_MASK) + (GDK_SCROLL_MASK) + (GDK_ALL_EVENTS_MASK))) + +(typedef GdkVisibilityState + (enum + (GDK_VISIBILITY_UNOBSCURED) + (GDK_VISIBILITY_PARTIAL) + (GDK_VISIBILITY_FULLY_OBSCURED))) + +(typedef GdkScrollDirection + (enum + (GDK_SCROLL_UP) + (GDK_SCROLL_DOWN) + (GDK_SCROLL_LEFT) + (GDK_SCROLL_RIGHT))) + +(typedef GdkNotifyType + (enum + (GDK_NOTIFY_ANCESTOR) + (GDK_NOTIFY_VIRTUAL) + (GDK_NOTIFY_INFERIOR) + (GDK_NOTIFY_NONLINEAR) + (GDK_NOTIFY_NONLINEAR_VIRTUAL) + (GDK_NOTIFY_UNKNOWN))) + +(typedef GdkCrossingMode + (enum + (GDK_CROSSING_NORMAL) + (GDK_CROSSING_GRAB) + (GDK_CROSSING_UNGRAB))) + +(typedef GdkPropertyState + (enum + (GDK_PROPERTY_NEW_VALUE) + (GDK_PROPERTY_DELETE))) + +(typedef GdkWindowState + (enum + (GDK_WINDOW_STATE_WITHDRAWN) + (GDK_WINDOW_STATE_ICONIFIED) + (GDK_WINDOW_STATE_MAXIMIZED) + (GDK_WINDOW_STATE_STICKY) + (GDK_WINDOW_STATE_FULLSCREEN) + (GDK_WINDOW_STATE_ABOVE) + (GDK_WINDOW_STATE_BELOW))) + +(typedef GdkSettingAction + (enum + (GDK_SETTING_ACTION_NEW) + (GDK_SETTING_ACTION_CHANGED) + (GDK_SETTING_ACTION_DELETED))) + +(typedef GdkOwnerChange + (enum + (GDK_OWNER_CHANGE_NEW_OWNER) + (GDK_OWNER_CHANGE_DESTROY) + (GDK_OWNER_CHANGE_CLOSE))) + +(struct _GdkEventAny + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8)) + +(struct _GdkEventExpose + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (area GdkRectangle) + (region (* GdkRegion)) + (count gint)) + +(struct _GdkEventNoExpose + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8)) + +(struct _GdkEventVisibility + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (state GdkVisibilityState)) + +(struct _GdkEventMotion + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (time guint32) + (x gdouble) + (y gdouble) + (axes (* gdouble)) + (state guint) + (is_hint gint16) + (device (* GdkDevice)) + (x_root gdouble) + (y_root gdouble)) + +(struct _GdkEventButton + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (time guint32) + (x gdouble) + (y gdouble) + (axes (* gdouble)) + (state guint) + (button guint) + (device (* GdkDevice)) + (x_root gdouble) + (y_root gdouble)) + +(struct _GdkEventScroll + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (time guint32) + (x gdouble) + (y gdouble) + (state guint) + (direction GdkScrollDirection) + (device (* GdkDevice)) + (x_root gdouble) + (y_root gdouble)) + +(struct _GdkEventKey + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (time guint32) + (state guint) + (keyval guint) + (length gint) + (string (* gchar)) + (hardware_keycode guint16) + (group guint8)) + +(struct _GdkEventCrossing + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (subwindow (* GdkWindow)) + (time guint32) + (x gdouble) + (y gdouble) + (x_root gdouble) + (y_root gdouble) + (mode GdkCrossingMode) + (detail GdkNotifyType) + (focus gboolean) + (state guint)) + +(struct _GdkEventFocus + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (in gint16)) + +(struct _GdkEventConfigure + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (x gint) + (y gint) + (width gint) + (height gint)) + +(struct _GdkEventProperty + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (atom GdkAtom) + (time guint32) + (state guint)) + +(struct _GdkEventSelection + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (selection GdkAtom) + (target GdkAtom) + (property GdkAtom) + (time guint32) + (requestor GdkNativeWindow)) + +(struct _GdkEventOwnerChange + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (owner GdkNativeWindow) + (reason GdkOwnerChange) + (selection GdkAtom) + (time guint32) + (selection_time guint32)) + +(struct _GdkEventProximity + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (time guint32) + (device (* GdkDevice))) + +(struct _GdkEventClient + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (message_type GdkAtom) + (data_format gushort) + (data (union + (b (array char 20)) + (s (array short 10)) + (l (array long 5))))) + +(struct _GdkEventSetting + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (action GdkSettingAction) + (name (* char))) + +(struct _GdkEventWindowState + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (changed_mask GdkWindowState) + (new_window_state GdkWindowState)) + +(struct _GdkEventGrabBroken + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (keyboard gboolean) + (implicit gboolean) + (grab_window (* GdkWindow))) + +(struct _GdkEventDND + (type GdkEventType) + (window (* GdkWindow)) + (send_event gint8) + (context (* GdkDragContext)) + (time guint32) + (x_root gshort) + (y_root gshort)) + +(union _GdkEvent + (type GdkEventType) + (any GdkEventAny) + (expose GdkEventExpose) + (no_expose GdkEventNoExpose) + (visibility GdkEventVisibility) + (motion GdkEventMotion) + (button GdkEventButton) + (scroll GdkEventScroll) + (key GdkEventKey) + (crossing GdkEventCrossing) + (focus_change GdkEventFocus) + (configure GdkEventConfigure) + (property GdkEventProperty) + (selection GdkEventSelection) + (owner_change GdkEventOwnerChange) + (proximity GdkEventProximity) + (client GdkEventClient) + (dnd GdkEventDND) + (window_state GdkEventWindowState) + (setting GdkEventSetting) + (grab_broken GdkEventGrabBroken)) + +;Most of these externs are commented out just to avoid inflating +;gtk.so with a lot of useless or redundant trampolines. +; +;(extern GType gdk_event_get_type) +;(extern gboolean gdk_events_pending) +;(extern (* GdkEvent) gdk_event_get) +;(extern (* GdkEvent) gdk_event_peek) +;(extern (* GdkEvent) gdk_event_get_graphics_expose +; (window (* GdkWindow))) +;(extern void gdk_event_put +; (event (* GdkEvent))) +; +;(extern (* GdkEvent) gdk_event_new +; (type GdkEventType)) +(extern (* GdkEvent) gdk_event_copy + (event (* GdkEvent))) +(extern void gdk_event_free + (event (* GdkEvent))) +(extern guint32 gdk_event_get_time + (event (* GdkEvent))) +;(extern gboolean gdk_event_get_state +; (event (* GdkEvent)) +; (state (* GdkModifierType))) +;(extern gboolean gdk_event_get_coords +; (event (* GdkEvent)) +; (x_win (* gdouble)) +; (y_win (* gdouble))) +;(extern gboolean gdk_event_get_root_coords +; (event (* GdkEvent)) +; (x_root (* gdouble)) +; (y_root (* gdouble))) +;(extern gboolean gdk_event_get_axis +; (event (* GdkEvent)) +; (axis_use GdkAxisUse) +; (value (* gdouble))) +;(extern void gdk_event_handler_set +; (func GdkEventFunc) +; (data gpointer) +; (notify GDestroyNotify)) +; +;(extern void gdk_event_set_screen +; (event (* GdkEvent)) (screen (* GdkScreen))) +; +;(extern (* GdkScreen) gdk_event_get_screen +; (event (* GdkEvent))) +; +;(extern void gdk_set_show_events +; (show_events gboolean)) +;(extern gboolean gdk_get_show_events) \ No newline at end of file diff --git a/src/gtk/Includes/gdkfont.cdecl b/src/gtk/Includes/gdkfont.cdecl new file mode 100644 index 000000000..da0968e0d --- /dev/null +++ b/src/gtk/Includes/gdkfont.cdecl @@ -0,0 +1,38 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkfont.h |# + +;(include "gdktypes") +;(include "pango-font") + +(typedef GdkFontType + (enum + (GDK_FONT_FONT) + (GDK_FONT_FONTSET))) + +(struct _GdkFont + (type GdkFontType) + (ascent gint) + (descent gint)) + +(extern GType gdk_font_get_type) + +(extern (* GdkFont) gdk_font_ref + ((* GdkFont) font)) +(extern void gdk_font_unref + ((* GdkFont) font)) +(extern gint gdk_font_id + (font (const (* GdkFont)))) +(extern gboolean gdk_font_equal + (fonta (const (* GdkFont))) + (fontb (const (* GdkFont)))) + +(extern (* GdkFont) gdk_font_load_for_display + (display (* GdkDisplay)) + (font_name (const (* gchar)))) +(extern (* GdkFont) gdk_fontset_load_for_display + (GdkDisplay *display) + (const gchar *fontset_name)) +(extern (* GdkFont) gdk_font_from_description_for_display + (GdkDisplay *display) + (PangoFontDescription *font_desc)) \ No newline at end of file diff --git a/src/gtk/Includes/gdkgc.cdecl b/src/gtk/Includes/gdkgc.cdecl new file mode 100644 index 000000000..1aa8f0876 --- /dev/null +++ b/src/gtk/Includes/gdkgc.cdecl @@ -0,0 +1,215 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkgc.h |# + +;(include "gdkcolor") +;(include "gdktypes") + +(typedef GdkGCValues (struct _GdkGCValues)) +(typedef GdkGCClass (struct _GdkGCClass)) + +(typedef GdkCapStyle + (enum + (GDK_CAP_NOT_LAST) + (GDK_CAP_BUTT) + (GDK_CAP_ROUND) + (GDK_CAP_PROJECTING))) + +(typedef GdkFill + (enum + (GDK_SOLID) + (GDK_TILED) + (GDK_STIPPLED) + (GDK_OPAQUE_STIPPLED))) + +(typedef GdkFunction + (enum + (GDK_COPY) + (GDK_INVERT) + (GDK_XOR) + (GDK_CLEAR) + (GDK_AND) + (GDK_AND_REVERSE) + (GDK_AND_INVERT) + (GDK_NOOP) + (GDK_OR) + (GDK_EQUIV) + (GDK_OR_REVERSE) + (GDK_COPY_INVERT) + (GDK_OR_INVERT) + (GDK_NAND) + (GDK_NOR) + (GDK_SET))) + +(typedef GdkJoinStyle + (enum + (GDK_JOIN_MITER) + (GDK_JOIN_ROUND) + (GDK_JOIN_BEVEL))) + +(typedef GdkLineStyle + (enum + (GDK_LINE_SOLID) + (GDK_LINE_ON_OFF_DASH) + (GDK_LINE_DOUBLE_DASH))) + +(typedef GdkSubwindowMode + (enum + (GDK_CLIP_BY_CHILDREN) + (GDK_INCLUDE_INFERIORS))) + +(typedef GdkGCValuesMask + (enum + (GDK_GC_FOREGROUND) + (GDK_GC_BACKGROUND) + (GDK_GC_FONT) + (GDK_GC_FUNCTION) + (GDK_GC_FILL) + (GDK_GC_TILE) + (GDK_GC_STIPPLE) + (GDK_GC_CLIP_MASK) + (GDK_GC_SUBWINDOW) + (GDK_GC_TS_X_ORIGIN) + (GDK_GC_TS_Y_ORIGIN) + (GDK_GC_CLIP_X_ORIGIN) + (GDK_GC_CLIP_Y_ORIGIN) + (GDK_GC_EXPOSURES) + (GDK_GC_LINE_WIDTH) + (GDK_GC_LINE_STYLE) + (GDK_GC_CAP_STYLE) + (GDK_GC_JOIN_STYLE))) + +(struct _GdkGCValues + (foreground GdkColor) + (background GdkColor) + (font (* GdkFont)) + (function GdkFunction) + (fill GdkFill) + (tile (* GdkPixmap)) + (stipple (* GdkPixmap)) + (clip_mask (* GdkPixmap)) + (subwindow_mode GdkSubwindowMode) + (ts_x_origin gint) + (ts_y_origin gint) + (clip_x_origin gint) + (clip_y_origin gint) + (graphics_exposures gint) + (line_width gint) + (line_style GdkLineStyle) + (cap_style GdkCapStyle) + (join_style GdkJoinStyle)) + +(struct _GdkGC + (parent_instance GObject) + (clip_x_origin gint) + (clip_y_origin gint) + (ts_x_origin gint) + (ts_y_origin gint) + (colormap (* GdkColormap))) + +(struct _GdkGCClass + (parent_class GObjectClass) + (get_values (* (function void + (gc (* GdkGC)) + (values (* GdkGCValues))))) + (set_values (* (function void + (GdkGC *gc) + (GdkGCValues *values) + (GdkGCValuesMask mask)))) + (set_dashes (* (function void + (gc (* GdkGC)) + (dash_offset gint) + (dash_list (array gint8)) + (gint n)))) + + ;; Padding for future expansion + (_gdk_reserved1 (* (function void))) + (_gdk_reserved2 (* (function void))) + (_gdk_reserved3 (* (function void))) + (_gdk_reserved4 (* (function void)))) + +;(extern GType gdk_gc_get_type) +;(extern (* GdkGC) gdk_gc_new +; (drawable (* GdkDrawable))) +;(extern (* GdkGC) gdk_gc_new_with_values +; (drawable (* GdkDrawable)) +; (values (* GdkGCValues)) +; (values_mask GdkGCValuesMask)) +;(extern void gdk_gc_get_values +; (gc (* GdkGC)) +; (values (* GdkGCValues))) +;(extern void gdk_gc_set_values +; (gc (* GdkGC)) +; (values (* GdkGCValues)) +; (values_mask GdkGCValuesMask)) +;(extern void gdk_gc_set_foreground +; (gc (* GdkGC)) +; (color (const (* GdkColor)))) +;(extern void gdk_gc_set_background +; (gc (* GdkGC)) +; (color (const (* GdkColor)))) +;(extern void gdk_gc_set_function +; (gc (* GdkGC)) +; (function GdkFunction)) +;(extern void gdk_gc_set_fill +; (gc (* GdkGC)) +; (fill GdkFill)) +;(extern void gdk_gc_set_tile +; (gc (* GdkGC)) +; (tile (* GdkPixmap))) +;(extern void gdk_gc_set_stipple +; (gc (* GdkGC)) +; (stipple (* GdkPixmap))) +;(extern void gdk_gc_set_ts_origin +; (gc (* GdkGC)) +; (x gint) (y gint)) +;(extern void gdk_gc_set_clip_origin +; (gc (* GdkGC)) +; (x gint) (y gint)) +;(extern void gdk_gc_set_clip_mask +; (gc (* GdkGC)) +; (mask (* GdkBitmap))) +(extern void gdk_gc_set_clip_rectangle + (gc (* GdkGC)) + (rectangle (* GdkRectangle))) +;(extern void gdk_gc_set_clip_region +; (gc (* GdkGC)) +; (region (* GdkRegion))) +;(extern void gdk_gc_set_subwindow +; (gc (* GdkGC)) +; (mode GdkSubwindowMode)) +;(extern void gdk_gc_set_exposures +; (gc (* GdkGC)) +; (exposures gboolean)) +;(extern void gdk_gc_set_line_attributes +; (gc (* GdkGC)) +; (line_width gint) +; (line_style GdkLineStyle) +; (cap_style GdkCapStyle) +; (join_style GdkJoinStyle)) +;(extern void gdk_gc_set_dashes +; (gc (* GdkGC)) +; (dash_offset gint) +; (dash_list (array gint8)) +; (n gint)) +;(extern void gdk_gc_offset +; (gc (* GdkGC)) +; (x_offset gint) +; (y_offset gint)) +;(extern void gdk_gc_copy +; (dst_gc (* GdkGC)) +; (src_gc (* GdkGC))) +; +;(extern void gdk_gc_set_colormap +; (gc (* GdkGC)) +; (colormap (* GdkColormap))) +;(extern (* GdkColormap) gdk_gc_get_colormap +; (gc (* GdkGC))) +;(extern void gdk_gc_set_rgb_fg_color +; (gc (* GdkGC)) +; (color (const (* GdkColor)))) +;(extern void gdk_gc_set_rgb_bg_color +; (gc (* GdkGC)) +; (color (const (* GdkColor)))) +;(extern (* GdkScreen) gdk_gc_get_screen +; (gc (* GdkGC))) \ No newline at end of file diff --git a/src/gtk/Includes/gdkkeys.cdecl b/src/gtk/Includes/gdkkeys.cdecl new file mode 100644 index 000000000..bb8f8d9e7 --- /dev/null +++ b/src/gtk/Includes/gdkkeys.cdecl @@ -0,0 +1,63 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkkeys.h |# + +;(include "gdktypes") + +(typedef GdkKeymapKey (struct _GdkKeymapKey)) + +(struct _GdkKeymapKey + (keycode guint) + (group gint) + (level gint)) + +(typedef GdkKeymap (struct _GdkKeymap)) +(typedef GdkKeymapClass (struct _GdkKeymapClass)) +(struct _GdkKeymap + (parent_instance GObject) + (display (* GdkDisplay))) + +(struct _GdkKeymapClass + (parent_class GObjectClass) + (direction_changed (* (function void (keymap (* GdkKeymap))))) + (keys_changed (* (function void (keymap (* GdkKeymap)))))) + +;(extern (* GdkKeymap) gdk_keymap_get_for_display +; (display (* GdkDisplay))) +; +;(extern guint gdk_keymap_lookup_key +; (keymap (* GdkKeymap)) +; (key (const (* GdkKeymapKey)))) +;(extern gboolean gdk_keymap_translate_keyboard_state +; (keymap (* GdkKeymap)) +; (hardware_keycode guint) +; (state GdkModifierType) +; (group gint) +; (keyval (* guint)) +; (effective_group (* gint)) +; (level (* gint)) +; (consumed_modifiers (* GdkModifierType))) +;(extern gboolean gdk_keymap_get_entries_for_keyval +; ((* GdkKeymap) keymap) +; (keyval guint) +; (keys (* (* GdkKeymapKey))) +; (n_keys (* gint))) +;(extern gboolean gdk_keymap_get_entries_for_keycode +; (keymap (* GdkKeymap)) +; (hardware_keycode guint) +; (keys (* (* GdkKeymapKey))) +; (keyvals (* (* guint))) +; (n_entries (* gint))) +;(extern PangoDirection gdk_keymap_get_direction (keymap (* GdkKeymap))) + +(extern (* gchar) gdk_keyval_name (keyval guint)) +;(extern guint gdk_keyval_from_name (keyval_name (const (* gchar)))) +;(extern void gdk_keyval_convert_case +; (symbol guint) (lower (* guint)) (upper (* guint))) +;(extern guint gdk_keyval_to_upper (keyval guint)) +;(extern guint gdk_keyval_to_lower (keyval guint)) +;(extern gboolean gdk_keyval_is_upper (keyval guint)) +;(extern gboolean gdk_keyval_is_lower (keyval guint)) +; +;(extern guint32 gdk_keyval_to_unicode (keyval guint)) +;(extern guint gdk_unicode_to_keyval (wc guint32)) \ No newline at end of file diff --git a/src/gtk/Includes/gdkkeysyms.cdecl b/src/gtk/Includes/gdkkeysyms.cdecl new file mode 100644 index 000000000..77e9841d1 --- /dev/null +++ b/src/gtk/Includes/gdkkeysyms.cdecl @@ -0,0 +1,1713 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkkeysyms.h |# + +(enum GdkKeysyms + (GDK_VoidSymbol) + (GDK_BackSpace) + (GDK_Tab) + (GDK_Linefeed) + (GDK_Clear) + (GDK_Return) + (GDK_Pause) + (GDK_Scroll_Lock) + (GDK_Sys_Req) + (GDK_Escape) + (GDK_Delete) + (GDK_Multi_key) + (GDK_Codeinput) + (GDK_SingleCandidate) + (GDK_MultipleCandidate) + (GDK_PreviousCandidate) + (GDK_Kanji) + (GDK_Muhenkan) + (GDK_Henkan_Mode) + (GDK_Henkan) + (GDK_Romaji) + (GDK_Hiragana) + (GDK_Katakana) + (GDK_Hiragana_Katakana) + (GDK_Zenkaku) + (GDK_Hankaku) + (GDK_Zenkaku_Hankaku) + (GDK_Touroku) + (GDK_Massyo) + (GDK_Kana_Lock) + (GDK_Kana_Shift) + (GDK_Eisu_Shift) + (GDK_Eisu_toggle) + (GDK_Kanji_Bangou) + (GDK_Zen_Koho) + (GDK_Mae_Koho) + (GDK_Home) + (GDK_Left) + (GDK_Up) + (GDK_Right) + (GDK_Down) + (GDK_Prior) + (GDK_Page_Up) + (GDK_Next) + (GDK_Page_Down) + (GDK_End) + (GDK_Begin) + (GDK_Select) + (GDK_Print) + (GDK_Execute) + (GDK_Insert) + (GDK_Undo) + (GDK_Redo) + (GDK_Menu) + (GDK_Find) + (GDK_Cancel) + (GDK_Help) + (GDK_Break) + (GDK_Mode_switch) + (GDK_script_switch) + (GDK_Num_Lock) + (GDK_KP_Space) + (GDK_KP_Tab) + (GDK_KP_Enter) + (GDK_KP_F1) + (GDK_KP_F2) + (GDK_KP_F3) + (GDK_KP_F4) + (GDK_KP_Home) + (GDK_KP_Left) + (GDK_KP_Up) + (GDK_KP_Right) + (GDK_KP_Down) + (GDK_KP_Prior) + (GDK_KP_Page_Up) + (GDK_KP_Next) + (GDK_KP_Page_Down) + (GDK_KP_End) + (GDK_KP_Begin) + (GDK_KP_Insert) + (GDK_KP_Delete) + (GDK_KP_Equal) + (GDK_KP_Multiply) + (GDK_KP_Add) + (GDK_KP_Separator) + (GDK_KP_Subtract) + (GDK_KP_Decimal) + (GDK_KP_Divide) + (GDK_KP_0) + (GDK_KP_1) + (GDK_KP_2) + (GDK_KP_3) + (GDK_KP_4) + (GDK_KP_5) + (GDK_KP_6) + (GDK_KP_7) + (GDK_KP_8) + (GDK_KP_9) + (GDK_F1) + (GDK_F2) + (GDK_F3) + (GDK_F4) + (GDK_F5) + (GDK_F6) + (GDK_F7) + (GDK_F8) + (GDK_F9) + (GDK_F10) + (GDK_F11) + (GDK_L1) + (GDK_F12) + (GDK_L2) + (GDK_F13) + (GDK_L3) + (GDK_F14) + (GDK_L4) + (GDK_F15) + (GDK_L5) + (GDK_F16) + (GDK_L6) + (GDK_F17) + (GDK_L7) + (GDK_F18) + (GDK_L8) + (GDK_F19) + (GDK_L9) + (GDK_F20) + (GDK_L10) + (GDK_F21) + (GDK_R1) + (GDK_F22) + (GDK_R2) + (GDK_F23) + (GDK_R3) + (GDK_F24) + (GDK_R4) + (GDK_F25) + (GDK_R5) + (GDK_F26) + (GDK_R6) + (GDK_F27) + (GDK_R7) + (GDK_F28) + (GDK_R8) + (GDK_F29) + (GDK_R9) + (GDK_F30) + (GDK_R10) + (GDK_F31) + (GDK_R11) + (GDK_F32) + (GDK_R12) + (GDK_F33) + (GDK_R13) + (GDK_F34) + (GDK_R14) + (GDK_F35) + (GDK_R15) + (GDK_Shift_L) + (GDK_Shift_R) + (GDK_Control_L) + (GDK_Control_R) + (GDK_Caps_Lock) + (GDK_Shift_Lock) + (GDK_Meta_L) + (GDK_Meta_R) + (GDK_Alt_L) + (GDK_Alt_R) + (GDK_Super_L) + (GDK_Super_R) + (GDK_Hyper_L) + (GDK_Hyper_R) + (GDK_ISO_Lock) + (GDK_ISO_Level2_Latch) + (GDK_ISO_Level3_Shift) + (GDK_ISO_Level3_Latch) + (GDK_ISO_Level3_Lock) + (GDK_ISO_Group_Shift) + (GDK_ISO_Group_Latch) + (GDK_ISO_Group_Lock) + (GDK_ISO_Next_Group) + (GDK_ISO_Next_Group_Lock) + (GDK_ISO_Prev_Group) + (GDK_ISO_Prev_Group_Lock) + (GDK_ISO_First_Group) + (GDK_ISO_First_Group_Lock) + (GDK_ISO_Last_Group) + (GDK_ISO_Last_Group_Lock) + (GDK_ISO_Left_Tab) + (GDK_ISO_Move_Line_Up) + (GDK_ISO_Move_Line_Down) + (GDK_ISO_Partial_Line_Up) + (GDK_ISO_Partial_Line_Down) + (GDK_ISO_Partial_Space_Left) + (GDK_ISO_Partial_Space_Right) + (GDK_ISO_Set_Margin_Left) + (GDK_ISO_Set_Margin_Right) + (GDK_ISO_Release_Margin_Left) + (GDK_ISO_Release_Margin_Right) + (GDK_ISO_Release_Both_Margins) + (GDK_ISO_Fast_Cursor_Left) + (GDK_ISO_Fast_Cursor_Right) + (GDK_ISO_Fast_Cursor_Up) + (GDK_ISO_Fast_Cursor_Down) + (GDK_ISO_Continuous_Underline) + (GDK_ISO_Discontinuous_Underline) + (GDK_ISO_Emphasize) + (GDK_ISO_Center_Object) + (GDK_ISO_Enter) + (GDK_dead_grave) + (GDK_dead_acute) + (GDK_dead_circumflex) + (GDK_dead_tilde) + (GDK_dead_macron) + (GDK_dead_breve) + (GDK_dead_abovedot) + (GDK_dead_diaeresis) + (GDK_dead_abovering) + (GDK_dead_doubleacute) + (GDK_dead_caron) + (GDK_dead_cedilla) + (GDK_dead_ogonek) + (GDK_dead_iota) + (GDK_dead_voiced_sound) + (GDK_dead_semivoiced_sound) + (GDK_dead_belowdot) + (GDK_dead_hook) + (GDK_dead_horn) + (GDK_First_Virtual_Screen) + (GDK_Prev_Virtual_Screen) + (GDK_Next_Virtual_Screen) + (GDK_Last_Virtual_Screen) + (GDK_Terminate_Server) + (GDK_AccessX_Enable) + (GDK_AccessX_Feedback_Enable) + (GDK_RepeatKeys_Enable) + (GDK_SlowKeys_Enable) + (GDK_BounceKeys_Enable) + (GDK_StickyKeys_Enable) + (GDK_MouseKeys_Enable) + (GDK_MouseKeys_Accel_Enable) + (GDK_Overlay1_Enable) + (GDK_Overlay2_Enable) + (GDK_AudibleBell_Enable) + (GDK_Pointer_Left) + (GDK_Pointer_Right) + (GDK_Pointer_Up) + (GDK_Pointer_Down) + (GDK_Pointer_UpLeft) + (GDK_Pointer_UpRight) + (GDK_Pointer_DownLeft) + (GDK_Pointer_DownRight) + (GDK_Pointer_Button_Dflt) + (GDK_Pointer_Button1) + (GDK_Pointer_Button2) + (GDK_Pointer_Button3) + (GDK_Pointer_Button4) + (GDK_Pointer_Button5) + (GDK_Pointer_DblClick_Dflt) + (GDK_Pointer_DblClick1) + (GDK_Pointer_DblClick2) + (GDK_Pointer_DblClick3) + (GDK_Pointer_DblClick4) + (GDK_Pointer_DblClick5) + (GDK_Pointer_Drag_Dflt) + (GDK_Pointer_Drag1) + (GDK_Pointer_Drag2) + (GDK_Pointer_Drag3) + (GDK_Pointer_Drag4) + (GDK_Pointer_Drag5) + (GDK_Pointer_EnableKeys) + (GDK_Pointer_Accelerate) + (GDK_Pointer_DfltBtnNext) + (GDK_Pointer_DfltBtnPrev) + (GDK_3270_Duplicate) + (GDK_3270_FieldMark) + (GDK_3270_Right2) + (GDK_3270_Left2) + (GDK_3270_BackTab) + (GDK_3270_EraseEOF) + (GDK_3270_EraseInput) + (GDK_3270_Reset) + (GDK_3270_Quit) + (GDK_3270_PA1) + (GDK_3270_PA2) + (GDK_3270_PA3) + (GDK_3270_Test) + (GDK_3270_Attn) + (GDK_3270_CursorBlink) + (GDK_3270_AltCursor) + (GDK_3270_KeyClick) + (GDK_3270_Jump) + (GDK_3270_Ident) + (GDK_3270_Rule) + (GDK_3270_Copy) + (GDK_3270_Play) + (GDK_3270_Setup) + (GDK_3270_Record) + (GDK_3270_ChangeScreen) + (GDK_3270_DeleteWord) + (GDK_3270_ExSelect) + (GDK_3270_CursorSelect) + (GDK_3270_PrintScreen) + (GDK_3270_Enter) + (GDK_space) + (GDK_exclam) + (GDK_quotedbl) + (GDK_numbersign) + (GDK_dollar) + (GDK_percent) + (GDK_ampersand) + (GDK_apostrophe) + (GDK_quoteright) + (GDK_parenleft) + (GDK_parenright) + (GDK_asterisk) + (GDK_plus) + (GDK_comma) + (GDK_minus) + (GDK_period) + (GDK_slash) + (GDK_0) + (GDK_1) + (GDK_2) + (GDK_3) + (GDK_4) + (GDK_5) + (GDK_6) + (GDK_7) + (GDK_8) + (GDK_9) + (GDK_colon) + (GDK_semicolon) + (GDK_less) + (GDK_equal) + (GDK_greater) + (GDK_question) + (GDK_at) + (GDK_A) + (GDK_B) + (GDK_C) + (GDK_D) + (GDK_E) + (GDK_F) + (GDK_G) + (GDK_H) + (GDK_I) + (GDK_J) + (GDK_K) + (GDK_L) + (GDK_M) + (GDK_N) + (GDK_O) + (GDK_P) + (GDK_Q) + (GDK_R) + (GDK_S) + (GDK_T) + (GDK_U) + (GDK_V) + (GDK_W) + (GDK_X) + (GDK_Y) + (GDK_Z) + (GDK_bracketleft) + (GDK_backslash) + (GDK_bracketright) + (GDK_asciicircum) + (GDK_underscore) + (GDK_grave) + (GDK_quoteleft) + (GDK_a) + (GDK_b) + (GDK_c) + (GDK_d) + (GDK_e) + (GDK_f) + (GDK_g) + (GDK_h) + (GDK_i) + (GDK_j) + (GDK_k) + (GDK_l) + (GDK_m) + (GDK_n) + (GDK_o) + (GDK_p) + (GDK_q) + (GDK_r) + (GDK_s) + (GDK_t) + (GDK_u) + (GDK_v) + (GDK_w) + (GDK_x) + (GDK_y) + (GDK_z) + (GDK_braceleft) + (GDK_bar) + (GDK_braceright) + (GDK_asciitilde) + (GDK_nobreakspace) + (GDK_exclamdown) + (GDK_cent) + (GDK_sterling) + (GDK_currency) + (GDK_yen) + (GDK_brokenbar) + (GDK_section) + (GDK_diaeresis) + (GDK_copyright) + (GDK_ordfeminine) + (GDK_guillemotleft) + (GDK_notsign) + (GDK_hyphen) + (GDK_registered) + (GDK_macron) + (GDK_degree) + (GDK_plusminus) + (GDK_twosuperior) + (GDK_threesuperior) + (GDK_acute) + (GDK_mu) + (GDK_paragraph) + (GDK_periodcentered) + (GDK_cedilla) + (GDK_onesuperior) + (GDK_masculine) + (GDK_guillemotright) + (GDK_onequarter) + (GDK_onehalf) + (GDK_threequarters) + (GDK_questiondown) + (GDK_Agrave) + (GDK_Aacute) + (GDK_Acircumflex) + (GDK_Atilde) + (GDK_Adiaeresis) + (GDK_Aring) + (GDK_AE) + (GDK_Ccedilla) + (GDK_Egrave) + (GDK_Eacute) + (GDK_Ecircumflex) + (GDK_Ediaeresis) + (GDK_Igrave) + (GDK_Iacute) + (GDK_Icircumflex) + (GDK_Idiaeresis) + (GDK_ETH) + (GDK_Eth) + (GDK_Ntilde) + (GDK_Ograve) + (GDK_Oacute) + (GDK_Ocircumflex) + (GDK_Otilde) + (GDK_Odiaeresis) + (GDK_multiply) + (GDK_Oslash) + (GDK_Ooblique) + (GDK_Ugrave) + (GDK_Uacute) + (GDK_Ucircumflex) + (GDK_Udiaeresis) + (GDK_Yacute) + (GDK_THORN) + (GDK_Thorn) + (GDK_ssharp) + (GDK_agrave) + (GDK_aacute) + (GDK_acircumflex) + (GDK_atilde) + (GDK_adiaeresis) + (GDK_aring) + (GDK_ae) + (GDK_ccedilla) + (GDK_egrave) + (GDK_eacute) + (GDK_ecircumflex) + (GDK_ediaeresis) + (GDK_igrave) + (GDK_iacute) + (GDK_icircumflex) + (GDK_idiaeresis) + (GDK_eth) + (GDK_ntilde) + (GDK_ograve) + (GDK_oacute) + (GDK_ocircumflex) + (GDK_otilde) + (GDK_odiaeresis) + (GDK_division) + (GDK_oslash) + (GDK_ooblique) + (GDK_ugrave) + (GDK_uacute) + (GDK_ucircumflex) + (GDK_udiaeresis) + (GDK_yacute) + (GDK_thorn) + (GDK_ydiaeresis) + (GDK_Aogonek) + (GDK_breve) + (GDK_Lstroke) + (GDK_Lcaron) + (GDK_Sacute) + (GDK_Scaron) + (GDK_Scedilla) + (GDK_Tcaron) + (GDK_Zacute) + (GDK_Zcaron) + (GDK_Zabovedot) + (GDK_aogonek) + (GDK_ogonek) + (GDK_lstroke) + (GDK_lcaron) + (GDK_sacute) + (GDK_caron) + (GDK_scaron) + (GDK_scedilla) + (GDK_tcaron) + (GDK_zacute) + (GDK_doubleacute) + (GDK_zcaron) + (GDK_zabovedot) + (GDK_Racute) + (GDK_Abreve) + (GDK_Lacute) + (GDK_Cacute) + (GDK_Ccaron) + (GDK_Eogonek) + (GDK_Ecaron) + (GDK_Dcaron) + (GDK_Dstroke) + (GDK_Nacute) + (GDK_Ncaron) + (GDK_Odoubleacute) + (GDK_Rcaron) + (GDK_Uring) + (GDK_Udoubleacute) + (GDK_Tcedilla) + (GDK_racute) + (GDK_abreve) + (GDK_lacute) + (GDK_cacute) + (GDK_ccaron) + (GDK_eogonek) + (GDK_ecaron) + (GDK_dcaron) + (GDK_dstroke) + (GDK_nacute) + (GDK_ncaron) + (GDK_odoubleacute) + (GDK_udoubleacute) + (GDK_rcaron) + (GDK_uring) + (GDK_tcedilla) + (GDK_abovedot) + (GDK_Hstroke) + (GDK_Hcircumflex) + (GDK_Iabovedot) + (GDK_Gbreve) + (GDK_Jcircumflex) + (GDK_hstroke) + (GDK_hcircumflex) + (GDK_idotless) + (GDK_gbreve) + (GDK_jcircumflex) + (GDK_Cabovedot) + (GDK_Ccircumflex) + (GDK_Gabovedot) + (GDK_Gcircumflex) + (GDK_Ubreve) + (GDK_Scircumflex) + (GDK_cabovedot) + (GDK_ccircumflex) + (GDK_gabovedot) + (GDK_gcircumflex) + (GDK_ubreve) + (GDK_scircumflex) + (GDK_kra) + (GDK_kappa) + (GDK_Rcedilla) + (GDK_Itilde) + (GDK_Lcedilla) + (GDK_Emacron) + (GDK_Gcedilla) + (GDK_Tslash) + (GDK_rcedilla) + (GDK_itilde) + (GDK_lcedilla) + (GDK_emacron) + (GDK_gcedilla) + (GDK_tslash) + (GDK_ENG) + (GDK_eng) + (GDK_Amacron) + (GDK_Iogonek) + (GDK_Eabovedot) + (GDK_Imacron) + (GDK_Ncedilla) + (GDK_Omacron) + (GDK_Kcedilla) + (GDK_Uogonek) + (GDK_Utilde) + (GDK_Umacron) + (GDK_amacron) + (GDK_iogonek) + (GDK_eabovedot) + (GDK_imacron) + (GDK_ncedilla) + (GDK_omacron) + (GDK_kcedilla) + (GDK_uogonek) + (GDK_utilde) + (GDK_umacron) + (GDK_Babovedot) + (GDK_babovedot) + (GDK_Dabovedot) + (GDK_Wgrave) + (GDK_Wacute) + (GDK_dabovedot) + (GDK_Ygrave) + (GDK_Fabovedot) + (GDK_fabovedot) + (GDK_Mabovedot) + (GDK_mabovedot) + (GDK_Pabovedot) + (GDK_wgrave) + (GDK_pabovedot) + (GDK_wacute) + (GDK_Sabovedot) + (GDK_ygrave) + (GDK_Wdiaeresis) + (GDK_wdiaeresis) + (GDK_sabovedot) + (GDK_Wcircumflex) + (GDK_Tabovedot) + (GDK_Ycircumflex) + (GDK_wcircumflex) + (GDK_tabovedot) + (GDK_ycircumflex) + (GDK_OE) + (GDK_oe) + (GDK_Ydiaeresis) + (GDK_overline) + (GDK_kana_fullstop) + (GDK_kana_openingbracket) + (GDK_kana_closingbracket) + (GDK_kana_comma) + (GDK_kana_conjunctive) + (GDK_kana_middledot) + (GDK_kana_WO) + (GDK_kana_a) + (GDK_kana_i) + (GDK_kana_u) + (GDK_kana_e) + (GDK_kana_o) + (GDK_kana_ya) + (GDK_kana_yu) + (GDK_kana_yo) + (GDK_kana_tsu) + (GDK_kana_tu) + (GDK_prolongedsound) + (GDK_kana_A) + (GDK_kana_I) + (GDK_kana_U) + (GDK_kana_E) + (GDK_kana_O) + (GDK_kana_KA) + (GDK_kana_KI) + (GDK_kana_KU) + (GDK_kana_KE) + (GDK_kana_KO) + (GDK_kana_SA) + (GDK_kana_SHI) + (GDK_kana_SU) + (GDK_kana_SE) + (GDK_kana_SO) + (GDK_kana_TA) + (GDK_kana_CHI) + (GDK_kana_TI) + (GDK_kana_TSU) + (GDK_kana_TU) + (GDK_kana_TE) + (GDK_kana_TO) + (GDK_kana_NA) + (GDK_kana_NI) + (GDK_kana_NU) + (GDK_kana_NE) + (GDK_kana_NO) + (GDK_kana_HA) + (GDK_kana_HI) + (GDK_kana_FU) + (GDK_kana_HU) + (GDK_kana_HE) + (GDK_kana_HO) + (GDK_kana_MA) + (GDK_kana_MI) + (GDK_kana_MU) + (GDK_kana_ME) + (GDK_kana_MO) + (GDK_kana_YA) + (GDK_kana_YU) + (GDK_kana_YO) + (GDK_kana_RA) + (GDK_kana_RI) + (GDK_kana_RU) + (GDK_kana_RE) + (GDK_kana_RO) + (GDK_kana_WA) + (GDK_kana_N) + (GDK_voicedsound) + (GDK_semivoicedsound) + (GDK_kana_switch) + (GDK_Farsi_0) + (GDK_Farsi_1) + (GDK_Farsi_2) + (GDK_Farsi_3) + (GDK_Farsi_4) + (GDK_Farsi_5) + (GDK_Farsi_6) + (GDK_Farsi_7) + (GDK_Farsi_8) + (GDK_Farsi_9) + (GDK_Arabic_percent) + (GDK_Arabic_superscript_alef) + (GDK_Arabic_tteh) + (GDK_Arabic_peh) + (GDK_Arabic_tcheh) + (GDK_Arabic_ddal) + (GDK_Arabic_rreh) + (GDK_Arabic_comma) + (GDK_Arabic_fullstop) + (GDK_Arabic_0) + (GDK_Arabic_1) + (GDK_Arabic_2) + (GDK_Arabic_3) + (GDK_Arabic_4) + (GDK_Arabic_5) + (GDK_Arabic_6) + (GDK_Arabic_7) + (GDK_Arabic_8) + (GDK_Arabic_9) + (GDK_Arabic_semicolon) + (GDK_Arabic_question_mark) + (GDK_Arabic_hamza) + (GDK_Arabic_maddaonalef) + (GDK_Arabic_hamzaonalef) + (GDK_Arabic_hamzaonwaw) + (GDK_Arabic_hamzaunderalef) + (GDK_Arabic_hamzaonyeh) + (GDK_Arabic_alef) + (GDK_Arabic_beh) + (GDK_Arabic_tehmarbuta) + (GDK_Arabic_teh) + (GDK_Arabic_theh) + (GDK_Arabic_jeem) + (GDK_Arabic_hah) + (GDK_Arabic_khah) + (GDK_Arabic_dal) + (GDK_Arabic_thal) + (GDK_Arabic_ra) + (GDK_Arabic_zain) + (GDK_Arabic_seen) + (GDK_Arabic_sheen) + (GDK_Arabic_sad) + (GDK_Arabic_dad) + (GDK_Arabic_tah) + (GDK_Arabic_zah) + (GDK_Arabic_ain) + (GDK_Arabic_ghain) + (GDK_Arabic_tatweel) + (GDK_Arabic_feh) + (GDK_Arabic_qaf) + (GDK_Arabic_kaf) + (GDK_Arabic_lam) + (GDK_Arabic_meem) + (GDK_Arabic_noon) + (GDK_Arabic_ha) + (GDK_Arabic_heh) + (GDK_Arabic_waw) + (GDK_Arabic_alefmaksura) + (GDK_Arabic_yeh) + (GDK_Arabic_fathatan) + (GDK_Arabic_dammatan) + (GDK_Arabic_kasratan) + (GDK_Arabic_fatha) + (GDK_Arabic_damma) + (GDK_Arabic_kasra) + (GDK_Arabic_shadda) + (GDK_Arabic_sukun) + (GDK_Arabic_madda_above) + (GDK_Arabic_hamza_above) + (GDK_Arabic_hamza_below) + (GDK_Arabic_jeh) + (GDK_Arabic_veh) + (GDK_Arabic_keheh) + (GDK_Arabic_gaf) + (GDK_Arabic_noon_ghunna) + (GDK_Arabic_heh_doachashmee) + (GDK_Farsi_yeh) + (GDK_Arabic_farsi_yeh) + (GDK_Arabic_yeh_baree) + (GDK_Arabic_heh_goal) + (GDK_Arabic_switch) + (GDK_Cyrillic_GHE_bar) + (GDK_Cyrillic_ghe_bar) + (GDK_Cyrillic_ZHE_descender) + (GDK_Cyrillic_zhe_descender) + (GDK_Cyrillic_KA_descender) + (GDK_Cyrillic_ka_descender) + (GDK_Cyrillic_KA_vertstroke) + (GDK_Cyrillic_ka_vertstroke) + (GDK_Cyrillic_EN_descender) + (GDK_Cyrillic_en_descender) + (GDK_Cyrillic_U_straight) + (GDK_Cyrillic_u_straight) + (GDK_Cyrillic_U_straight_bar) + (GDK_Cyrillic_u_straight_bar) + (GDK_Cyrillic_HA_descender) + (GDK_Cyrillic_ha_descender) + (GDK_Cyrillic_CHE_descender) + (GDK_Cyrillic_che_descender) + (GDK_Cyrillic_CHE_vertstroke) + (GDK_Cyrillic_che_vertstroke) + (GDK_Cyrillic_SHHA) + (GDK_Cyrillic_shha) + (GDK_Cyrillic_SCHWA) + (GDK_Cyrillic_schwa) + (GDK_Cyrillic_I_macron) + (GDK_Cyrillic_i_macron) + (GDK_Cyrillic_O_bar) + (GDK_Cyrillic_o_bar) + (GDK_Cyrillic_U_macron) + (GDK_Cyrillic_u_macron) + (GDK_Serbian_dje) + (GDK_Macedonia_gje) + (GDK_Cyrillic_io) + (GDK_Ukrainian_ie) + (GDK_Ukranian_je) + (GDK_Macedonia_dse) + (GDK_Ukrainian_i) + (GDK_Ukranian_i) + (GDK_Ukrainian_yi) + (GDK_Ukranian_yi) + (GDK_Cyrillic_je) + (GDK_Serbian_je) + (GDK_Cyrillic_lje) + (GDK_Serbian_lje) + (GDK_Cyrillic_nje) + (GDK_Serbian_nje) + (GDK_Serbian_tshe) + (GDK_Macedonia_kje) + (GDK_Ukrainian_ghe_with_upturn) + (GDK_Byelorussian_shortu) + (GDK_Cyrillic_dzhe) + (GDK_Serbian_dze) + (GDK_numerosign) + (GDK_Serbian_DJE) + (GDK_Macedonia_GJE) + (GDK_Cyrillic_IO) + (GDK_Ukrainian_IE) + (GDK_Ukranian_JE) + (GDK_Macedonia_DSE) + (GDK_Ukrainian_I) + (GDK_Ukranian_I) + (GDK_Ukrainian_YI) + (GDK_Ukranian_YI) + (GDK_Cyrillic_JE) + (GDK_Serbian_JE) + (GDK_Cyrillic_LJE) + (GDK_Serbian_LJE) + (GDK_Cyrillic_NJE) + (GDK_Serbian_NJE) + (GDK_Serbian_TSHE) + (GDK_Macedonia_KJE) + (GDK_Ukrainian_GHE_WITH_UPTURN) + (GDK_Byelorussian_SHORTU) + (GDK_Cyrillic_DZHE) + (GDK_Serbian_DZE) + (GDK_Cyrillic_yu) + (GDK_Cyrillic_a) + (GDK_Cyrillic_be) + (GDK_Cyrillic_tse) + (GDK_Cyrillic_de) + (GDK_Cyrillic_ie) + (GDK_Cyrillic_ef) + (GDK_Cyrillic_ghe) + (GDK_Cyrillic_ha) + (GDK_Cyrillic_i) + (GDK_Cyrillic_shorti) + (GDK_Cyrillic_ka) + (GDK_Cyrillic_el) + (GDK_Cyrillic_em) + (GDK_Cyrillic_en) + (GDK_Cyrillic_o) + (GDK_Cyrillic_pe) + (GDK_Cyrillic_ya) + (GDK_Cyrillic_er) + (GDK_Cyrillic_es) + (GDK_Cyrillic_te) + (GDK_Cyrillic_u) + (GDK_Cyrillic_zhe) + (GDK_Cyrillic_ve) + (GDK_Cyrillic_softsign) + (GDK_Cyrillic_yeru) + (GDK_Cyrillic_ze) + (GDK_Cyrillic_sha) + (GDK_Cyrillic_e) + (GDK_Cyrillic_shcha) + (GDK_Cyrillic_che) + (GDK_Cyrillic_hardsign) + (GDK_Cyrillic_YU) + (GDK_Cyrillic_A) + (GDK_Cyrillic_BE) + (GDK_Cyrillic_TSE) + (GDK_Cyrillic_DE) + (GDK_Cyrillic_IE) + (GDK_Cyrillic_EF) + (GDK_Cyrillic_GHE) + (GDK_Cyrillic_HA) + (GDK_Cyrillic_I) + (GDK_Cyrillic_SHORTI) + (GDK_Cyrillic_KA) + (GDK_Cyrillic_EL) + (GDK_Cyrillic_EM) + (GDK_Cyrillic_EN) + (GDK_Cyrillic_O) + (GDK_Cyrillic_PE) + (GDK_Cyrillic_YA) + (GDK_Cyrillic_ER) + (GDK_Cyrillic_ES) + (GDK_Cyrillic_TE) + (GDK_Cyrillic_U) + (GDK_Cyrillic_ZHE) + (GDK_Cyrillic_VE) + (GDK_Cyrillic_SOFTSIGN) + (GDK_Cyrillic_YERU) + (GDK_Cyrillic_ZE) + (GDK_Cyrillic_SHA) + (GDK_Cyrillic_E) + (GDK_Cyrillic_SHCHA) + (GDK_Cyrillic_CHE) + (GDK_Cyrillic_HARDSIGN) + (GDK_Greek_ALPHAaccent) + (GDK_Greek_EPSILONaccent) + (GDK_Greek_ETAaccent) + (GDK_Greek_IOTAaccent) + (GDK_Greek_IOTAdieresis) + (GDK_Greek_IOTAdiaeresis) + (GDK_Greek_OMICRONaccent) + (GDK_Greek_UPSILONaccent) + (GDK_Greek_UPSILONdieresis) + (GDK_Greek_OMEGAaccent) + (GDK_Greek_accentdieresis) + (GDK_Greek_horizbar) + (GDK_Greek_alphaaccent) + (GDK_Greek_epsilonaccent) + (GDK_Greek_etaaccent) + (GDK_Greek_iotaaccent) + (GDK_Greek_iotadieresis) + (GDK_Greek_iotaaccentdieresis) + (GDK_Greek_omicronaccent) + (GDK_Greek_upsilonaccent) + (GDK_Greek_upsilondieresis) + (GDK_Greek_upsilonaccentdieresis) + (GDK_Greek_omegaaccent) + (GDK_Greek_ALPHA) + (GDK_Greek_BETA) + (GDK_Greek_GAMMA) + (GDK_Greek_DELTA) + (GDK_Greek_EPSILON) + (GDK_Greek_ZETA) + (GDK_Greek_ETA) + (GDK_Greek_THETA) + (GDK_Greek_IOTA) + (GDK_Greek_KAPPA) + (GDK_Greek_LAMDA) + (GDK_Greek_LAMBDA) + (GDK_Greek_MU) + (GDK_Greek_NU) + (GDK_Greek_XI) + (GDK_Greek_OMICRON) + (GDK_Greek_PI) + (GDK_Greek_RHO) + (GDK_Greek_SIGMA) + (GDK_Greek_TAU) + (GDK_Greek_UPSILON) + (GDK_Greek_PHI) + (GDK_Greek_CHI) + (GDK_Greek_PSI) + (GDK_Greek_OMEGA) + (GDK_Greek_alpha) + (GDK_Greek_beta) + (GDK_Greek_gamma) + (GDK_Greek_delta) + (GDK_Greek_epsilon) + (GDK_Greek_zeta) + (GDK_Greek_eta) + (GDK_Greek_theta) + (GDK_Greek_iota) + (GDK_Greek_kappa) + (GDK_Greek_lamda) + (GDK_Greek_lambda) + (GDK_Greek_mu) + (GDK_Greek_nu) + (GDK_Greek_xi) + (GDK_Greek_omicron) + (GDK_Greek_pi) + (GDK_Greek_rho) + (GDK_Greek_sigma) + (GDK_Greek_finalsmallsigma) + (GDK_Greek_tau) + (GDK_Greek_upsilon) + (GDK_Greek_phi) + (GDK_Greek_chi) + (GDK_Greek_psi) + (GDK_Greek_omega) + (GDK_Greek_switch) + (GDK_leftradical) + (GDK_topleftradical) + (GDK_horizconnector) + (GDK_topintegral) + (GDK_botintegral) + (GDK_vertconnector) + (GDK_topleftsqbracket) + (GDK_botleftsqbracket) + (GDK_toprightsqbracket) + (GDK_botrightsqbracket) + (GDK_topleftparens) + (GDK_botleftparens) + (GDK_toprightparens) + (GDK_botrightparens) + (GDK_leftmiddlecurlybrace) + (GDK_rightmiddlecurlybrace) + (GDK_topleftsummation) + (GDK_botleftsummation) + (GDK_topvertsummationconnector) + (GDK_botvertsummationconnector) + (GDK_toprightsummation) + (GDK_botrightsummation) + (GDK_rightmiddlesummation) + (GDK_lessthanequal) + (GDK_notequal) + (GDK_greaterthanequal) + (GDK_integral) + (GDK_therefore) + (GDK_variation) + (GDK_infinity) + (GDK_nabla) + (GDK_approximate) + (GDK_similarequal) + (GDK_ifonlyif) + (GDK_implies) + (GDK_identical) + (GDK_radical) + (GDK_includedin) + (GDK_includes) + (GDK_intersection) + (GDK_union) + (GDK_logicaland) + (GDK_logicalor) + (GDK_partialderivative) + (GDK_function) + (GDK_leftarrow) + (GDK_uparrow) + (GDK_rightarrow) + (GDK_downarrow) + (GDK_blank) + (GDK_soliddiamond) + (GDK_checkerboard) + (GDK_ht) + (GDK_ff) + (GDK_cr) + (GDK_lf) + (GDK_nl) + (GDK_vt) + (GDK_lowrightcorner) + (GDK_uprightcorner) + (GDK_upleftcorner) + (GDK_lowleftcorner) + (GDK_crossinglines) + (GDK_horizlinescan1) + (GDK_horizlinescan3) + (GDK_horizlinescan5) + (GDK_horizlinescan7) + (GDK_horizlinescan9) + (GDK_leftt) + (GDK_rightt) + (GDK_bott) + (GDK_topt) + (GDK_vertbar) + (GDK_emspace) + (GDK_enspace) + (GDK_em3space) + (GDK_em4space) + (GDK_digitspace) + (GDK_punctspace) + (GDK_thinspace) + (GDK_hairspace) + (GDK_emdash) + (GDK_endash) + (GDK_signifblank) + (GDK_ellipsis) + (GDK_doubbaselinedot) + (GDK_onethird) + (GDK_twothirds) + (GDK_onefifth) + (GDK_twofifths) + (GDK_threefifths) + (GDK_fourfifths) + (GDK_onesixth) + (GDK_fivesixths) + (GDK_careof) + (GDK_figdash) + (GDK_leftanglebracket) + (GDK_decimalpoint) + (GDK_rightanglebracket) + (GDK_marker) + (GDK_oneeighth) + (GDK_threeeighths) + (GDK_fiveeighths) + (GDK_seveneighths) + (GDK_trademark) + (GDK_signaturemark) + (GDK_trademarkincircle) + (GDK_leftopentriangle) + (GDK_rightopentriangle) + (GDK_emopencircle) + (GDK_emopenrectangle) + (GDK_leftsinglequotemark) + (GDK_rightsinglequotemark) + (GDK_leftdoublequotemark) + (GDK_rightdoublequotemark) + (GDK_prescription) + (GDK_minutes) + (GDK_seconds) + (GDK_latincross) + (GDK_hexagram) + (GDK_filledrectbullet) + (GDK_filledlefttribullet) + (GDK_filledrighttribullet) + (GDK_emfilledcircle) + (GDK_emfilledrect) + (GDK_enopencircbullet) + (GDK_enopensquarebullet) + (GDK_openrectbullet) + (GDK_opentribulletup) + (GDK_opentribulletdown) + (GDK_openstar) + (GDK_enfilledcircbullet) + (GDK_enfilledsqbullet) + (GDK_filledtribulletup) + (GDK_filledtribulletdown) + (GDK_leftpointer) + (GDK_rightpointer) + (GDK_club) + (GDK_diamond) + (GDK_heart) + (GDK_maltesecross) + (GDK_dagger) + (GDK_doubledagger) + (GDK_checkmark) + (GDK_ballotcross) + (GDK_musicalsharp) + (GDK_musicalflat) + (GDK_malesymbol) + (GDK_femalesymbol) + (GDK_telephone) + (GDK_telephonerecorder) + (GDK_phonographcopyright) + (GDK_caret) + (GDK_singlelowquotemark) + (GDK_doublelowquotemark) + (GDK_cursor) + (GDK_leftcaret) + (GDK_rightcaret) + (GDK_downcaret) + (GDK_upcaret) + (GDK_overbar) + (GDK_downtack) + (GDK_upshoe) + (GDK_downstile) + (GDK_underbar) + (GDK_jot) + (GDK_quad) + (GDK_uptack) + (GDK_circle) + (GDK_upstile) + (GDK_downshoe) + (GDK_rightshoe) + (GDK_leftshoe) + (GDK_lefttack) + (GDK_righttack) + (GDK_hebrew_doublelowline) + (GDK_hebrew_aleph) + (GDK_hebrew_bet) + (GDK_hebrew_beth) + (GDK_hebrew_gimel) + (GDK_hebrew_gimmel) + (GDK_hebrew_dalet) + (GDK_hebrew_daleth) + (GDK_hebrew_he) + (GDK_hebrew_waw) + (GDK_hebrew_zain) + (GDK_hebrew_zayin) + (GDK_hebrew_chet) + (GDK_hebrew_het) + (GDK_hebrew_tet) + (GDK_hebrew_teth) + (GDK_hebrew_yod) + (GDK_hebrew_finalkaph) + (GDK_hebrew_kaph) + (GDK_hebrew_lamed) + (GDK_hebrew_finalmem) + (GDK_hebrew_mem) + (GDK_hebrew_finalnun) + (GDK_hebrew_nun) + (GDK_hebrew_samech) + (GDK_hebrew_samekh) + (GDK_hebrew_ayin) + (GDK_hebrew_finalpe) + (GDK_hebrew_pe) + (GDK_hebrew_finalzade) + (GDK_hebrew_finalzadi) + (GDK_hebrew_zade) + (GDK_hebrew_zadi) + (GDK_hebrew_qoph) + (GDK_hebrew_kuf) + (GDK_hebrew_resh) + (GDK_hebrew_shin) + (GDK_hebrew_taw) + (GDK_hebrew_taf) + (GDK_Hebrew_switch) + (GDK_Thai_kokai) + (GDK_Thai_khokhai) + (GDK_Thai_khokhuat) + (GDK_Thai_khokhwai) + (GDK_Thai_khokhon) + (GDK_Thai_khorakhang) + (GDK_Thai_ngongu) + (GDK_Thai_chochan) + (GDK_Thai_choching) + (GDK_Thai_chochang) + (GDK_Thai_soso) + (GDK_Thai_chochoe) + (GDK_Thai_yoying) + (GDK_Thai_dochada) + (GDK_Thai_topatak) + (GDK_Thai_thothan) + (GDK_Thai_thonangmontho) + (GDK_Thai_thophuthao) + (GDK_Thai_nonen) + (GDK_Thai_dodek) + (GDK_Thai_totao) + (GDK_Thai_thothung) + (GDK_Thai_thothahan) + (GDK_Thai_thothong) + (GDK_Thai_nonu) + (GDK_Thai_bobaimai) + (GDK_Thai_popla) + (GDK_Thai_phophung) + (GDK_Thai_fofa) + (GDK_Thai_phophan) + (GDK_Thai_fofan) + (GDK_Thai_phosamphao) + (GDK_Thai_moma) + (GDK_Thai_yoyak) + (GDK_Thai_rorua) + (GDK_Thai_ru) + (GDK_Thai_loling) + (GDK_Thai_lu) + (GDK_Thai_wowaen) + (GDK_Thai_sosala) + (GDK_Thai_sorusi) + (GDK_Thai_sosua) + (GDK_Thai_hohip) + (GDK_Thai_lochula) + (GDK_Thai_oang) + (GDK_Thai_honokhuk) + (GDK_Thai_paiyannoi) + (GDK_Thai_saraa) + (GDK_Thai_maihanakat) + (GDK_Thai_saraaa) + (GDK_Thai_saraam) + (GDK_Thai_sarai) + (GDK_Thai_saraii) + (GDK_Thai_saraue) + (GDK_Thai_sarauee) + (GDK_Thai_sarau) + (GDK_Thai_sarauu) + (GDK_Thai_phinthu) + (GDK_Thai_maihanakat_maitho) + (GDK_Thai_baht) + (GDK_Thai_sarae) + (GDK_Thai_saraae) + (GDK_Thai_sarao) + (GDK_Thai_saraaimaimuan) + (GDK_Thai_saraaimaimalai) + (GDK_Thai_lakkhangyao) + (GDK_Thai_maiyamok) + (GDK_Thai_maitaikhu) + (GDK_Thai_maiek) + (GDK_Thai_maitho) + (GDK_Thai_maitri) + (GDK_Thai_maichattawa) + (GDK_Thai_thanthakhat) + (GDK_Thai_nikhahit) + (GDK_Thai_leksun) + (GDK_Thai_leknung) + (GDK_Thai_leksong) + (GDK_Thai_leksam) + (GDK_Thai_leksi) + (GDK_Thai_lekha) + (GDK_Thai_lekhok) + (GDK_Thai_lekchet) + (GDK_Thai_lekpaet) + (GDK_Thai_lekkao) + (GDK_Hangul) + (GDK_Hangul_Start) + (GDK_Hangul_End) + (GDK_Hangul_Hanja) + (GDK_Hangul_Jamo) + (GDK_Hangul_Romaja) + (GDK_Hangul_Codeinput) + (GDK_Hangul_Jeonja) + (GDK_Hangul_Banja) + (GDK_Hangul_PreHanja) + (GDK_Hangul_PostHanja) + (GDK_Hangul_SingleCandidate) + (GDK_Hangul_MultipleCandidate) + (GDK_Hangul_PreviousCandidate) + (GDK_Hangul_Special) + (GDK_Hangul_switch) + (GDK_Hangul_Kiyeog) + (GDK_Hangul_SsangKiyeog) + (GDK_Hangul_KiyeogSios) + (GDK_Hangul_Nieun) + (GDK_Hangul_NieunJieuj) + (GDK_Hangul_NieunHieuh) + (GDK_Hangul_Dikeud) + (GDK_Hangul_SsangDikeud) + (GDK_Hangul_Rieul) + (GDK_Hangul_RieulKiyeog) + (GDK_Hangul_RieulMieum) + (GDK_Hangul_RieulPieub) + (GDK_Hangul_RieulSios) + (GDK_Hangul_RieulTieut) + (GDK_Hangul_RieulPhieuf) + (GDK_Hangul_RieulHieuh) + (GDK_Hangul_Mieum) + (GDK_Hangul_Pieub) + (GDK_Hangul_SsangPieub) + (GDK_Hangul_PieubSios) + (GDK_Hangul_Sios) + (GDK_Hangul_SsangSios) + (GDK_Hangul_Ieung) + (GDK_Hangul_Jieuj) + (GDK_Hangul_SsangJieuj) + (GDK_Hangul_Cieuc) + (GDK_Hangul_Khieuq) + (GDK_Hangul_Tieut) + (GDK_Hangul_Phieuf) + (GDK_Hangul_Hieuh) + (GDK_Hangul_A) + (GDK_Hangul_AE) + (GDK_Hangul_YA) + (GDK_Hangul_YAE) + (GDK_Hangul_EO) + (GDK_Hangul_E) + (GDK_Hangul_YEO) + (GDK_Hangul_YE) + (GDK_Hangul_O) + (GDK_Hangul_WA) + (GDK_Hangul_WAE) + (GDK_Hangul_OE) + (GDK_Hangul_YO) + (GDK_Hangul_U) + (GDK_Hangul_WEO) + (GDK_Hangul_WE) + (GDK_Hangul_WI) + (GDK_Hangul_YU) + (GDK_Hangul_EU) + (GDK_Hangul_YI) + (GDK_Hangul_I) + (GDK_Hangul_J_Kiyeog) + (GDK_Hangul_J_SsangKiyeog) + (GDK_Hangul_J_KiyeogSios) + (GDK_Hangul_J_Nieun) + (GDK_Hangul_J_NieunJieuj) + (GDK_Hangul_J_NieunHieuh) + (GDK_Hangul_J_Dikeud) + (GDK_Hangul_J_Rieul) + (GDK_Hangul_J_RieulKiyeog) + (GDK_Hangul_J_RieulMieum) + (GDK_Hangul_J_RieulPieub) + (GDK_Hangul_J_RieulSios) + (GDK_Hangul_J_RieulTieut) + (GDK_Hangul_J_RieulPhieuf) + (GDK_Hangul_J_RieulHieuh) + (GDK_Hangul_J_Mieum) + (GDK_Hangul_J_Pieub) + (GDK_Hangul_J_PieubSios) + (GDK_Hangul_J_Sios) + (GDK_Hangul_J_SsangSios) + (GDK_Hangul_J_Ieung) + (GDK_Hangul_J_Jieuj) + (GDK_Hangul_J_Cieuc) + (GDK_Hangul_J_Khieuq) + (GDK_Hangul_J_Tieut) + (GDK_Hangul_J_Phieuf) + (GDK_Hangul_J_Hieuh) + (GDK_Hangul_RieulYeorinHieuh) + (GDK_Hangul_SunkyeongeumMieum) + (GDK_Hangul_SunkyeongeumPieub) + (GDK_Hangul_PanSios) + (GDK_Hangul_KkogjiDalrinIeung) + (GDK_Hangul_SunkyeongeumPhieuf) + (GDK_Hangul_YeorinHieuh) + (GDK_Hangul_AraeA) + (GDK_Hangul_AraeAE) + (GDK_Hangul_J_PanSios) + (GDK_Hangul_J_KkogjiDalrinIeung) + (GDK_Hangul_J_YeorinHieuh) + (GDK_Korean_Won) + (GDK_Armenian_ligature_ew) + (GDK_Armenian_full_stop) + (GDK_Armenian_verjaket) + (GDK_Armenian_separation_mark) + (GDK_Armenian_but) + (GDK_Armenian_hyphen) + (GDK_Armenian_yentamna) + (GDK_Armenian_exclam) + (GDK_Armenian_amanak) + (GDK_Armenian_accent) + (GDK_Armenian_shesht) + (GDK_Armenian_question) + (GDK_Armenian_paruyk) + (GDK_Armenian_AYB) + (GDK_Armenian_ayb) + (GDK_Armenian_BEN) + (GDK_Armenian_ben) + (GDK_Armenian_GIM) + (GDK_Armenian_gim) + (GDK_Armenian_DA) + (GDK_Armenian_da) + (GDK_Armenian_YECH) + (GDK_Armenian_yech) + (GDK_Armenian_ZA) + (GDK_Armenian_za) + (GDK_Armenian_E) + (GDK_Armenian_e) + (GDK_Armenian_AT) + (GDK_Armenian_at) + (GDK_Armenian_TO) + (GDK_Armenian_to) + (GDK_Armenian_ZHE) + (GDK_Armenian_zhe) + (GDK_Armenian_INI) + (GDK_Armenian_ini) + (GDK_Armenian_LYUN) + (GDK_Armenian_lyun) + (GDK_Armenian_KHE) + (GDK_Armenian_khe) + (GDK_Armenian_TSA) + (GDK_Armenian_tsa) + (GDK_Armenian_KEN) + (GDK_Armenian_ken) + (GDK_Armenian_HO) + (GDK_Armenian_ho) + (GDK_Armenian_DZA) + (GDK_Armenian_dza) + (GDK_Armenian_GHAT) + (GDK_Armenian_ghat) + (GDK_Armenian_TCHE) + (GDK_Armenian_tche) + (GDK_Armenian_MEN) + (GDK_Armenian_men) + (GDK_Armenian_HI) + (GDK_Armenian_hi) + (GDK_Armenian_NU) + (GDK_Armenian_nu) + (GDK_Armenian_SHA) + (GDK_Armenian_sha) + (GDK_Armenian_VO) + (GDK_Armenian_vo) + (GDK_Armenian_CHA) + (GDK_Armenian_cha) + (GDK_Armenian_PE) + (GDK_Armenian_pe) + (GDK_Armenian_JE) + (GDK_Armenian_je) + (GDK_Armenian_RA) + (GDK_Armenian_ra) + (GDK_Armenian_SE) + (GDK_Armenian_se) + (GDK_Armenian_VEV) + (GDK_Armenian_vev) + (GDK_Armenian_TYUN) + (GDK_Armenian_tyun) + (GDK_Armenian_RE) + (GDK_Armenian_re) + (GDK_Armenian_TSO) + (GDK_Armenian_tso) + (GDK_Armenian_VYUN) + (GDK_Armenian_vyun) + (GDK_Armenian_PYUR) + (GDK_Armenian_pyur) + (GDK_Armenian_KE) + (GDK_Armenian_ke) + (GDK_Armenian_O) + (GDK_Armenian_o) + (GDK_Armenian_FE) + (GDK_Armenian_fe) + (GDK_Armenian_apostrophe) + (GDK_Georgian_an) + (GDK_Georgian_ban) + (GDK_Georgian_gan) + (GDK_Georgian_don) + (GDK_Georgian_en) + (GDK_Georgian_vin) + (GDK_Georgian_zen) + (GDK_Georgian_tan) + (GDK_Georgian_in) + (GDK_Georgian_kan) + (GDK_Georgian_las) + (GDK_Georgian_man) + (GDK_Georgian_nar) + (GDK_Georgian_on) + (GDK_Georgian_par) + (GDK_Georgian_zhar) + (GDK_Georgian_rae) + (GDK_Georgian_san) + (GDK_Georgian_tar) + (GDK_Georgian_un) + (GDK_Georgian_phar) + (GDK_Georgian_khar) + (GDK_Georgian_ghan) + (GDK_Georgian_qar) + (GDK_Georgian_shin) + (GDK_Georgian_chin) + (GDK_Georgian_can) + (GDK_Georgian_jil) + (GDK_Georgian_cil) + (GDK_Georgian_char) + (GDK_Georgian_xan) + (GDK_Georgian_jhan) + (GDK_Georgian_hae) + (GDK_Georgian_he) + (GDK_Georgian_hie) + (GDK_Georgian_we) + (GDK_Georgian_har) + (GDK_Georgian_hoe) + (GDK_Georgian_fi) + (GDK_Xabovedot) + (GDK_Ibreve) + (GDK_Zstroke) + (GDK_Gcaron) + (GDK_Ocaron) + (GDK_Obarred) + (GDK_xabovedot) + (GDK_ibreve) + (GDK_zstroke) + (GDK_gcaron) + (GDK_ocaron) + (GDK_obarred) + (GDK_SCHWA) + (GDK_schwa) + (GDK_Lbelowdot) + (GDK_lbelowdot) + (GDK_Abelowdot) + (GDK_abelowdot) + (GDK_Ahook) + (GDK_ahook) + (GDK_Acircumflexacute) + (GDK_acircumflexacute) + (GDK_Acircumflexgrave) + (GDK_acircumflexgrave) + (GDK_Acircumflexhook) + (GDK_acircumflexhook) + (GDK_Acircumflextilde) + (GDK_acircumflextilde) + (GDK_Acircumflexbelowdot) + (GDK_acircumflexbelowdot) + (GDK_Abreveacute) + (GDK_abreveacute) + (GDK_Abrevegrave) + (GDK_abrevegrave) + (GDK_Abrevehook) + (GDK_abrevehook) + (GDK_Abrevetilde) + (GDK_abrevetilde) + (GDK_Abrevebelowdot) + (GDK_abrevebelowdot) + (GDK_Ebelowdot) + (GDK_ebelowdot) + (GDK_Ehook) + (GDK_ehook) + (GDK_Etilde) + (GDK_etilde) + (GDK_Ecircumflexacute) + (GDK_ecircumflexacute) + (GDK_Ecircumflexgrave) + (GDK_ecircumflexgrave) + (GDK_Ecircumflexhook) + (GDK_ecircumflexhook) + (GDK_Ecircumflextilde) + (GDK_ecircumflextilde) + (GDK_Ecircumflexbelowdot) + (GDK_ecircumflexbelowdot) + (GDK_Ihook) + (GDK_ihook) + (GDK_Ibelowdot) + (GDK_ibelowdot) + (GDK_Obelowdot) + (GDK_obelowdot) + (GDK_Ohook) + (GDK_ohook) + (GDK_Ocircumflexacute) + (GDK_ocircumflexacute) + (GDK_Ocircumflexgrave) + (GDK_ocircumflexgrave) + (GDK_Ocircumflexhook) + (GDK_ocircumflexhook) + (GDK_Ocircumflextilde) + (GDK_ocircumflextilde) + (GDK_Ocircumflexbelowdot) + (GDK_ocircumflexbelowdot) + (GDK_Ohornacute) + (GDK_ohornacute) + (GDK_Ohorngrave) + (GDK_ohorngrave) + (GDK_Ohornhook) + (GDK_ohornhook) + (GDK_Ohorntilde) + (GDK_ohorntilde) + (GDK_Ohornbelowdot) + (GDK_ohornbelowdot) + (GDK_Ubelowdot) + (GDK_ubelowdot) + (GDK_Uhook) + (GDK_uhook) + (GDK_Uhornacute) + (GDK_uhornacute) + (GDK_Uhorngrave) + (GDK_uhorngrave) + (GDK_Uhornhook) + (GDK_uhornhook) + (GDK_Uhorntilde) + (GDK_uhorntilde) + (GDK_Uhornbelowdot) + (GDK_uhornbelowdot) + (GDK_Ybelowdot) + (GDK_ybelowdot) + (GDK_Yhook) + (GDK_yhook) + (GDK_Ytilde) + (GDK_ytilde) + (GDK_Ohorn) + (GDK_ohorn) + (GDK_Uhorn) + (GDK_uhorn) + (GDK_EcuSign) + (GDK_ColonSign) + (GDK_CruzeiroSign) + (GDK_FFrancSign) + (GDK_LiraSign) + (GDK_MillSign) + (GDK_NairaSign) + (GDK_PesetaSign) + (GDK_RupeeSign) + (GDK_WonSign) + (GDK_NewSheqelSign) + (GDK_DongSign) + (GDK_EuroSign) + (GDK_zerosuperior) + (GDK_foursuperior) + (GDK_fivesuperior) + (GDK_sixsuperior) + (GDK_sevensuperior) + (GDK_eightsuperior) + (GDK_ninesuperior) + (GDK_zerosubscript) + (GDK_onesubscript) + (GDK_twosubscript) + (GDK_threesubscript) + (GDK_foursubscript) + (GDK_fivesubscript) + (GDK_sixsubscript) + (GDK_sevensubscript) + (GDK_eightsubscript) + (GDK_ninesubscript) + (GDK_partdifferential) + (GDK_emptyset) + (GDK_elementof) + (GDK_notelementof) + (GDK_containsas) + (GDK_squareroot) + (GDK_cuberoot) + (GDK_fourthroot) + (GDK_dintegral) + (GDK_tintegral) + (GDK_because) + (GDK_approxeq) + (GDK_notapproxeq) + (GDK_notidentical) + (GDK_stricteq)) \ No newline at end of file diff --git a/src/gtk/Includes/gdkrgb.cdecl b/src/gtk/Includes/gdkrgb.cdecl new file mode 100644 index 000000000..70cf9516c --- /dev/null +++ b/src/gtk/Includes/gdkrgb.cdecl @@ -0,0 +1,9 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkrgb.h |# + +(typedef GdkRgbDither + (enum + (GDK_RGB_DITHER_NONE) + (GDK_RGB_DITHER_NORMAL) + (GDK_RGB_DITHER_MAX))) \ No newline at end of file diff --git a/src/gtk/Includes/gdktypes.cdecl b/src/gtk/Includes/gdktypes.cdecl new file mode 100644 index 000000000..43bf3dbdc --- /dev/null +++ b/src/gtk/Includes/gdktypes.cdecl @@ -0,0 +1,100 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdktypes.h |# + +(include "glib") +(include "pango") +;(include "glib-object") + +;(include "gdkconfig") + +(enum (GDK_CURRENT_TIME)) +(enum (GDK_PARENT_RELATIVE)) + +(typedef GdkPoint (struct _GdkPoint)) +(typedef GdkRectangle (struct _GdkRectangle)) +(typedef GdkSegment (struct _GdkSegment)) +(typedef GdkSpan (struct _GdkSpan)) +(typedef GdkWChar guint32) + +(typedef GdkAtom (* (struct _GdkAtom))) + +(typedef GdkNativeWindow gpointer) + +(typedef GdkColor (struct _GdkColor)) +(typedef GdkColormap (struct _GdkColormap)) +(typedef GdkCursor (struct _GdkCursor)) +;(typedef GdkFont (struct _GdkFont)) +;(typedef GdkGC (struct _GdkGC)) +;(typedef GdkImage (struct _GdkImage)) +;(typedef GdkRegion (struct _GdkRegion)) +;(typedef GdkVisual (struct _GdkVisual)) + +(typedef GdkDrawable (struct _GdkDrawable)) +(typedef GdkBitmap (struct _GdkDrawable)) +(typedef GdkPixmap (struct _GdkDrawable)) +(typedef GdkWindow (struct _GdkDrawable)) +;(typedef GdkDisplay (struct _GdkDisplay)) +;(typedef GdkScreen (struct _GdkScreen)) + +(typedef GdkModifierType + (enum + (GDK_SHIFT_MASK) + (GDK_LOCK_MASK) + (GDK_CONTROL_MASK) + (GDK_MOD1_MASK) + (GDK_MOD2_MASK) + (GDK_MOD3_MASK) + (GDK_MOD4_MASK) + (GDK_MOD5_MASK) + (GDK_BUTTON1_MASK) + (GDK_BUTTON2_MASK) + (GDK_BUTTON3_MASK) + (GDK_BUTTON4_MASK) + (GDK_BUTTON5_MASK) + (GDK_RELEASE_MASK) + ;;GDK_MODIFIER_MASK = GDK_RELEASE_MASK | 0x1fff + )) + +(typedef GdkInputCondition + (enum + (GDK_INPUT_READ) + (GDK_INPUT_WRITE) + (GDK_INPUT_EXCEPTION))) + +(typedef GdkStatus + (enum + (GDK_OK) + (GDK_ERROR) + (GDK_ERROR_PARAM) + (GDK_ERROR_FILE) + (GDK_ERROR_MEM))) + +(typedef GdkGrabStatus + (enum + (GDK_GRAB_SUCCESS) + (GDK_GRAB_ALREADY_GRABBED) + (GDK_GRAB_INVALID_TIME) + (GDK_GRAB_NOT_VIEWABLE) + (GDK_GRAB_FROZEN))) + +(struct _GdkPoint + (x gint) + (y gint)) + +(struct _GdkRectangle + (x gint) + (y gint) + (width gint) + (height gint)) + +(struct _GdkSegment + (x1 gint) + (y1 gint) + (x2 gint) + (y2 gint)) + +(struct _GdkSpan + (x gint) + (y gint) + (width gint)) \ No newline at end of file diff --git a/src/gtk/Includes/gdkwindow.cdecl b/src/gtk/Includes/gdkwindow.cdecl new file mode 100644 index 000000000..2b3292160 --- /dev/null +++ b/src/gtk/Includes/gdkwindow.cdecl @@ -0,0 +1,222 @@ +#| -*-Scheme-*- + +gtk-2.0/gdk/gdkwindow.h |# + +;(include "gdkdrawable") +;(include "gdktypes") +;(include "gdkevents") + +(typedef GdkGeometry (struct _GdkGeometry)) +(typedef GdkWindowAttr (struct _GdkWindowAttr)) +(typedef GdkPointerHooks (struct _GdkPointerHooks)) + +(typedef GdkWindowClass + (enum + (GDK_INPUT_OUTPUT) (GDK_INPUT_ONLY))) + +(typedef GdkWindowType + (enum + (GDK_WINDOW_ROOT) + (GDK_WINDOW_TOPLEVEL) + (GDK_WINDOW_CHILD) + (GDK_WINDOW_DIALOG) + (GDK_WINDOW_TEMP) + (GDK_WINDOW_FOREIGN))) + +(typedef GdkWindowAttributesType + (enum + (GDK_WA_TITLE) + (GDK_WA_X) + (GDK_WA_Y) + (GDK_WA_CURSOR) + (GDK_WA_COLORMAP) + (GDK_WA_VISUAL) + (GDK_WA_WMCLASS) + (GDK_WA_NOREDIR))) + +(typedef GdkWindowHints + (enum + (GDK_HINT_POS) + (GDK_HINT_MIN_SIZE) + (GDK_HINT_MAX_SIZE) + (GDK_HINT_BASE_SIZE) + (GDK_HINT_ASPECT) + (GDK_HINT_RESIZE_INC) + (GDK_HINT_WIN_GRAVITY) + (GDK_HINT_USER_POS) + (GDK_HINT_USER_SIZE))) + +(typedef GdkWindowTypeHint + (enum + (GDK_WINDOW_TYPE_HINT_NORMAL) + (GDK_WINDOW_TYPE_HINT_DIALOG) + (GDK_WINDOW_TYPE_HINT_MENU) + (GDK_WINDOW_TYPE_HINT_TOOLBAR) + (GDK_WINDOW_TYPE_HINT_SPLASHSCREEN) + (GDK_WINDOW_TYPE_HINT_UTILITY) + (GDK_WINDOW_TYPE_HINT_DOCK) + (GDK_WINDOW_TYPE_HINT_DESKTOP))) + +(typedef GdkWMDecoration + (enum + (GDK_DECOR_ALL) + (GDK_DECOR_BORDER) + (GDK_DECOR_RESIZEH) + (GDK_DECOR_TITLE) + (GDK_DECOR_MENU) + (GDK_DECOR_MINIMIZE) + (GDK_DECOR_MAXIMIZE))) + +(typedef GdkWMFunction + (enum + (GDK_FUNC_ALL) + (GDK_FUNC_RESIZE) + (GDK_FUNC_MOVE) + (GDK_FUNC_MINIMIZE) + (GDK_FUNC_MAXIMIZE) + (GDK_FUNC_CLOSE))) + +(typedef GdkGravity + (enum + (GDK_GRAVITY_NORTH_WEST) + (GDK_GRAVITY_NORTH) + (GDK_GRAVITY_NORTH_EAST) + (GDK_GRAVITY_WEST) + (GDK_GRAVITY_CENTER) + (GDK_GRAVITY_EAST) + (GDK_GRAVITY_SOUTH_WEST) + (GDK_GRAVITY_SOUTH) + (GDK_GRAVITY_SOUTH_EAST) + (GDK_GRAVITY_STATIC))) + +(typedef GdkWindowEdge + (enum + (GDK_WINDOW_EDGE_NORTH_WEST) + (GDK_WINDOW_EDGE_NORTH) + (GDK_WINDOW_EDGE_NORTH_EAST) + (GDK_WINDOW_EDGE_WEST) + (GDK_WINDOW_EDGE_EAST) + (GDK_WINDOW_EDGE_SOUTH_WEST) + (GDK_WINDOW_EDGE_SOUTH) + (GDK_WINDOW_EDGE_SOUTH_EAST))) + +(struct _GdkWindowAttr + (title (* gchar)) + (event_mask gint) + (x gint) + (y gint) + (width gint) + (height gint) + (wclass GdkWindowClass) + (visual (* GdkVisual)) + (colormap (* GdkColormap)) + (window_type GdkWindowType) + (cursor (* GdkCursor)) + (wmclass_name (* gchar)) + (wmclass_class (* gchar)) + (override_redirect gboolean) + (type_hint GdkWindowTypeHint)) + +(struct _GdkGeometry + (min_width gint) + (min_height gint) + (max_width gint) + (max_height gint) + (base_width gint) + (base_height gint) + (width_inc gint) + (height_inc gint) + (min_aspect gdouble) + (max_aspect gdouble) + (win_gravity GdkGravity)) + +(struct _GdkPointerHooks + (get_pointer (* (function (* GdkWindow) + (window (* GdkWindow)) + (x (* gint)) + (y (* gint)) + (mask (* GdkModifierType))))) + (window_at_pointer (* (function (* GdkWindow) + (screen (* GdkScreen)) + (win_x (* gint)) + (win_y (* gint)))))) + +(typedef GdkWindowObject (struct _GdkWindowObject)) + +(typedef GdkWindowObjectClass (struct _GdkWindowObjectClass)) + +(struct _GdkWindowObject + (parent_instance GdkDrawable) + (impl (* GdkDrawable)) + (parent (* GdkWindowObject)) + (user_data gpointer) + (x gint) + (y gint) + (extension_events gint) + (filters (* GList)) + (children (* GList)) + (bg_color GdkColor) + (bg_pixmap (* GdkPixmap)) + (paint_stack (* GSList)) + (update_area (* GdkRegion)) + (update_freeze_count guint) + (window_type guint8) + (depth guint8) + (resize_count guint8) + (state GdkWindowState) + ;;(_skip guchar) + (event_mask GdkEventMask) + (update_and_descendants_freeze_count guint)) + +(struct _GdkWindowObjectClass + (parent_class GdkDrawableClass)) + +(extern (* GdkWindow) gdk_window_new + (parent (* GdkWindow)) + (attributes (* GdkWindowAttr)) + (attributes_mask gint)) + +(extern void gdk_window_destroy + (window (* GdkWindow))) + +(extern void gdk_window_show + (window (* GdkWindow))) + +(extern void gdk_window_set_user_data + (window (* GdkWindow)) + (user_data gpointer)) + +(extern void gdk_window_move_resize + (window (* GdkWindow)) + (x gint) (y gint) (width gint) (height gint)) + +(extern void gdk_window_set_background + (window (* GdkWindow)) + (color (const (* GdkColor)))) + +(extern (* GdkWindow) gdk_window_get_pointer + (window (* GdkWindow)) + (x (* gint)) + (y (* gint)) + (mask (* GdkModifierType))) + +(extern void gdk_window_clear_area + (window (* GdkWindow)) + (x gint) + (y gint) + (width gint) + (height gint)) + +(extern void gdk_window_scroll + (window (* GdkWindow)) + (dx gint) + (dy gint)) + +;(extern void gdk_window_invalidate_rect +; (window (* GdkWindow)) +; (rect (* GdkRectangle)) +; (invalidate_children gboolean)) + +(extern void gdk_window_process_updates + (window (* GdkWindow)) + (update_children gboolean)) \ No newline at end of file diff --git a/src/gtk/Includes/genums.cdecl b/src/gtk/Includes/genums.cdecl new file mode 100644 index 000000000..da7eb7b60 --- /dev/null +++ b/src/gtk/Includes/genums.cdecl @@ -0,0 +1,42 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/genums.h |# + +;(include "gtype") + +(typedef GEnumClass (struct _GEnumClass)) +(typedef GFlagsClass (struct _GFlagsClass)) +(typedef GEnumValue (struct _GEnumValue)) +(typedef GFlagsValue (struct _GFlagsValue)) +(struct _GEnumClass + (g_type_class GTypeClass) + ;;< public > + (minimum gint) + (maximum gint) + (n_values guint) + (values (* GEnumValue))) +(struct _GFlagsClass + (g_type_class GTypeClass) + ;;< public > + (mask guint) + (n_values guint) + (values (* GFlagsValue))) +(struct _GEnumValue + (value gint) + (value_name (* gchar)) + (value_nick (* gchar))) +(struct _GFlagsValue + (value guint) + (value_name (* gchar)) + (value_nick (* gchar))) + +(extern void g_value_set_enum + (value (* GValue)) + (v_enum gint)) +(extern gint g_value_get_enum + (value (const (* GValue)))) +(extern void g_value_set_flags + (value (* GValue)) + (v_flags guint)) +(extern guint g_value_get_flags + (value (const (* GValue)))) \ No newline at end of file diff --git a/src/gtk/Includes/gerror.cdecl b/src/gtk/Includes/gerror.cdecl new file mode 100644 index 000000000..99f8ad08e --- /dev/null +++ b/src/gtk/Includes/gerror.cdecl @@ -0,0 +1,43 @@ +#| -*-Scheme-*- + +glib-2.0/glib/gerror.h |# + +(include "gquark") + +(typedef GError (struct _GError)) + +(struct _GError + (domain GQuark) + (code gint) + (message (* gchar))) + +;(extern (* GError) g_error_new +; (domain GQuark) +; (code gint) +; (format (* (const gchar))) +; ...) + +;(extern (* GError) g_error_new_literal +; (domain GQuark) +; (code gint) +; (message (* (const gchar)))) + +(extern void g_error_free (error (* GError))) + +;(extern (* GError) g_error_copy (error (* (const GError)))) + +;(extern gboolean g_error_matches +; (error (* (const GError))) +; (domain GQuark) +; (code gint)) + +;(extern void g_set_error +; (err (* (* GError))) +; (domain GQuark) +; (code gint) +; (format (* (const gchar))) +; ...) + +;(extern void g_propagate_error (dest (* (* GError))) (src (* GError))) + +;(extern void g_clear_error (err (* (* GError)))) diff --git a/src/gtk/Includes/glib.cdecl b/src/gtk/Includes/glib.cdecl new file mode 100644 index 000000000..289d3a81a --- /dev/null +++ b/src/gtk/Includes/glib.cdecl @@ -0,0 +1,54 @@ +#| -*-Scheme-*- + +glib-2.0/glib.h |# + +;(include "glib/galloca") +;(include "glib/garray") +;(include "glib/gasyncqueue") +;(include "glib/gatomic") +;(include "glib/gbacktrace") +;(include "glib/gbase64") +;(include "glib/gbookmarkfile") +;(include "glib/gcache") +;(include "glib/gcompletion") +;(include "glib/gconvert") +;(include "glib/gdataset") +;(include "glib/gdate") +;(include "glib/gdir") +(include "gerror") +;(include "glib/gfileutils") +;(include "glib/ghash") +;(include "glib/ghook") +;(include "glib/giochannel") +;(include "glib/gkeyfile") +;(include "glib/glist") +;(include "glib/gmacros") +;(include "glib/gmain") +;(include "glib/gmappedfile") +;(include "glib/gmarkup") +;(include "glib/gmem") +;(include "glib/gmessages") +;(include "glib/gnode") +;(include "glib/goption") +;(include "glib/gpattern") +;(include "glib/gprimes") +;(include "glib/gqsort") +(include "gquark") +;(include "glib/gqueue") +;(include "glib/grand") +;(include "glib/grel") +;(include "glib/gregex") +;(include "glib/gscanner") +;(include "glib/gsequence") +;(include "glib/gshell") +;(include "glib/gslist") +;(include "glib/gspawn") +;(include "glib/gstrfuncs") +;(include "glib/gstring") +;(include "glib/gthread") +;(include "glib/gthreadpool") +;(include "glib/gtimer") +;(include "glib/gtree") +(include "gtypes") +;(include "glib/gunicode") +;(include "glib/gutils") diff --git a/src/gtk/Includes/gobject.cdecl b/src/gtk/Includes/gobject.cdecl new file mode 100644 index 000000000..e00c9d54b --- /dev/null +++ b/src/gtk/Includes/gobject.cdecl @@ -0,0 +1,120 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gobject.h |# + +;(include "gtype") +;(include "gvalue") +;(include "gparam") +;(include "gclosure") +;(include "gsignal") + +(typedef GObject (struct _GObject)) +(typedef GObjectClass (struct _GObjectClass)) +(typedef GObjectConstructParam (struct _GObjectConstructParam)) +(typedef GObjectGetPropertyFunc + (* (function void + (object (* GObject)) + (property_id guint) + (value (* GValue)) + (pspec (* GParamSpec))))) +(typedef GObjectSetPropertyFunc + (* (function void + (object (* GObject)) + (property_id guint) + (value (const (* GValue))) + (pspec (* GParamSpec))))) +(typedef GObjectFinalizeFunc + (* (function void (object (* GObject))))) +(typedef GWeakNotify + (* (function void + (data gpointer) + (where_the_object_was (* GObject))))) + +(struct _GObject + (g_type_instance GTypeInstance) + ;; < private > + (ref_count guint) + (qdata (* GData))) + +(struct _GObjectClass + (g_type_class GTypeClass) + ;; < private > + (construct_properties (* GSList)) + ;; < public > + ;; overridable methods + (constructor + (* (function (* GObject) + (type GType) + (n_construct_properties guint) + (construct_properties (* GObjectConstructParam))))) + (set_property + (* (function void + (object (* GObject)) + (property_id guint) + (value (const (* GValue))) + (pspec (* GParamSpec))))) + (get_property + (* (function void + (object (* GObject)) + (property_id guint) + (value (* GValue)) + (pspec (* GParamSpec))))) + (dispose + (* (function void + (object (* GObject))))) + (finalize + (* (function void + (object (* GObject))))) + + ;; seldomly overidden + (dispatch_properties_changed + (* (function void + (object (* GObject)) + (n_pspecs guint) + (pspecs (* (* GParamSpec)))))) + + ;; signals + (notify + (* (function void + (object (* GObject)) + (pspec (* GParamSpec))))) + + ;; called when done constructing + (constructed + (* (function void (object (* GObject))))) + ;; < private > + ;; padding + (pdummy (array gpointer 7))) + +(struct _GObjectConstructParam + (pspec (* GParamSpec)) + (value (* GValue))) + +(extern (* GObjectClass) G_OBJECT_GET_CLASS (object (* GObject))) + +(extern GType G_OBJECT_TYPE (instance (* GTypeInstance))) + +(extern gpointer g_object_ref_sink (object gpointer)) +(extern gpointer g_object_ref (object gpointer)) + +(extern void g_object_unref (object gpointer)) + +(extern (* GParamSpec) g_object_class_find_property + (oclass (* GObjectClass)) + (property_name (const (* gchar)))) + +(extern void g_object_set_property + (object (* GObject)) + (property_name (const (* gchar))) + (value (const (* GValue)))) + +(extern void g_object_get_property + (object (* GObject)) + (property_name (const (* gchar))) + (value (* GValue))) + +(extern void g_value_set_object + (value (* GValue)) + (v_object gpointer)) +(extern (* GObject) g_value_get_object + (value (const (* GValue)))) diff --git a/src/gtk/Includes/gparam.cdecl b/src/gtk/Includes/gparam.cdecl new file mode 100644 index 000000000..776750bf1 --- /dev/null +++ b/src/gtk/Includes/gparam.cdecl @@ -0,0 +1,61 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gparam.h |# + +(typedef GParamFlags + (enum + (G_PARAM_READABLE) + (G_PARAM_WRITABLE) + (G_PARAM_CONSTRUCT) + (G_PARAM_CONSTRUCT_ONLY) + (G_PARAM_LAX_VALIDATION) + (G_PARAM_STATIC_NAME) + (G_PARAM_STATIC_NICK) + (G_PARAM_STATIC_BLURB))) + +(typedef GParamSpec (struct _GParamSpec)) +(typedef GParamSpecClass (struct _GParamSpecClass)) +(typedef GParameter (struct _GParameter)) +;(typedef GParamSpecPool (struct _GParamSpecPool)) + +(struct _GParamSpec + (g_type_instance GTypeInstance) + (name (* gchar)) + (flags GParamFlags) + (value_type GType) + (owner_type GType) + ;;< private > + (_nick (* gchar)) + (_blurb (* gchar)) + (qdata (* GData)) + (ref_count guint) + (param_id guint)) + +(struct _GParamSpecClass + (g_type_class GTypeClass) + (value_type GType) + (finalize (* (function void (pspec (* GParamSpec))))) + ;; GParam methods + (value_set_default + (* (function void + ((* GParamSpec) pspec) + (value (* GValue))))) + (value_validate + (* (function gboolean + (pspec (* GParamSpec)) + (value (* GValue))))) + (values_cmp + (* (function gint + (pspec (* GParamSpec)) + (value1 (const (* GValue))) + (value2 (const (* GValue)))))) + ;;< private > + (dummy (array gpointer 4))) + +(struct _GParameter ; auxillary structure for _setv() variants + (name (const (* gchar))) + (value GValue)) + +(extern GType ;glib-2.0/gobject/gparam.h + G_PARAM_SPEC_VALUE_TYPE + (pspec (* GParamSpec))) \ No newline at end of file diff --git a/src/gtk/Includes/gparamspecs.cdecl b/src/gtk/Includes/gparamspecs.cdecl new file mode 100644 index 000000000..6e70e4c88 --- /dev/null +++ b/src/gtk/Includes/gparamspecs.cdecl @@ -0,0 +1,141 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gparamspecs.h |# + +;(include "gvalue") +;(include "genums") +;(include "gboxed") +;(include "gobject") + +(typedef GParamSpecChar (struct _GParamSpecChar)) +(typedef GParamSpecUChar (struct _GParamSpecUChar)) +(typedef GParamSpecBoolean (struct _GParamSpecBoolean)) +(typedef GParamSpecInt (struct _GParamSpecInt)) +(typedef GParamSpecUInt (struct _GParamSpecUInt)) +(typedef GParamSpecLong (struct _GParamSpecLong)) +(typedef GParamSpecULong (struct _GParamSpecULong)) +;(typedef GParamSpecInt64 (struct _GParamSpecInt64)) +;(typedef GParamSpecUInt64 (struct _GParamSpecUInt64)) +;(typedef GParamSpecUnichar (struct _GParamSpecUnichar)) +(typedef GParamSpecEnum (struct _GParamSpecEnum)) +(typedef GParamSpecFlags (struct _GParamSpecFlags)) +(typedef GParamSpecFloat (struct _GParamSpecFloat)) +(typedef GParamSpecDouble (struct _GParamSpecDouble)) +(typedef GParamSpecString (struct _GParamSpecString)) +(typedef GParamSpecParam (struct _GParamSpecParam)) +(typedef GParamSpecBoxed (struct _GParamSpecBoxed)) +(typedef GParamSpecPointer (struct _GParamSpecPointer)) +(typedef GParamSpecValueArray (struct _GParamSpecValueArray)) +(typedef GParamSpecObject (struct _GParamSpecObject)) +(typedef GParamSpecOverride (struct _GParamSpecOverride)) + +(struct _GParamSpecChar + (parent_instance GParamSpec) + (minimum gint8) + (maximum gint8) + (default_value gint8)) + +(struct _GParamSpecUChar + (parent_instance GParamSpec) + (minimum guint8) + (maximum guint8) + (default_value guint8)) + +(struct _GParamSpecBoolean + (parent_instance GParamSpec) + (default_value gboolean)) + +(struct _GParamSpecInt + (parent_instance GParamSpec) + (minimum gint) + (maximum gint) + (default_value gint)) + +(struct _GParamSpecUInt + (parent_instance GParamSpec) + (minimum guint) + (maximum guint) + (default_value guint)) + +(struct _GParamSpecLong + (parent_instance GParamSpec) + (minimum glong) + (maximum glong) + (default_value glong)) + +(struct _GParamSpecULong + (parent_instance GParamSpec) + (minimum gulong) + (maximum gulong) + (default_value gulong)) + +;(struct _GParamSpecInt64 +; (parent_instance GParamSpec) +; (minimum gint64) +; (maximum gint64) +; (default_value gint64)) +; +;(struct _GParamSpecUInt64 +; (parent_instance GParamSpec) +; (minimum guint64) +; (maximum guint64) +; (default_value guint64)) + +;(struct _GParamSpecUnichar +; (parent_instance GParamSpec) +; (default_value gunichar)) + +(struct _GParamSpecEnum + (parent_instance GParamSpec) + (enum_class (* GEnumClass)) + (default_value gint)) + +(struct _GParamSpecFlags + (parent_instance GParamSpec) + (flags_class (* GFlagsClass)) + (default_value guint)) + +(struct _GParamSpecFloat + (parent_instance GParamSpec) + (minimum gfloat) + (maximum gfloat) + (default_value gfloat) + (epsilon gfloat)) + +(struct _GParamSpecDouble + (parent_instance GParamSpec) + (minimum gdouble) + (maximum gdouble) + (default_value gdouble) + (epsilon gdouble)) + +(struct _GParamSpecString + (parent_instance GParamSpec) + (default_value (* gchar)) + (cset_first (* gchar)) + (cset_nth (* gchar)) + (substitutor gchar) + ;;(_skip guchar) + ) + +(struct _GParamSpecParam + (parent_instance GParamSpec)) + +(struct _GParamSpecBoxed + (parent_instance GParamSpec)) + +(struct _GParamSpecPointer + (parent_instance GParamSpec)) + +(struct _GParamSpecValueArray + (parent_instance GParamSpec) + (element_spec (* GParamSpec)) + (fixed_n_elements guint)) + +(struct _GParamSpecObject + (parent_instance GParamSpec)) + +(struct _GParamSpecOverride + ;;< private > + (parent_instance GParamSpec) + (overridden (* GParamSpec))) \ No newline at end of file diff --git a/src/gtk/Includes/gquark.cdecl b/src/gtk/Includes/gquark.cdecl new file mode 100644 index 000000000..b74034a48 --- /dev/null +++ b/src/gtk/Includes/gquark.cdecl @@ -0,0 +1,16 @@ +#| -*-Scheme-*- + +glib-2.0/glib/gquark.h |# + +;(include "gtypes") + +(typedef GQuark guint32) + +(extern GQuark g_quark_try_string + (string (const (* gchar)))) +;(extern GQuark g_quark_from_static_string +; (string (const (* gchar)))) +(extern GQuark g_quark_from_string + (string (const (* gchar)))) +(extern (const (* gchar)) g_quark_to_string + (quark GQuark)) \ No newline at end of file diff --git a/src/gtk/Includes/gsignal.cdecl b/src/gtk/Includes/gsignal.cdecl new file mode 100644 index 000000000..81903defa --- /dev/null +++ b/src/gtk/Includes/gsignal.cdecl @@ -0,0 +1,23 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gsignal.h |# + +;(include "gclosure") +;(include "gvalue") +;(include "gparam") +;(include "gmarshal") + +(extern gulong g_signal_connect_data + (instance gpointer) + (detailed_signal (const (* gchar))) + (CALLBACK GCallback) + (ID gpointer) + (destroy_data GClosureNotify) + (connect_flags GConnectFlags)) +(typedef GCallback (* mumble)) +(typedef GClosureNotify (* mumble)) +(typedef GConnectFlags ulong) + +(extern void g_signal_handler_disconnect + (instance gpointer) + (handler_id gulong)) \ No newline at end of file diff --git a/src/gtk/Includes/gtk.cdecl b/src/gtk/Includes/gtk.cdecl new file mode 100644 index 000000000..99f02f6a8 --- /dev/null +++ b/src/gtk/Includes/gtk.cdecl @@ -0,0 +1,165 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtk.h |# + +(include "gdk") +;(include "gtkaboutdialog") +;(include "gtkaccelgroup") +;(include "gtkaccellabel") +;(include "gtkaccelmap") +;(include "gtkaccessible") +;(include "gtkaction") +;(include "gtkactiongroup") +(include "gtkadjustment") +;(include "gtkalignment") +;(include "gtkarrow") +;(include "gtkaspectframe") +;(include "gtkbbox") +;(include "gtkbin") +;(include "gtkbindings") +(include "gtkbox") +;(include "gtkbutton") +;(include "gtkcalendar") +;(include "gtkcelllayout") +;(include "gtkcellrenderer") +;(include "gtkcellrenderercombo") +;(include "gtkcellrendererpixbuf") +;(include "gtkcellrendererprogress") +;(include "gtkcellrenderertext") +;(include "gtkcellrenderertoggle") +;(include "gtkcellview") +;(include "gtkcheckbutton") +;(include "gtkcheckmenuitem") +;(include "gtkclipboard") +;(include "gtkclist") +;(include "gtkcolorbutton") +;(include "gtkcolorsel") +;(include "gtkcolorseldialog") +;(include "gtkcombo") +;(include "gtkcombobox") +;(include "gtkcomboboxentry") +;(include "gtkcontainer") +;(include "gtkctree") +;(include "gtkcurve") +;(include "gtkdialog") +;(include "gtkdnd") +;(include "gtkdrawingarea") +;(include "gtkeditable") +;(include "gtkentry") +;(include "gtkentrycompletion") +(include "gtkenums") +;(include "gtkeventbox") +;(include "gtkexpander") +;(include "gtkfilesel") +;(include "gtkfixed") +;(include "gtkfilechooserbutton") +;(include "gtkfilechooserdialog") +;(include "gtkfilechooserwidget") +;(include "gtkfontbutton") +;(include "gtkfontsel") +;(include "gtkframe") +;(include "gtkgamma") +;(include "gtkgc") +;(include "gtkhandlebox") +;(include "gtkhbbox") +;(include "gtkhbox") +;(include "gtkhpaned") +;(include "gtkhruler") +;(include "gtkhscale") +;(include "gtkhscrollbar") +;(include "gtkhseparator") +;(include "gtkiconfactory") +;(include "gtkicontheme") +;(include "gtkiconview") +;(include "gtkimage") +;(include "gtkimagemenuitem") +;(include "gtkimcontext") +;(include "gtkimcontextsimple") +;(include "gtkimmulticontext") +;(include "gtkinputdialog") +;(include "gtkinvisible") +;(include "gtkitem") +;(include "gtkitemfactory") +;(include "gtklabel") +;(include "gtklayout") +;(include "gtklist") +;(include "gtklistitem") +;(include "gtkliststore") +;(include "gtkmain") +;(include "gtkmenu") +;(include "gtkmenubar") +;(include "gtkmenuitem") +;(include "gtkmenushell") +;(include "gtkmenutoolbutton") +;(include "gtkmessagedialog") +;(include "gtkmisc") +;(include "gtkmodules") +;(include "gtknotebook") +(include "gtkobject") +;(include "gtkoldeditable") +;(include "gtkoptionmenu") +;(include "gtkpaned") +;(include "gtkpixmap") +;(include "gtkplug") +;(include "gtkpreview") +;(include "gtkprogress") +;(include "gtkprogressbar") +;(include "gtkradioaction") +;(include "gtkradiobutton") +;(include "gtkradiomenuitem") +;(include "gtkradiotoolbutton") +;(include "gtkrange") +;(include "gtkrc") +;(include "gtkruler") +;(include "gtkscale") +;(include "gtkscrollbar") +;(include "gtkscrolledwindow") +;(include "gtkselection") +;(include "gtkseparator") +;(include "gtkseparatormenuitem") +;(include "gtkseparatortoolitem") +;(include "gtksettings") +;(include "gtksignal") +;(include "gtksizegroup") +;(include "gtksocket") +;(include "gtkspinbutton") +;(include "gtkstatusbar") +;(include "gtkstock") +(include "gtkstyle") +;(include "gtktable") +;(include "gtktearoffmenuitem") +;(include "gtktext") +;(include "gtktextbuffer") +;(include "gtktextview") +;(include "gtktipsquery") +;(include "gtktoggleaction") +;(include "gtktogglebutton") +;(include "gtktoggletoolbutton") +;(include "gtktoolbar") +;(include "gtktoolbar") +;(include "gtktoolbutton") +;(include "gtktoolitem") +;(include "gtktooltips") +;(include "gtktree") +;(include "gtktreednd") +;(include "gtktreeitem") +;(include "gtktreemodel") +;(include "gtktreemodelfilter") +;(include "gtktreemodelsort") +;(include "gtktreeselection") +;(include "gtktreestore") +;(include "gtktreeview") +;(include "gtktreeviewcolumn") +(include "gtktypeutils") +;(include "gtkuimanager") +;(include "gtkvbbox") +(include "gtkvbox") +;(include "gtkversion") +;(include "gtkviewport") +;(include "gtkvpaned") +;(include "gtkvruler") +;(include "gtkvscale") +;(include "gtkvscrollbar") +;(include "gtkvseparator") +(include "gtkwidget") +;(include "gtkwindow") \ No newline at end of file diff --git a/src/gtk/Includes/gtkadjustment.cdecl b/src/gtk/Includes/gtkadjustment.cdecl new file mode 100644 index 000000000..c96980995 --- /dev/null +++ b/src/gtk/Includes/gtkadjustment.cdecl @@ -0,0 +1,42 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkadjustment.h |# + +(typedef GtkAdjustment (struct _GtkAdjustment)) + +(struct _GtkAdjustment + (parent_instance GtkObject) + (lower gdouble) + (upper gdouble) + (value gdouble) + (step_increment gdouble) + (page_increment gdouble) + (page_size gdouble)) + +;(extern GType gtk_adjustment_get_type) + +(extern (* GtkObject) gtk_adjustment_new + (value gdouble) + (lower gdouble) + (upper gdouble) + (step_increment gdouble) + (page_increment gdouble) + (page_size gdouble)) + +(extern void gtk_adjustment_changed + (adjustment (* GtkAdjustment))) + +(extern void gtk_adjustment_value_changed + (adjustment (* GtkAdjustment))) + +;(extern void gtk_adjustment_clamp_page +; (adjustment (* GtkAdjustment)) +; (lower gdouble) +; (upper gdouble)) + +;(extern gdouble gtk_adjustment_get_value +; (adjustment (* GtkAdjustment))) + +;(extern void gtk_adjustment_set_value +; (adjustment (* GtkAdjustment)) +; (value gdouble)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkbox.cdecl b/src/gtk/Includes/gtkbox.cdecl new file mode 100644 index 000000000..26c3f58e0 --- /dev/null +++ b/src/gtk/Includes/gtkbox.cdecl @@ -0,0 +1,19 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkbox.h |# + +(extern void + gtk_box_pack_start + (box (* GtkBox)) + (child (* GtkWidget)) + (expand gboolean) + (fill gboolean) + (padding guint)) + +(extern void + gtk_box_pack_end + (box (* GtkBox)) + (child (* GtkWidget)) + (expand gboolean) + (fill gboolean) + (padding guint)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkenums.cdecl b/src/gtk/Includes/gtkenums.cdecl new file mode 100644 index 000000000..1fa8a7fcc --- /dev/null +++ b/src/gtk/Includes/gtkenums.cdecl @@ -0,0 +1,301 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkenums.h |# + +;(include "glib-object") + +(typedef GtkAnchorType + (enum + (GTK_ANCHOR_CENTER) + (GTK_ANCHOR_NORTH) + (GTK_ANCHOR_NORTH_WEST) + (GTK_ANCHOR_NORTH_EAST) + (GTK_ANCHOR_SOUTH) + (GTK_ANCHOR_SOUTH_WEST) + (GTK_ANCHOR_SOUTH_EAST) + (GTK_ANCHOR_WEST) + (GTK_ANCHOR_EAST) + (GTK_ANCHOR_N) + (GTK_ANCHOR_NW) + (GTK_ANCHOR_NE) + (GTK_ANCHOR_S) + (GTK_ANCHOR_SW) + (GTK_ANCHOR_SE) + (GTK_ANCHOR_W) + (GTK_ANCHOR_E))) + +(typedef GtkArrowType + (enum + (GTK_ARROW_UP) + (GTK_ARROW_DOWN) + (GTK_ARROW_LEFT) + (GTK_ARROW_RIGHT))) + +(typedef GtkAttachOptions + (enum + (GTK_EXPAND) + (GTK_SHRINK) + (GTK_FILL))) + +(typedef GtkButtonBoxStyle + (enum + (GTK_BUTTONBOX_DEFAULT_STYLE) + (GTK_BUTTONBOX_SPREAD) + (GTK_BUTTONBOX_EDGE) + (GTK_BUTTONBOX_START) + (GTK_BUTTONBOX_END))) + +(typedef GtkCurveType + (enum + (GTK_CURVE_TYPE_LINEAR) + (GTK_CURVE_TYPE_SPLINE) + (GTK_CURVE_TYPE_FREE))) + +(typedef GtkDeleteType + (enum + (GTK_DELETE_CHARS) + (GTK_DELETE_WORD_ENDS) + (GTK_DELETE_WORDS) + (GTK_DELETE_DISPLAY_LINES) + (GTK_DELETE_DISPLAY_LINE_ENDS) + (GTK_DELETE_PARAGRAPH_ENDS) + (GTK_DELETE_PARAGRAPHS) + (GTK_DELETE_WHITESPACE))) + +(typedef GtkDirectionType + (enum + (GTK_DIR_TAB_FORWARD) + (GTK_DIR_TAB_BACKWARD) + (GTK_DIR_UP) + (GTK_DIR_DOWN) + (GTK_DIR_LEFT) + (GTK_DIR_RIGHT))) + +(typedef GtkExpanderStyle + (enum + (GTK_EXPANDER_COLLAPSED) + (GTK_EXPANDER_SEMI_COLLAPSED) + (GTK_EXPANDER_SEMI_EXPANDED) + (GTK_EXPANDER_EXPANDED))) + +(typedef GtkIconSize + (enum + (GTK_ICON_SIZE_INVALID) + (GTK_ICON_SIZE_MENU) + (GTK_ICON_SIZE_SMALL_TOOLBAR) + (GTK_ICON_SIZE_LARGE_TOOLBAR) + (GTK_ICON_SIZE_BUTTON) + (GTK_ICON_SIZE_DND) + (GTK_ICON_SIZE_DIALOG))) + +(typedef GtkTextDirection + (enum + (GTK_TEXT_DIR_NONE) + (GTK_TEXT_DIR_LTR) + (GTK_TEXT_DIR_RTL))) + +(typedef GtkJustification + (enum + (GTK_JUSTIFY_LEFT) + (GTK_JUSTIFY_RIGHT) + (GTK_JUSTIFY_CENTER) + (GTK_JUSTIFY_FILL))) + +(typedef GtkMenuDirectionType + (enum + (GTK_MENU_DIR_PARENT) + (GTK_MENU_DIR_CHILD) + (GTK_MENU_DIR_NEXT) + (GTK_MENU_DIR_PREV))) + +(typedef GtkMetricType + (enum + (GTK_PIXELS) + (GTK_INCHES) + (GTK_CENTIMETERS))) + +(typedef GtkMovementStep + (enum + (GTK_MOVEMENT_LOGICAL_POSITIONS) + (GTK_MOVEMENT_VISUAL_POSITIONS) + (GTK_MOVEMENT_WORDS) + (GTK_MOVEMENT_DISPLAY_LINES) + (GTK_MOVEMENT_DISPLAY_LINE_ENDS) + (GTK_MOVEMENT_PARAGRAPHS) + (GTK_MOVEMENT_PARAGRAPH_ENDS) + (GTK_MOVEMENT_PAGES) + (GTK_MOVEMENT_BUFFER_ENDS) + (GTK_MOVEMENT_HORIZONTAL_PAGES))) + +(typedef GtkScrollStep + (enum + (GTK_SCROLL_STEPS) + (GTK_SCROLL_PAGES) + (GTK_SCROLL_ENDS) + (GTK_SCROLL_HORIZONTAL_STEPS) + (GTK_SCROLL_HORIZONTAL_PAGES) + (GTK_SCROLL_HORIZONTAL_ENDS))) + +(typedef GtkOrientation + (enum + (GTK_ORIENTATION_HORIZONTAL) + (GTK_ORIENTATION_VERTICAL))) + +(typedef GtkCornerType + (enum + (GTK_CORNER_TOP_LEFT) + (GTK_CORNER_BOTTOM_LEFT) + (GTK_CORNER_TOP_RIGHT) + (GTK_CORNER_BOTTOM_RIGHT))) + +(typedef GtkPackType + (enum + (GTK_PACK_START) + (GTK_PACK_END))) + +(typedef GtkPathPriorityType + (enum + (GTK_PATH_PRIO_LOWEST) + (GTK_PATH_PRIO_GTK) + (GTK_PATH_PRIO_APPLICATION) + (GTK_PATH_PRIO_THEME) + (GTK_PATH_PRIO_RC) + (GTK_PATH_PRIO_HIGHEST) + (GTK_PATH_PRIO_MASK))) + +(typedef GtkPathType + (enum + (GTK_PATH_WIDGET) + (GTK_PATH_WIDGET_CLASS) + (GTK_PATH_CLASS))) + +(typedef GtkPolicyType + (enum + (GTK_POLICY_ALWAYS) + (GTK_POLICY_AUTOMATIC) + (GTK_POLICY_NEVER))) + +(typedef GtkPositionType + (enum + (GTK_POS_LEFT) + (GTK_POS_RIGHT) + (GTK_POS_TOP) + (GTK_POS_BOTTOM))) + +(typedef GtkReliefStyle + (enum + (GTK_RELIEF_NORMAL) + (GTK_RELIEF_HALF) + (GTK_RELIEF_NONE))) + +(typedef GtkResizeMode + (enum + (GTK_RESIZE_PARENT) + (GTK_RESIZE_QUEUE) + (GTK_RESIZE_IMMEDIATE))) + +(typedef GtkScrollType + (enum + (GTK_SCROLL_NONE) + (GTK_SCROLL_JUMP) + (GTK_SCROLL_STEP_BACKWARD) + (GTK_SCROLL_STEP_FORWARD) + (GTK_SCROLL_PAGE_BACKWARD) + (GTK_SCROLL_PAGE_FORWARD) + (GTK_SCROLL_STEP_UP) + (GTK_SCROLL_STEP_DOWN) + (GTK_SCROLL_PAGE_UP) + (GTK_SCROLL_PAGE_DOWN) + (GTK_SCROLL_STEP_LEFT) + (GTK_SCROLL_STEP_RIGHT) + (GTK_SCROLL_PAGE_LEFT) + (GTK_SCROLL_PAGE_RIGHT) + (GTK_SCROLL_START) + (GTK_SCROLL_END))) + +(typedef GtkSelectionMode + (enum + (GTK_SELECTION_NONE) + (GTK_SELECTION_SINGLE) + (GTK_SELECTION_BROWSE) + (GTK_SELECTION_MULTIPLE) + (GTK_SELECTION_EXTENDED))) + +(typedef GtkShadowType + (enum + (GTK_SHADOW_NONE) + (GTK_SHADOW_IN) + (GTK_SHADOW_OUT) + (GTK_SHADOW_ETCHED_IN) + (GTK_SHADOW_ETCHED_OUT))) + +(typedef GtkStateType + (enum + (GTK_STATE_NORMAL) + (GTK_STATE_ACTIVE) + (GTK_STATE_PRELIGHT) + (GTK_STATE_SELECTED) + (GTK_STATE_INSENSITIVE))) + +(typedef GtkToolbarStyle + (enum + (GTK_TOOLBAR_ICONS) + (GTK_TOOLBAR_TEXT) + (GTK_TOOLBAR_BOTH) + (GTK_TOOLBAR_BOTH_HORIZ))) + +(typedef GtkUpdateType + (enum + (GTK_UPDATE_CONTINUOUS) + (GTK_UPDATE_DISCONTINUOUS) + (GTK_UPDATE_DELAYED))) + +(typedef GtkVisibility + (enum + (GTK_VISIBILITY_NONE) + (GTK_VISIBILITY_PARTIAL) + (GTK_VISIBILITY_FULL))) + +(typedef GtkWindowPosition + (enum + (GTK_WIN_POS_NONE) + (GTK_WIN_POS_CENTER) + (GTK_WIN_POS_MOUSE) + (GTK_WIN_POS_CENTER_ALWAYS) + (GTK_WIN_POS_CENTER_ON_PARENT))) + +(typedef GtkWindowType + (enum + (GTK_WINDOW_TOPLEVEL) + (GTK_WINDOW_POPUP))) + +(typedef GtkWrapMode + (enum + (GTK_WRAP_NONE) + (GTK_WRAP_CHAR) + (GTK_WRAP_WORD) + (GTK_WRAP_WORD_CHAR))) + +(typedef GtkSortType + (enum + (GTK_SORT_ASCENDING) + (GTK_SORT_DESCENDING))) + +(typedef GtkIMPreeditStyle + (enum + (GTK_IM_PREEDIT_NOTHING) + (GTK_IM_PREEDIT_CALLBACK) + (GTK_IM_PREEDIT_NONE))) + +(typedef GtkIMStatusStyle + (enum + (GTK_IM_STATUS_NOTHING) + (GTK_IM_STATUS_CALLBACK) + (GTK_IM_STATUS_NONE))) + +(typedef GtkPackDirection + (enum + (GTK_PACK_DIRECTION_LTR) + (GTK_PACK_DIRECTION_RTL) + (GTK_PACK_DIRECTION_TTB) + (GTK_PACK_DIRECTION_BTT))) \ No newline at end of file diff --git a/src/gtk/Includes/gtkobject.cdecl b/src/gtk/Includes/gtkobject.cdecl new file mode 100644 index 000000000..a55788d19 --- /dev/null +++ b/src/gtk/Includes/gtkobject.cdecl @@ -0,0 +1,39 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkobject.h |# + +;(include "gtkenums") +;(include "gtktypeutils") +;(include "gtkdebug") + +(typedef GtkObjectFlags + (enum + (GTK_IN_DESTRUCTION) + (GTK_FLOATING) + (GTK_RESERVED_1) + (GTK_RESERVED_2))) + +(typedef GtkObjectClass (struct _GtkObjectClass)) + +(struct _GtkObject + (parent_instance GObject) + (flags guint32)) + +(struct _GtkObjectClass + (parent_class GObjectClass) + + ;; Non overridable class methods to set and get per class arguments + (set_arg (* (function void + (object (* GtkObject)) + (arg (* GtkArg)) + (arg_id guint)))) + (get_arg (* (function void + (object (* GtkObject)) + (arg (* GtkArg)) + (arg_id guint)))) + + (destroy (* (function void + (object (* GtkObject)))))) + +(extern void gtk_object_sink (object (* GtkObject))) +(extern void gtk_object_destroy (object (* GtkObject))) diff --git a/src/gtk/Includes/gtkstyle.cdecl b/src/gtk/Includes/gtkstyle.cdecl new file mode 100644 index 000000000..dc852dc3b --- /dev/null +++ b/src/gtk/Includes/gtkstyle.cdecl @@ -0,0 +1,119 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkstyle.h |# + +(typedef GtkWidget (struct _GtkWidget)) + +(typedef GtkStyle (struct _GtkStyle)) + +(struct _GtkStyle + (parent_instance GObject) + + (fg (array GdkColor 5)) + (bg (array GdkColor 5)) + (light (array GdkColor 5)) + (dark (array GdkColor 5)) + (mid (array GdkColor 5)) + (text (array GdkColor 5)) + (base (array GdkColor 5)) + (text_aa (array GdkColor 5)) + + (black GdkColor) + (white GdkColor) + (font_desc (* PangoFontDescription)) + + (xthickness gint) + (ythickness gint) + + (fg_gc (array (* GdkGC) 5)) + (bg_gc (array (* GdkGC) 5)) + (light_gc (array (* GdkGC) 5)) + (dark_gc (array (* GdkGC) 5)) + (mid_gc (array (* GdkGC) 5)) + (text_gc (array (* GdkGC) 5)) + (base_gc (array (* GdkGC) 5)) + (text_aa_gc (array (* GdkGC) 5)) + (black_gc (* GdkGC)) + (white_gc (* GdkGC)) + + (bg_pixmap (array (* GdkPixmap) 5)) + + ;; < private > + + (attach_count gint) + + (depth gint) + (colormap (* GdkColormap)) + (private_font (* GdkFont)) + (private_font_desc (* PangoFontDescription)) + + (rc_style (* GtkRcStyle)) + + (styles (* GSList)) + (property_cache (* GArray)) + (icon_factories (* GSList))) + +(extern (* GtkStyle) gtk_style_attach + (style (* GtkStyle)) + (window (* GdkWindow))) + +(extern void gtk_style_set_background + (style (* GtkStyle)) + (window (* GdkWindow)) + (state_type GtkStateType)) + +(extern void gtk_paint_hline + (style (* GtkStyle)) + (window (* GdkWindow)) + (state_type GtkStateType) + (area (* GdkRectangle)) + (widget (* GtkWidget)) + (detail (const (* gchar))) + (x1 gint) + (x2 gint) + (y gint)) + +(extern void gtk_paint_vline + (style (* GtkStyle)) + (window (* GdkWindow)) + (state_type GtkStateType) + (area (* GdkRectangle)) + (widget (* GtkWidget)) + (detail (const (* gchar))) + (y1_ gint) + (y2_ gint) + (x gint)) + +(extern void gtk_paint_box + (style (* GtkStyle)) + (window (* GdkWindow)) + (state_type GtkStateType) + (shadow_type GtkShadowType) + (area (* GdkRectangle)) + (widget (* GtkWidget)) + (detail (const (* gchar))) + (x gint) + (y gint) + (width gint) + (height gint)) + +(extern void gtk_paint_focus + (style (* GtkStyle)) + (window (* GdkWindow)) + (state_type GtkStateType) + (area (* GdkRectangle)) + (widget (* GtkWidget)) + (detail (const (* gchar))) + (x gint) (y gint) + (width gint) (height gint)) + +(extern void gtk_paint_layout + (style (* GtkStyle)) + (window (* GdkWindow)) + (state_type GtkStateType) + (use_text gboolean) + (area (* GdkRectangle)) + (widget (* GtkWidget)) + (detail (const (* gchar))) + (x gint) (y gint) + (layout (* PangoLayout))) \ No newline at end of file diff --git a/src/gtk/Includes/gtktypeutils.cdecl b/src/gtk/Includes/gtktypeutils.cdecl new file mode 100644 index 000000000..38940c7eb --- /dev/null +++ b/src/gtk/Includes/gtktypeutils.cdecl @@ -0,0 +1,23 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtktypeutils.h |# + +;(include "glib-object") + +(typedef GtkType GType) + +;(include "gtktypebuiltins") + +;(typedef GtkArg (struct _GtkArg)) +(typedef GtkObject (struct _GtkObject)) +(typedef GtkFunction + (* (function gboolean (data gpointer)))) +(typedef GtkDestroyNotify + (* (function void (data gpointer)))) +(typedef GtkCallbackMarshal + (* (function void + (object (* GtkObject)) + (data gpointer) + (n_args guint) + (args (* GtkArg))))) +(typedef GtkSignalFunc (* (function void))) diff --git a/src/gtk/Includes/gtkvbox.cdecl b/src/gtk/Includes/gtkvbox.cdecl new file mode 100644 index 000000000..44a3d5a0a --- /dev/null +++ b/src/gtk/Includes/gtkvbox.cdecl @@ -0,0 +1,8 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkvbox.h |# + +(extern (* GtkWidget) + gtk_vbox_new + (homogeneous gboolean) + (spacing gint)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl new file mode 100644 index 000000000..cf9918af9 --- /dev/null +++ b/src/gtk/Includes/gtkwidget.cdecl @@ -0,0 +1,356 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkwidget.h |# + +;(include "gdk") +;(include "gtkaccelgroup") +;(include "gtkobject") +;(include "gtkadjustment") +;(include "gtkstyle") +;(include "gtksettings") +;(include "atkobject") + +(typedef GtkWidgetFlags + (enum + (GTK_TOPLEVEL) + (GTK_NO_WINDOW) + (GTK_REALIZED) + (GTK_MAPPED) + + (GTK_VISIBLE) + (GTK_SENSITIVE) + (GTK_PARENT_SENSITIVE) + (GTK_CAN_FOCUS) + + (GTK_HAS_FOCUS) + (GTK_CAN_DEFAULT) + (GTK_HAS_DEFAULT) + (GTK_HAS_GRAB) + + (GTK_RC_STYLE) + (GTK_COMPOSITE_CHILD) + (GTK_NO_REPARENT) + (GTK_APP_PAINTABLE) + (GTK_RECEIVES_DEFAULT) + (GTK_DOUBLE_BUFFERED) + (GTK_NO_SHOW_ALL))) + +(typedef GtkWidgetHelpType + (enum + (GTK_WIDGET_HELP_TOOLTIP) + (GTK_WIDGET_HELP_WHATS_THIS))) + +(typedef GtkRequisition (struct _GtkRequisition)) +(typedef GtkAllocation GdkRectangle) +;(typedef GtkSelectionData (struct _GtkSelectionData)) +(typedef GtkWidgetClass (struct _GtkWidgetClass)) +(typedef GtkWidgetAuxInfo (struct _GtkWidgetAuxInfo)) +(typedef GtkWidgetShapeInfo (struct _GtkWidgetShapeInfo)) +;(typedef GtkClipboard (struct _GtkClipboard)) +(typedef GtkCallback + (* (function void (widget (* GtkWidget)) (data gpointer)))) + +(struct _GtkRequisition + (width gint) + (height gint)) + +(struct _GtkWidget + (object GtkObject) + (private_flags guint16) + (state guint8) + (saved_state guint8) + (name (* gchar)) + (style (* GtkStyle)) + (requisition GtkRequisition) + (allocation GtkAllocation) + (window (* GdkWindow)) + (parent (* GtkWidget))) + +(struct _GtkWidgetClass + (parent_class GtkObjectClass) + (activate_signal guint) + (set_scroll_adjustments_signal guint) + (dispatch_child_properties_changed + (* (function void + (widget (* GtkWidget)) + (n_pspecs guint) + (pspecs (* (* GParamSpec)))))) + (show (* (function void (widget (* GtkWidget))))) + (show_all (* (function void (widget (* GtkWidget))))) + (hide (* (function void (widget (* GtkWidget))))) + (hide_all (* (function void (widget (* GtkWidget))))) + (map (* (function void (widget (* GtkWidget))))) + (unmap (* (function void (widget (* GtkWidget))))) + (realize (* (function void (widget (* GtkWidget))))) + (unrealize (* (function void (widget (* GtkWidget))))) + (size_request + (* (function void + (widget (* GtkWidget)) + (requisition (* GtkRequisition))))) + (size_allocate + (* (function void + (widget (* GtkWidget)) (allocation (* GtkAllocation))))) + (state_changed + (* (function void + (widget (* GtkWidget)) (previous_state GtkStateType)))) + (parent_set + (* (function void + (widget (* GtkWidget)) (previous_parent (* GtkWidget))))) + (hierarchy_changed + (* (function void + (widget (* GtkWidget)) + (previous_toplevel (* GtkWidget))))) + (style_set + (* (function void + (widget (* GtkWidget)) (previous_style (* GtkStyle))))) + (direction_changed + (* (function void + (widget (* GtkWidget)) + (previous_direction GtkTextDirection)))) + (grab_notify + (* (function void + (widget (* GtkWidget)) (was_grabbed gboolean)))) + (child_notify + (* (function void + (widget (* GtkWidget)) (pspec (* GParamSpec))))) + (mnemonic_activate + (* (function gboolean + (widget (* GtkWidget)) (group_cycling gboolean)))) + (grab_focus (* (function void (widget (* GtkWidget))))) + (focus (* (function gboolean + (widget (* GtkWidget)) + (direction GtkDirectionType)))) + (event (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEvent))))) + (button_press_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventButton))))) + (button_release_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventButton))))) + (scroll_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventScroll))))) + (motion_notify_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventMotion))))) + (delete_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventAny))))) + (destroy_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventAny))))) + (expose_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventExpose))))) + (key_press_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventKey))))) + (key_release_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventKey))))) + (enter_notify_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventCrossing))))) + (leave_notify_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventCrossing))))) + (configure_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventConfigure))))) + (focus_in_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventFocus))))) + (focus_out_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventFocus))))) + (map_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventAny))))) + (unmap_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventAny))))) + (property_notify_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventProperty))))) + (selection_clear_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventSelection))))) + (selection_request_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventSelection))))) + (selection_notify_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventSelection))))) + (proximity_in_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventProximity))))) + (proximity_out_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventProximity))))) + (visibility_notify_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventVisibility))))) + (client_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventClient))))) + (no_expose_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventAny))))) + (window_state_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventWindowState))))) + (selection_get + (* (function void + (widget (* GtkWidget)) + (selection_data (* GtkSelectionData)) + (info guint) + (time_ guint)))) + (selection_received + (* (function void + (widget (* GtkWidget)) + (selection_data (* GtkSelectionData)) + (time_ guint)))) + (drag_begin + (* (function void + (widget (* GtkWidget)) (context (* GdkDragContext))))) + (drag_end + (* (function void + (widget (* GtkWidget)) (context (* GdkDragContext))))) + (drag_data_get + (* (function void + (widget (* GtkWidget)) (context (* GdkDragContext)) + (selection_data (* GtkSelectionData)) + (info guint) + (time_ guint)))) + (drag_data_delete + (* (function void + (widget (* GtkWidget)) (context (* GdkDragContext))))) + (drag_leave + (* (function void + (widget (* GtkWidget)) (context (* GdkDragContext)) + (time_ guint)))) + (drag_motion + (* (function gboolean + (widget (* GtkWidget)) (context (* GdkDragContext)) + (x gint) (y gint) (time_ guint)))) + (drag_drop + (* (function gboolean + (widget (* GtkWidget)) (context (* GdkDragContext)) + (x gint) (y gint) (time_ guint)))) + (drag_data_received + (* (function void + (widget (* GtkWidget)) (context (* GdkDragContext)) + (x gint) (y gint) + (selection_data (* GtkSelectionData)) + (info guint) (time_ guint)))) + (popup_menu + (* (function gboolean + (widget (* GtkWidget))))) + (show_help + (* (function gboolean + (widget (* GtkWidget)) (help_type GtkWidgetHelpType)))) + (get_accessible + (* (function (* AtkObject) + (widget (* GtkWidget))))) + (screen_changed + (* (function void + (widget (* GtkWidget)) (previous_screen (* GdkScreen))))) + (can_activate_accel + (* (function gboolean + (widget (* GtkWidget)) (signal_id guint)))) + (grab_broken_event + (* (function gboolean + (widget (* GtkWidget)) (event (* GdkEventGrabBroken))))) + (composited_changed + (* (function void (widget (* GtkWidget))))) + (query_tooltip + (* (function gboolean + (widget (* GtkWidget)) (x gint) (y gint) + (keyboard_tooltip gboolean) + (tooltip (* GtkTooltip))))) + (_gtk_reserved5 (* (function void))) + (_gtk_reserved6 (* (function void))) + (_gtk_reserved7 (* (function void)))) + +(struct _GtkWidgetAuxInfo + (x gint) + (y gint) + (width gint) + (height gint) + ;;(_skip guint) + ) + +(struct _GtkWidgetShapeInfo + (offset_x gint16) + (offset_y gint16) + (shape_mask (* GdkBitmap))) + +(extern void gtk_widget_destroy + (widget (* GtkWidget))) + +(extern void gtk_widget_show_all + (widget (* GtkWidget))) + +(extern void gtk_widget_queue_draw_area + (widget (* GtkWidget)) + (x gint) + (y gint) + (width gint) + (height gint)) + +(extern (* GdkWindow) gtk_widget_get_parent_window + (widget (* GtkWidget))) + +(extern (* GdkColormap) gtk_widget_get_colormap + (widget (* GtkWidget))) +(extern (* GdkVisual) gtk_widget_get_visual + (widget (* GtkWidget))) + +(extern gint gtk_widget_get_events + (widget (* GtkWidget))) + +;;; Widget styles. + +(extern void gtk_widget_ensure_style + (widget (* GtkWidget))) + +(extern void gtk_widget_modify_style + (widget (* GtkWidget)) + (style (* GtkRcStyle))) + +(extern (* GtkRcStyle) + gtk_widget_get_modifier_style + (widget (* GtkWidget))) + +(extern void gtk_widget_modify_fg + (widget (* GtkWidget)) + (state GtkStateType) + (color (* (const GdkColor)))) + +(extern void gtk_widget_modify_bg + (widget (* GtkWidget)) + (state GtkStateType) + (color (* (const GdkColor)))) + +(extern void gtk_widget_modify_text + (widget (* GtkWidget)) + (state GtkStateType) + (color (* (const GdkColor)))) + +(extern void gtk_widget_modify_base + (widget (* GtkWidget)) + (state GtkStateType) + (color (* (const GdkColor)))) + +(extern void gtk_widget_modify_font + (widget (* GtkWidget)) + (font_desc (* PangoFontDescription))) + +(extern (* PangoContext) + gtk_widget_get_pango_context (widget (* GtkWidget))) + +(extern (* PangoLayout) + gtk_widget_create_pango_layout + (widget (* GtkWidget)) + (text (const (* gchar)))) \ No newline at end of file diff --git a/src/gtk/Includes/gtype.cdecl b/src/gtk/Includes/gtype.cdecl new file mode 100644 index 000000000..4c953e18a --- /dev/null +++ b/src/gtk/Includes/gtype.cdecl @@ -0,0 +1,76 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gtype.h |# + +(include "glib") + +(enum GFundamentalType + (G_TYPE_INVALID) + (G_TYPE_NONE) + (G_TYPE_INTERFACE) + (G_TYPE_CHAR) + (G_TYPE_UCHAR) + (G_TYPE_BOOLEAN) + (G_TYPE_INT) + (G_TYPE_UINT) + (G_TYPE_LONG) + (G_TYPE_ULONG) + (G_TYPE_INT64) + (G_TYPE_UINT64) + (G_TYPE_ENUM) + (G_TYPE_FLAGS) + (G_TYPE_FLOAT) + (G_TYPE_DOUBLE) + (G_TYPE_STRING) + (G_TYPE_POINTER) + (G_TYPE_BOXED) + (G_TYPE_PARAM) + (G_TYPE_OBJECT)) + +(typedef GType guint) + +(typedef GValue (struct _GValue)) +;(typedef GTypeCValue (union _GTypeCValue)) +;(typedef GTypePlugin (struct _GTypePlugin)) +(typedef GTypeClass (struct _GTypeClass)) +(typedef GTypeInterface (struct _GTypeInterface)) +(typedef GTypeInstance (struct _GTypeInstance)) +;(typedef GTypeInfo (struct _GTypeInfo)) +;(typedef GTypeFundamentalInfo (struct _GTypeFundamentalInfo)) +;(typedef GInterfaceInfo (struct _GInterfaceInfo)) +;(typedef GTypeValueTable (struct _GTypeValueTable)) +(typedef GTypeQuery (struct _GTypeQuery)) + +(struct _GTypeClass + ;; < private > + (g_type GType)) + +(struct _GTypeInstance + ;; < private > + (g_class (* GTypeClass))) + +(struct _GTypeInterface + ;; < private > + (g_type GType) + (g_instance_type GType)) + +(struct _GTypeQuery + (type GType) + (type_name (const (* gchar))) + (class_size guint) + (instance_size guint)) + +(typedef GTypeDebugFlags + (enum + (G_TYPE_DEBUG_NONE) + (G_TYPE_DEBUG_OBJECTS) + (G_TYPE_DEBUG_SIGNALS) + (G_TYPE_DEBUG_MASK))) + +(extern GType + G_TYPE_FUNDAMENTAL + (type_id GType)) + +(extern (const (* gchar)) + G_OBJECT_CLASS_NAME + (class (* GObjectClass))) \ No newline at end of file diff --git a/src/gtk/Includes/gtypes.cdecl b/src/gtk/Includes/gtypes.cdecl new file mode 100644 index 000000000..82c82454f --- /dev/null +++ b/src/gtk/Includes/gtypes.cdecl @@ -0,0 +1,59 @@ +#| -*-Scheme-*- + +glib-2.0/glib/gtypes.h |# + +;(include "glibconfig") +(typedef gint8 char) +(typedef gint16 short) +(typedef gint32 int) +(typedef gint64 long) +(typedef guint8 uchar) +(typedef guint16 ushort) +(typedef guint32 uint) +;(typedef guint64 ulonglong) +(typedef gssize int) +(typedef gsize uint) + +(typedef gchar char) +(typedef gshort short) +(typedef glong long) +(typedef gint int) +(typedef gboolean gint) + +(typedef guchar uchar) +(typedef gushort ushort) +(typedef gulong ulong) +(typedef guint uint) + +(typedef gfloat float) +(typedef gdouble double) + +(typedef gpointer (* void)) +(typedef gconstpointer (const (* void))) + +#| + +typedef gint (*GCompareFunc) (gconstpointer a, + gconstpointer b); +typedef gint (*GCompareDataFunc) (gconstpointer a, + gconstpointer b, + gpointer user_data); +typedef gboolean (*GEqualFunc) (gconstpointer a, + gconstpointer b); +typedef void (*GDestroyNotify) (gpointer data); +typedef void (*GFunc) (gpointer data, + gpointer user_data); +typedef guint (*GHashFunc) (gconstpointer key); +typedef void (*GHFunc) (gpointer key, + gpointer value, + gpointer user_data); +typedef void (*GFreeFunc) (gpointer data); +typedef const gchar * (*GTranslateFunc) (const gchar *str, + gpointer data); +|# + +(typedef GTimeVal (struct _GTimeVal)) + +(struct _GTimeVal + (tv_sec glong) + (tv_usec glong)) \ No newline at end of file diff --git a/src/gtk/Includes/gvalue.cdecl b/src/gtk/Includes/gvalue.cdecl new file mode 100644 index 000000000..de10e25ba --- /dev/null +++ b/src/gtk/Includes/gvalue.cdecl @@ -0,0 +1,32 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gvalue.h |# + +(struct _GValue + (g_type GType) + (data (array + (union + (v_int gint) + (v_uint guint) + (v_long glong) + (v_ulong gulong) +; (v_int64 gint64) +; (v_uint64 guint64) + (v_float gfloat) + (v_double gdouble) + (v_pointer gpointer)) + 2))) + +(extern (* GValue) + g_value_init + (value (* GValue)) + (g_type GType)) + +(extern (* GValue) + g_value_reset + (value (* GValue))) + +(extern gboolean + g_value_type_compatible + (src_type GType) + (dest_type GType)) \ No newline at end of file diff --git a/src/gtk/Includes/gvaluetypes.cdecl b/src/gtk/Includes/gvaluetypes.cdecl new file mode 100644 index 000000000..b23e15e87 --- /dev/null +++ b/src/gtk/Includes/gvaluetypes.cdecl @@ -0,0 +1,76 @@ +#| -*-Scheme-*- + +glib-2.0/gobject/gvaluetypes.h |# + +;(include "gvalue") + +(extern void g_value_set_char + (value (* GValue)) + (v_char gchar)) +(extern gchar g_value_get_char + (value (const (* GValue)))) +(extern void g_value_set_uchar + (value (* GValue)) + (v_uchar guchar)) +(extern guchar g_value_get_uchar + (value (const (* GValue)))) +(extern void g_value_set_boolean + (value (* GValue)) + (v_boolean gboolean)) +(extern gboolean g_value_get_boolean + (value (const (* GValue)))) +(extern void g_value_set_int + (value (* GValue)) + (v_int gint)) +(extern gint g_value_get_int + (value (const (* GValue)))) +(extern void g_value_set_uint + (value (* GValue)) + (v_uint guint)) +(extern guint g_value_get_uint + (value (const (* GValue)))) +(extern void g_value_set_long + (value (* GValue)) + (v_long glong)) +(extern glong g_value_get_long + (value (const (* GValue)))) +(extern void g_value_set_ulong + (value (* GValue)) + (v_ulong gulong)) +(extern gulong g_value_get_ulong + (value (const (* GValue)))) +;(extern void g_value_set_int64 +; (value (* GValue)) +; (v_int64 gint64)) +;(extern gint64 g_value_get_int64 +; (value (const (* GValue)))) +;(extern void g_value_set_uint64 +; (value (* GValue)) +; (v_uint64 guint64)) +;(extern guint64 g_value_get_uint64 +; (value (const (* GValue)))) +(extern void g_value_set_float + (value (* GValue)) + (v_float gfloat)) +(extern gfloat g_value_get_float + (value (const (* GValue)))) +(extern void g_value_set_double + (value (* GValue)) + (v_double gdouble)) +(extern gdouble g_value_get_double + (value (const (* GValue)))) +(extern void g_value_set_string + (value (* GValue)) + (v_string (const (* gchar)))) +;(extern void g_value_set_static_string +; (value (* GValue)) +; (v_string (const (* gchar)))) +(extern (const (* gchar)) g_value_get_string + (value (const (* GValue)))) +;(extern (* gchar) g_value_dup_string +; (value (const (* GValue)))) +(extern void g_value_set_pointer + (value (* GValue)) + (v_pointer gpointer)) +(extern gpointer g_value_get_pointer + (value (const (* GValue)))) \ No newline at end of file diff --git a/src/gtk/Includes/pango-context.cdecl b/src/gtk/Includes/pango-context.cdecl new file mode 100644 index 000000000..d9614cc9b --- /dev/null +++ b/src/gtk/Includes/pango-context.cdecl @@ -0,0 +1,85 @@ +#| -*-Scheme-*- + +pango-1.0/pango/pango-context.h |# + +(include "pango-font") +;(include "pango-fontmap") +;(include "pango-attributes") + +;(extern (* PangoFontMap) +; pango_context_get_font_map +; (context (* PangoContext))) + +(extern void + pango_context_list_families + (context (* PangoContext)) + (families (* (* (* PangoFontFamily)))) + (n_families (* int))) + +;(extern (* PangoFont) +; pango_context_load_font +; (context (* PangoContext)) +; (desc (const (* PangoFontDescription)))) + +;(extern (* PangoFontset) +; pango_context_load_fontset +; (context (* PangoContext)) +; (desc (const (* PangoFontDescription))) +; (language (* PangoLanguage))) + +(extern (* PangoFontMetrics) + pango_context_get_metrics + (context (* PangoContext)) + (desc (const (* PangoFontDescription))) + (language (* PangoLanguage))) + +;(extern void +; pango_context_set_font_description +; (context (* PangoContext)) +; (desc (const (* PangoFontDescription)))) + +(extern (* PangoLanguage) + pango_context_get_language + (context (* PangoContext))) + +;(extern void +; pango_context_set_language +; (context (* PangoContext)) +; (language (* PangoLanguage))) + +;(extern void +; pango_context_set_base_dir +; (context (* PangoContext)) +; (direction PangoDirection)) + +;(extern PangoDirection +; pango_context_get_base_dir +; (context (* PangoContext))) + +;(extern void +; pango_context_set_matrix +; (context (* PangoContext)) +; (matrix (const (* PangoMatrix)))) + +;(extern (const (* PangoMatrix)) +; pango_context_get_matrix +; (context (* PangoContext))) + +;(extern (* GList) +; pango_itemize +; (context (* PangoContext)) +; (text (const (* char))) +; (start_index int) +; (length int) +; (attrs (* PangoAttrList)) +; (cached_iter (* PangoAttrIterator))) + +;(extern (* GList) +; pango_itemize_with_base_dir +; (context (* PangoContext)) +; (base_dir PangoDirection) +; (text (const (* char))) +; (start_index int) +; (length int) +; (attrs (* PangoAttrList)) +; (cached_iter (* PangoAttrIterator))) \ No newline at end of file diff --git a/src/gtk/Includes/pango-font.cdecl b/src/gtk/Includes/pango-font.cdecl new file mode 100644 index 000000000..0bf1bf4dc --- /dev/null +++ b/src/gtk/Includes/pango-font.cdecl @@ -0,0 +1,95 @@ +#| -*-Scheme-*- + +pango-1.0/pango/pango-font.h |# + +;(include "pango-coverage") +;(include "pango-types") + +;(include "glib-object") + +;(typedef PangoFontDescription (struct _PangoFontDescription)) +;(typedef PangoFontMetrics (struct _PangoFontMetrics)) + +;(typedef PangoStyle +; (enum +; (PANGO_STYLE_NORMAL) ;the font is upright. +; (PANGO_STYLE_OBLIQUE) ;the font is slanted, but roman. +; (PANGO_STYLE_ITALIC))) ;the font is slanted in italic style + +;(typedef PangoVariant +; (enum +; (PANGO_VARIANT_NORMAL) +; (PANGO_VARIANT_SMALL_CAPS))) + +;(typedef PangoWeight +; (enum +; (PANGO_WEIGHT_ULTRALIGHT) +; (PANGO_WEIGHT_LIGHT) +; (PANGO_WEIGHT_NORMAL) +; (PANGO_WEIGHT_SEMIBOLD) +; (PANGO_WEIGHT_BOLD) +; (PANGO_WEIGHT_ULTRABOLD) +; (PANGO_WEIGHT_HEAVY))) + +;(typedef PangoStretch +; (enum +; (PANGO_STRETCH_ULTRA_CONDENSED) +; (PANGO_STRETCH_EXTRA_CONDENSED) +; (PANGO_STRETCH_CONDENSED) +; (PANGO_STRETCH_SEMI_CONDENSED) +; (PANGO_STRETCH_NORMAL) +; (PANGO_STRETCH_SEMI_EXPANDED) +; (PANGO_STRETCH_EXPANDED) +; (PANGO_STRETCH_EXTRA_EXPANDED) +; (PANGO_STRETCH_ULTRA_EXPANDED))) + +;(typedef PangoFontMask +; (enum +; (PANGO_FONT_MASK_FAMILY) +; (PANGO_FONT_MASK_STYLE) +; (PANGO_FONT_MASK_VARIANT) +; (PANGO_FONT_MASK_WEIGHT) +; (PANGO_FONT_MASK_STRETCH) +; (PANGO_FONT_MASK_SIZE))) + +;; CSS scale factors (1.2 factor between each size) */ +;(define PANGO_SCALE_XX_SMALL 0.5787037037037) +;(define PANGO_SCALE_X_SMALL 0.6444444444444) +;(define PANGO_SCALE_SMALL 0.8333333333333) +;(define PANGO_SCALE_MEDIUM 1.0) +;(define PANGO_SCALE_LARGE 1.2) +;(define PANGO_SCALE_X_LARGE 1.4399999999999) +;(define PANGO_SCALE_XX_LARGE 1.728) + +(extern void pango_font_description_free (desc (* PangoFontDescription))) + +(extern (* PangoFontDescription) + pango_font_description_from_string + (str (* (const char)))) + +(extern void pango_font_metrics_unref (metrics (* PangoFontMetrics))) +(extern int pango_font_metrics_get_ascent (metrics (* PangoFontMetrics))) +(extern int pango_font_metrics_get_descent (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_approximate_char_width (metrics (* PangoFontMetrics))) +(extern int pango_font_metrics_get_approximate_digit_width (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_underline_position (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_unerline_thickness (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_strikethrough_position (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_strikethrough_thickness (metrics (* PangoFontMetrics))) + +(extern void pango_font_family_list_faces + (family (* PangoFontFamily)) + (faces (* (* (* PangoFontFace)))) + (n_faces (* int))) + +(extern (const (* char)) + pango_font_family_get_name + (family (* PangoFontFamily))) + +(extern gboolean + pango_font_family_is_monospace + (family (* PangoFontFamily))) + +(extern (const (* char)) + pango_font_face_get_face_name + (face (* PangoFontFace))) \ No newline at end of file diff --git a/src/gtk/Includes/pango-layout.cdecl b/src/gtk/Includes/pango-layout.cdecl new file mode 100644 index 000000000..6f27065eb --- /dev/null +++ b/src/gtk/Includes/pango-layout.cdecl @@ -0,0 +1,40 @@ +#| -*-Scheme-*- + +pango-1.0/pango/pango-layout.h |# + +;(include "pango-attributes") +(include "pango-context") +;(include "pango-glyph-item") +;(include "pango-tabs") + +(extern void pango_layout_get_extents + (layout (* PangoLayout)) + (ink_rect (* PangoRectangle)) + (logical_rect (* PangoRectangle))) +(extern void pango_layout_get_pixel_extents + (layout (* PangoLayout)) + (ink_rect (* PangoRectangle)) + (logical_rect (* PangoRectangle))) +(extern void pango_layout_set_text + (layout (* PangoLayout)) + (text (const (* char))) + (length int)) +(extern void pango_layout_set_font_description + (layout (* PangoLayout)) + (desc (const (* PangoFontDescription)))) +(extern void pango_layout_index_to_pos + (layout (* PangoLayout)) + (index int) + (pos (* PangoRectangle))) +(extern void pango_layout_xy_to_index + (layout (* PangoLayout)) + (x int) (y int) + (index (* int)) + (trailing (* int))) +(extern (* PangoLayoutIter) + pango_layout_get_iter + (layout (* PangoLayout))) +(extern void pango_layout_iter_free + (iter (* PangoLayoutIter))) +(extern int pango_layout_iter_get_baseline + (iter (* PangoLayoutIter))) diff --git a/src/gtk/Includes/pango-types.cdecl b/src/gtk/Includes/pango-types.cdecl new file mode 100644 index 000000000..0aadc4350 --- /dev/null +++ b/src/gtk/Includes/pango-types.cdecl @@ -0,0 +1,14 @@ +#| -*-Scheme-*- + +pango-1.0/pango/pango-types.h |# + +(include "glib") +;(include "glib-object") + +(typedef PangoRectangle + (struct _PangoRectangle)) +(struct _PangoRectangle + (x int) + (y int) + (width int) + (height int)) \ No newline at end of file diff --git a/src/gtk/Includes/pango.cdecl b/src/gtk/Includes/pango.cdecl new file mode 100644 index 000000000..8444eb442 --- /dev/null +++ b/src/gtk/Includes/pango.cdecl @@ -0,0 +1,25 @@ +#| -*-Scheme-*- + +pango-1.0/pango/pango.h |# + +;(include "pango-attributes") +;(include "pango-break") +(include "pango-context") +;(include "pango-coverage") +;(include "pango-engine") +;(include "pango-enum-types") +;(include "pango-features") +(include "pango-font") +;(include "pango-fontmap") +;(include "pango-fontset") +;(include "pango-glyph") +;(include "pango-glyph-item") +;(include "pango-gravity") +;(include "pango-item") +(include "pango-layout") +;(include "pango-matrix") +;(include "pango-renderer") +;(include "pango-script") +;(include "pango-tabs") +(include "pango-types") +;(include "pango-utils") \ No newline at end of file diff --git a/src/gtk/Includes/pangocairo.cdecl b/src/gtk/Includes/pangocairo.cdecl new file mode 100644 index 000000000..ae7635401 --- /dev/null +++ b/src/gtk/Includes/pangocairo.cdecl @@ -0,0 +1,15 @@ +#| -*-Scheme-*- + +pango-1.0/pango/pangocairo.h |# + +(include "pango-context") +;(include "pango-fontmap") +(include "pango-layout") +(include "cairo") + +;(typedef PangoCairoFont (struct _PangoCairoFont)) +;(typedef PangoCairoFontMap (struct _PangoCairoFontMap)) + +(extern (* PangoLayout) pango_cairo_create_layout (cr (* cairo_t))) +(extern void pango_cairo_update_layout (cr (* cairo_t))(layout (* PangoLayout))) +(extern void pango_cairo_show_layout (cd (* cairo_t))(layout (* PangoLayout))) diff --git a/src/gtk/Makefile-fragment b/src/gtk/Makefile-fragment new file mode 100644 index 000000000..74feb9bde --- /dev/null +++ b/src/gtk/Makefile-fragment @@ -0,0 +1,68 @@ +#-*-Makefile-*- +# $Id: $ +# gtk/Makefile-fragment + +TARGET_DIR = $(AUXDIR)/gtk + +generate: ../lib/lib/gtk-shim.so ../lib/lib/gtk-types.bin \ + ../lib/lib/gtk-const.bin ../lib/conses.png + +../lib/lib/gtk-shim.so: gtk-shim.so + $(INSTALL_DATA) gtk-shim.so $@ + +../lib/lib/gtk-types.bin: gtk-types.bin + $(INSTALL_DATA) gtk-types.bin $@ + +../lib/lib/gtk-const.bin: gtk-const.bin + $(INSTALL_DATA) gtk-const.bin $@ + +../lib/conses.png: conses.png + $(INSTALL_DATA) conses.png $@ + +conses.png: conses.png.uu + uudecode conses.png.uu + +build: + echo '(load "compile")' \ + | ../microcode/scheme --compiler --library ../lib --batch-mode + +install: + rm -rf $(DESTDIR)$(TARGET_DIR) + $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR) + $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) gtk-*.pkd $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) load.scm $(DESTDIR)$(TARGET_DIR)/. + $(INSTALL_DATA) gtk-shim.so $(DESTDIR)$(AUXDIR)/lib/. + $(INSTALL_DATA) gtk-types.bin $(DESTDIR)$(AUXDIR)/lib/. + $(INSTALL_DATA) gtk-const.bin $(DESTDIR)$(AUXDIR)/lib/. + +gtk-shim.so: gtk-shim.o scmwidget.o + $(LINK_SHIM) $^ `pkg-config --libs gtk+-2.0` + +scmwidget.o: scmwidget.c + $(COMPILE_SHIM) `pkg-config --cflags gtk+-2.0` -c scmwidget.c + +scmwidget.c: scmwidget.c.stay + cp -p scmwidget.c.stay scmwidget.c + +gtk-shim.o: gtk-shim.c gtk-shim.h ../lib/mit-scheme.h + $(COMPILE_SHIM) `pkg-config --cflags gtk+-2.0` -o $@ -c $< + +gtk-shim.c gtk-const.c gtk-types.bin: gtk.cdecl + (echo "(load-option 'FFI)"; \ + echo '(C-generate "gtk" "#include \"gtk-shim.h\"")') \ + | mit-scheme --batch-mode + +gtk-const.bin: gtk-const.scm + echo '(sf "gtk-const")' | mit-scheme --compiler --batch-mode + +gtk-const.scm: gtk-const + ./gtk-const + +gtk-const: gtk-const.o + @rm -f $@ + $(CCLD) $(CFLAGS) $(LDFLAGS) -o $@ $< `pkg-config --libs gtk+-2.0` + +gtk-const.o: gtk-const.c + $(CC) $(CFLAGS) `pkg-config --cflags gtk+-2.0` -o $@ -c $< diff --git a/src/gtk/Tags.sh b/src/gtk/Tags.sh new file mode 100644 index 000000000..09b8e6698 --- /dev/null +++ b/src/gtk/Tags.sh @@ -0,0 +1,9 @@ +#!/bin/sh +# +# $Id: Tags.sh,v 1.7 2008/01/30 20:02:08 cph Exp $ + +# Utility to make TAGS file for the gtk build directory. +# The working directory must be the build directory. + +etags gtk-shim.h scmwidget.c.stay --language=scheme \ + `echo *.scm | sed 's/ gtk-const.scm//'` Includes/*.cdecl diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm new file mode 100644 index 000000000..a1addd393 --- /dev/null +++ b/src/gtk/compile.scm @@ -0,0 +1,44 @@ +#| -*-Scheme-*- + +$Id: $ + +Compile the GTK system. |# + +(load-option 'CREF) +(load-option 'SOS) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (let ((gtk-files '("gtk" "main" "gobject" "gtk-object" + "scm-widget" "scm-layout" + "gtk-ev" "demo"))) + + ;; Build an empty package for use at syntax-time. + ;; The C-include syntax will bind C-INCLUDES here. + (if (not (name->package '(GTK))) + (let ((package-set (package-set-pathname "gtk"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "gtk")) + (construct-packages-from-file (fasload package-set)))) + + ;; Load the gtkio primitives too. + (load-library-object-file "prgtkio" #t) + + ;; Syntax in (gtk). + (fluid-let ((sf/default-syntax-table (->environment '(gtk))) + (sf/default-declarations + (cons '(usual-integrations) sf/default-declarations))) + (for-each (lambda (f) (sf-conditionally f #t)) gtk-files)) + + ;; Syntax in (runtime thread). + (fluid-let ((sf/default-syntax-table (->environment '(gtk thread))) + (sf/default-declarations + (cons '(usual-integrations) sf/default-declarations))) + (sf-conditionally "thread" #t)) + + ;; Cross-check. + (cref/generate-constructors "gtk" 'ALL) + + ;; Compile. + (for-each compile-file (cons "thread" gtk-files)) + ))) \ No newline at end of file diff --git a/src/gtk/conses.png.uu b/src/gtk/conses.png.uu new file mode 100644 index 000000000..37d7a3879 --- /dev/null +++ b/src/gtk/conses.png.uu @@ -0,0 +1,11 @@ +begin-base64 660 conses.png +iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABmJLR0QA/wD/ +AP+gvaeTAAAACXBIWXMAAABIAAAASABGyWs+AAABEklEQVRYw+2X4Q6DMAiE +ucX3f+Xbj9laW6ilNLolIzFxWr4iwslAkjJpACAiEmKQ5M5xWb3nLGOzgAlq +Xd9PRIr79lotQR/GazZ1xQ4h9zYACwjkg/W62scR1HgGyHwg/S7vLcuA1wKb +iyhdQEnlcbWv3QUeBtiSXE8FIMQ4hEQrHDKLzahl1qDvq/BsNr/DtlP6SE1c +zEi82VED2EE1+dIxIP9tABYQgFCRUQzV+JjFdWB5APHX+usZuNlyEaZOoJy7 +YmXBmQGcOsAYQq5M04t0racXy6R4lrFWiicYsS+ZNRV7GF8zFasRu6diFdEb +ip+firfhldXI1Z2KHfafio9XYKSxW91K9+kQG4Gn/x0/bm8fAcEjKw488QAA +AABJRU5ErkJggg== +==== diff --git a/src/gtk/demo.scm b/src/gtk/demo.scm new file mode 100644 index 000000000..9476c3944 --- /dev/null +++ b/src/gtk/demo.scm @@ -0,0 +1,214 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; A small drawing in two scm-layout widgets. +;;; package: (gtk demo) + + +(c-include "gtk") + +(define (scm-layout-demo) + (let* ((window (gtk-window-new 'toplevel)) + (vbox (gtk-vbox-new #t 0)) + (scroller1 (gtk-scrolled-window-new)) + (scroller2 (gtk-scrolled-window-new)) + (layout1 (scm-layout-new 200 200)) + (layout2 (scm-layout-new 200 200))) + (gtk-window-set-title window "scm-layout-demo") + (gtk-window-set-default-size window 200 400) + (gtk-container-set-border-width window 10) + (gtk-container-add scroller1 layout1) + (gtk-container-add vbox scroller1) + (gtk-container-add scroller2 layout2) + (gtk-container-add vbox scroller2) + (gtk-container-add window vbox) + (gtk-widget-show-all window) + (g-signal-connect window (C-callback "delete_event") + (lambda (w e) + w e ;;Ignored. + (outf-console "; Closed "window".\n") + 0)) + (let ((drawing (demo-drawing layout1))) + (set-scm-layout-drawing! layout1 drawing) + (set-scm-layout-scroll-pos! layout1 175 150) + (set-scm-widget-event! + layout1 (demo-event layout1 (scm-layout-event layout1))) + (set-scm-layout-drawing! layout2 drawing) + (set-scm-layout-scroll-pos! layout2 175 150) + (set-scm-widget-event! + layout2 (demo-event layout2 (scm-layout-event layout2))) + (let ((cursor1 (add-box-item drawing 'BOTTOM)) + (cursor2 (add-box-item drawing 'BOTTOM))) + (set-demo-drawing-cursor-items! + drawing (list (list cursor1 layout1) (list cursor2 layout2))) + (let ((thread (start-blinking drawing))) + (outf-console "; Cursor blinking courtesy of "thread".\n")))) + (outf-console "; Created "layout1" and "layout2"\n")) + unspecific) + +(define (demo-drawing device) + ;; DEVICE can (must, at the moment) be a scm-layout. + (let ((drawing (make-demo-drawing device))) + (set-drawing-size! drawing 500 500) + (let ((hline (add-hline-item drawing #f)) + (vline (add-vline-item drawing #f)) + (text (add-text-item drawing #f)) + (box (add-box-item drawing #f)) + (image (add-image-item-from-file + drawing #f + (merge-pathnames + "conses.png" (system-library-directory-pathname ""))))) + (set-drawn-item-position! hline 240 250) + (set-hline-item-size! hline 50) + (set-drawn-item-position! vline 250 240) + (set-vline-item-size! vline 50) + (set-drawn-item-position! text 250 250) + (set-text-item-text! text "Hello, World!") + (set-drawn-item-position! box 220 220) + (set-box-item-size! box 20 20) + (set-box-item-shadow! box 'etched-in) + (set-drawn-item-position! image 270 200) + drawing))) + +(define-class ( (constructor () 1)) + () + ;; An alist of cursors and their widgets, for the blinking thread + ;; and mouse motion handler. + (cursor-items define standard initial-value '())) + +(define (demo-event widget old-handler) + (named-lambda (scm-layout-demo::event GtkWidget GdkEvent) + + (trace2 ";(scm-layout-demo::event "GtkWidget" "GdkEvent")\n") + (let ((type (C-> GdkEvent "GdkEvent any type"))) + (cond + ((fix:= type (C-enum "GDK_MOTION_NOTIFY")) + (let* ((drawing (scm-layout-drawing widget)) + ;; pointer coords + (xP (floor->exact (C-> GdkEvent "GdkEventMotion x"))) + (yP (floor->exact (C-> GdkEvent "GdkEventMotion y"))) + ;; scroll offset + (scroll (scm-layout-on-screen-area widget)) + (xO (rect-x scroll)) + (yO (rect-y scroll)) + ;; drawing coords + (x (int:+ xP xO)) + (y (int:+ yP yO))) + (trace2 "; Pointer moved to ("x","y") in "widget".\n") + (for-each + (lambda (item) + (if (not (text-item? item)) + (trace "; Picked: "item"\n") + (let ((index (text-item-xy-to-index item x y)) + (text-area (drawn-item-area item))) + (trace "; Picked: "index" in "(text-item-text item)"\n") + (call-with-text-item-grapheme-rect + item index + (lambda (xG yG widthG heightG) + (for-each + (lambda (cursor.widgets) + (if (memq widget (cdr cursor.widgets)) + (begin + (set-box-item-pos-size! + (car cursor.widgets) + (int:+ xG (rect-x text-area)) + (int:+ yG (rect-y text-area)) + widthG heightG) + ;; Keep the cursor on while tracking the mouse. + (set-drawn-item-widgets! + (car cursor.widgets) + (cdr cursor.widgets))))) + (demo-drawing-cursor-items drawing))))))) + (drawing-pick-list drawing widget x y))) + (C-call "gdk_window_get_pointer" #f + (C-> GdkEvent "GdkEventMotion window") + null-alien null-alien null-alien) + 1 ;;Handled. + ) + + ((fix:= type (C-enum "GDK_BUTTON_RELEASE")) + (let ((scroll (scm-layout-on-screen-area widget)) + (drawing (scm-layout-drawing widget)) + (xp (floor->exact (C-> GdkEvent "GdkEventButton x"))) + (yp (floor->exact (C-> GdkEvent "GdkEventButton y")))) + (let ((x (int:+ xp (rect-x scroll))) + (y (int:+ yp (rect-y scroll)))) + (outf-console "; Pointer release at ("x","y").\n") + (for-each + (lambda (item) + (if (not (text-item? item)) + (outf-console "; Picked: "item"\n") + (let ((index (text-item-xy-to-index item x y))) + (outf-console "; Picked: "item" (char "index")\n")))) + (drawing-pick-list drawing widget x y)))) + 1 ;;Handled. + ) + + ((and (= type (C-enum "GDK_KEY_PRESS")) + (= (C-> GdkEvent "GdkEvent key keyval") (C-enum "GDK_D"))) + (bkpt 'Test) + (old-handler GtkWidget GdkEvent)) + + (else + (old-handler GtkWidget GdkEvent)))))) + +(define (start-blinking drawing) + (create-thread + #f + (lambda () + (trace2 ";blinking start\n") + (let loop () + ;; Off! + (for-each (lambda (cursor.widgets) + (set-drawn-item-widgets! (car cursor.widgets) '())) + (demo-drawing-cursor-items drawing)) + (trace2 ";blinked off\n") + (sleep-current-thread 500) + ;; On! + (for-each (lambda (cursor.widgets) + (set-drawn-item-widgets! (car cursor.widgets) + (cdr cursor.widgets))) + (demo-drawing-cursor-items drawing)) + (trace2 ";blinked on\n") + (sleep-current-thread 500) + (if (there-exists? + (demo-drawing-cursor-items drawing) + (lambda (cursor.widgets) + (there-exists? (cdr cursor.widgets) + (lambda (W) (not (gtk-object-destroyed? W)))))) + (loop) + (trace2 ";blinking ended\n")))))) + + +(define trace? #f) +(define trace2? #f) + +(define-syntax trace + (syntax-rules () + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + +(define-syntax trace2 + (syntax-rules () + ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm new file mode 100644 index 000000000..71f711ede --- /dev/null +++ b/src/gtk/gobject.scm @@ -0,0 +1,584 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; GtkObjects +;;; package: (gtk gobject) + + +(c-include "gtk") + +(define-class () + + ;; The GObject alien. A null alien if the toolkit object has not + ;; been created (yet), or has been finalized. + (alien define accessor + initializer (lambda () (make-alien '|GObject|))) + + ;; A pair, shared with finalize thunk closures. The cdr of this + ;; pair is the alist associating signal names with Scheme callback + ;; IDs and toolkit handles. In this alist, a callback ID will be #f + ;; if the signal was disconnected. + (signals define standard + initializer (lambda () (list 'GOBJECT-SIGNALS)))) + +(define-integrable (gobject-finalized? object) + (alien-null? (gobject-alien object))) + +(define-method initialize-instance ((object )) + ;; Arrange for all gobject signal handlers to be de-registered if + ;; GCed. The object itself is g_object_unref'ed. + (add-gc-cleanup object + (gobject-finalize-thunk + (gobject-alien object) + (gobject-signals object)))) + +(define (gobject-finalize-thunk alien signals) + ;; Return a thunk closed over ALIEN and SIGNALS (but not the gobject). + (lambda () + (gobject-finalize! alien signals))) + +(define (gobject-finalize! alien signals) + ;; This is finalization from Scheme perspective, not necessarily the + ;; toolkit's. + + (if (not (alien-null? alien)) + (begin + (C-call "g_object_unref" alien) + (alien-null! alien))) + + (for-each (lambda (name.id.handle) + (let ((id.handle (cdr name.id.handle))) + ;; Hacking this ID.HANDLE pair atomically. + (without-interrupts + (lambda () + (let ((id (car id.handle))) + (if id + (begin + (de-register-c-callback id) + (set-car! id.handle #f) + (set-cdr! id.handle #f)))))))) + (cdr signals))) + +(define (gobject-unref object) + ;; Calls g_object_unref to release Scheme's reference to the toolkit + ;; object. May be called multiple times; g_object_unref will be + ;; called once (per wrapper object). + (without-interrupts + (lambda () + (gobject-finalize! (gobject-alien object) (gobject-signals object))))) + +(define (g-signal-connect object alien-function closure) + ;; Allocate a callback and connect it with g_signal_connect_... The + ;; signal name is assumed to be the same as ALIEN-FUNCTION's name, + ;; e.g. in + ;; + ;; (g-signal-connect window (C-callback "delete_event") method) + ;; + ;; the signal name is assumed to be "delete_event". + + (let* ((name (alien-function/name alien-function)) + (sym (string->symbol name)) + (alien (gobject-alien object)) + (signals (gobject-signals object)) + (sym.id.handle (or (assq sym (cdr signals)) + (let ((entry (cons* sym #f #f))) + (set-cdr! signals (cons entry (cdr signals))) + entry))) + (id.handle (cdr sym.id.handle))) + ;; Disconnect existing signal handler. + (g-signal-disconnect!? alien id.handle) + ;; Connect. + (without-interrupts + (lambda () + (let ((id (car id.handle))) + (if (not id) + (let ((newid (register-c-callback closure))) + (set-car! id.handle newid) + (set-cdr! id.handle + (C-call "g_signal_connect_data" + alien name + alien-function newid + null-alien 0))))))))) + +(define (g-signal-disconnect object name) + (let* ((str (if (string? name) name + (ferror "The signal name ("name") is not a string."))) + (sym (string->symbol str)) + (signals (gobject-signals object)) + (alien (gobject-alien object)) + (sym.id.handle (assq sym (cdr signals)))) + (if (not sym.id.handle) + (ferror "No signal "name" on "object" to disconnect.") + (if (not (g-signal-disconnect!? alien (cdr sym.id.handle))) + (fwarn "Signal "name" already disconnected from "object"."))))) + +(define (g-signal-disconnect!? alien id.handle) + ;; Don't even THINK about recovering pairs from the signal list. + (without-interrupts + (lambda () + (let ((id (car id.handle))) + (and id + (begin + (C-call "g_signal_handler_disconnect" alien (cdr id.handle)) + (set-cdr! id.handle #f) + (de-register-c-callback (car id.handle)) + (set-car! id.handle #f) + #t)))))) + + +;;; GC Cleanups + +;;; Intended for any object needing a cleanup after it is GCed (any +;;; GObject?). Like the code in FFI/malloc.scm but does not need to +;;; make copies (and keep the copies consistent). These cleanup +;;; thunks can share an object's aliens at least -- something not +;;; possible for malloc! The shared structures (aliens) do not +;;; reference the object, and can be held strongly. + +;;; Note that a cleanup thunk cannot refer to its object. It should +;;; not even close over a variable referring to the object. It +;;; probably should not refer to any other object hoping for a +;;; cleanup. + +;;; A cleanup thunk may be called multiple times, so it might +;;; check first for a nulled alien before freeing a resource, and null +;;; that alien without interrupts after the resource is freed. + +(define gc-cleanups '()) + +(define (initialize-gc-cleanups!) + (set! gc-cleanups '()) + (add-gc-daemon! run-gc-cleanups)) + +(define (run-gc-cleanups) + (let loop ((alist gc-cleanups) + (prev #f)) + (if (pair? alist) + (if (weak-pair/car? (car alist)) + (loop (cdr alist) alist) + (let ((thunk (weak-cdr (car alist))) + (next (cdr alist))) + (thunk) + (if prev + (set-cdr! prev next) + (set! gc-cleanups next)) + (loop next prev)))))) + +(define (reset-gc-cleanups!) + (set! gc-cleanups '())) + +(define (add-gc-cleanup object cleanup-thunk) + (without-interrupts + (lambda () + (set! gc-cleanups + (cons (weak-cons object cleanup-thunk) gc-cleanups))))) + + +;;; Properties + +(define (gobject-get-property gobject property) + + (let ((object (check-gobject gobject)) + (name (check-prop-name property)) + (gvalue (malloc (C-sizeof "GValue") '|GValue|))) + + (define (unimplemented type) + (ferror "Property "name" (for "object") is "type" (unimplemented).")) + + (C-call "g_object_get_property" (gobject-alien object) name gvalue) + (let* ((type (C-> gvalue "GValue g_type")) + (value + (case type + (((C-enum "G_TYPE_INVALID")) + (ferror "Property "name" (for "object") is invalid.")) + (((C-enum "G_TYPE_NONE")) + (ferror "Property "name" (for "object") is void.")) + (((C-enum "G_TYPE_INTERFACE")) (unimplemented "an interface")) + (((C-enum "G_TYPE_CHAR")) + (C-call "g_value_get_char" gvalue)) + (((C-enum "G_TYPE_UCHAR")) + (C-call "g_value_get_uchar" gvalue)) + (((C-enum "G_TYPE_BOOLEAN")) + (C-call "g_value_get_boolean" gvalue)) + (((C-enum "G_TYPE_INT")) + (C-call "g_value_get_int" gvalue)) + (((C-enum "G_TYPE_UINT")) + (C-call "g_value_get_uint" gvalue)) + (((C-enum "G_TYPE_LONG")) + (C-call "g_value_get_long" gvalue)) + (((C-enum "G_TYPE_ULONG")) + (C-call "g_value_get_ulong" gvalue)) +; (((C-enum "G_TYPE_INT64")) +; (C-call "g_value_get_int64" gvalue)) +; (((C-enum "G_TYPE_UINT64")) +; (C-call "g_value_get_uint64" gvalue)) + (((C-enum "G_TYPE_ENUM")) + (C-call "g_value_get_enum" gvalue)) + (((C-enum "G_TYPE_FLAGS")) + (C-call "g_value_get_flags" gvalue)) + (((C-enum "G_TYPE_FLOAT")) + (C-call "g_value_get_float" gvalue)) + (((C-enum "G_TYPE_DOUBLE")) + (C-call "g_value_get_double" gvalue)) + (((C-enum "G_TYPE_STRING")) + (let ((alien (make-alien '(const (* |gchar|))))) + (C-call "g_value_get_string" alien gvalue) + (let ((str (c-peek-cstring alien))) + (free alien) + str))) + (((C-enum "G_TYPE_POINTER")) + (let ((alien (make-alien '|gpointer|))) + (C-call "g_value_get_pointer" alien gvalue) + alien)) + (((C-enum "G_TYPE_BOXED")) (unimplemented "a boxed")) + (((C-enum "G_TYPE_PARAM")) (unimplemented "a param")) + (((C-enum "G_TYPE_OBJECT")) + (let ((alien (make-alien '|GObject|))) + (C-call "g_value_get_object" alien gvalue) + alien)) + (else + (ferror "Unexpected GFundamentalType " + (C-enum "enum GFundamentalType" type) + " ("type")."))))) + (free gvalue) + value))) + +(define (gobject-set-properties gobject . property-list) + ;; WAS primitive G-OBJECT-SET-PROPERTIES [gtk.c] + (let* ((object (check-gobject gobject)) + (object-alien (gobject-alien object)) + (gvalue (malloc (C-sizeof "GValue") '|GValue|)) + (pspec (malloc (C-sizeof "GParamSpec") '|GParamSpec|)) + (gtype (malloc (C-sizeof "GType") '|GType|)) + (gclass (gobject-get-gclass object-alien)) + (gclass-name (gclass-get-name gclass))) + (let loop ((plist property-list)) + (cond ((null? plist) unspecific) + ((not (and (pair? plist) (pair? (cdr plist)))) + (ferror "Odd length property list: "property-list)) + (else + (let ((name (check-prop-name (car plist))) + (value (cadr plist))) + (C-call "g_object_class_find_property" pspec gclass name) + (if (alien-null? pspec) + (ferror "There is no "name" property for class " + gclass-name".")) + (let ((flags (C-> pspec "GParamSpec flags"))) + (if (flag-set? flags (C-enum "G_PARAM_WRITABLE")) + (ferror "The "name" property of " + gclass-name" is not writable.")) + (if (not (flag-set? flags (C-enum "G_PARAM_CONSTRUCT_ONLY"))) + (ferror "The "name" property of " + gclass-name" may not be set" + " outside its constructor.")) + (C-call "G_PARAM_SPEC_VALUE_TYPE" gtype pspec) + (C-call "g_value_init" gvalue gtype) + ;; g_value_set_* gvalue * + (let ((fundamental (C-call "G_TYPE_FUNDAMENTAL" gtype))) + (case fundamental + (((C-enum "G_TYPE_CHAR")) + (C-call "g_value_set_char" + gvalue (check-prop-char value name))) + (((C-enum "G_TYPE_UCHAR")) + (C-call "g_value_set_uchar" + gvalue (check-prop-uchar value name))) + (((C-enum "G_TYPE_INT")) + (C-call "g_value_set_int" + gvalue (check-prop-int value name))) + (((C-enum "G_TYPE_UINT")) + (C-call "g_value_set_uint" + gvalue (check-prop-uint value name))) +; (((C-enum "G_TYPE_LONG")) +; (C-call "g_value_set_long" +; gvalue (check-prop-long value name))) +; (((C-enum "G_TYPE_ULONG")) +; (C-call "g_value_set_ulong" +; gvalue (check-prop-ulong value name))) + (((C-enum "G_TYPE_FLOAT")) + (C-call "g_value_set_float" + gvalue (check-prop-flonum value name))) + (((C-enum "G_TYPE_DOUBLE")) + (C-call "g_value_set_double" + gvalue (check-prop-flonum value name))) + (((C-enum "G_TYPE_STRING")) + (C-call "g_value_set_string" + gvalue (check-prop-string value name))) + (((C-enum "G_TYPE_BOOLEAN")) + (C-call "g_value_set_boolean" + gvalue (check-prop-boolean value name))) + (((C-enum "G_TYPE_ENUM")) + (C-call "g_value_set_enum" + gvalue (check-prop-enum value name))) + (((C-enum "G_TYPE_FLAGS")) + (C-call "g_value_set_flags" + gvalue (check-prop-flags value name))) + (((C-enum "G_TYPE_OBJECT")) + (let* ((value-alien + (cond ((gobject? value) (gobject-alien value)) + ((alien? value) value) + (else + (ferror + "The value "value" for property " + name" of "gclass-name" is not a" + " nor alien.")))) + (value-gtype + (gobject-get-gtype value-alien))) + (if (fix:zero? (C-call "g_value_type_compatible" + value-gtype gtype)) + (ferror "The value "value" for property " + name" of "gclass-name + " has incompatible type " + (gclass-get-name + (gobject-get-gclass value-alien)) + ".")) + (C-call "g_value_set_object" gvalue value-alien))) + (else + (ferror "Fundamental GType " + (C-enum "enum GFundamentalType" fundamental) + " (the type of the "name" property of a " + gclass-name") is not supported.")))) + (C-call "g_object_set_property" object-alien name gvalue) + (C-call "g_value_reset" gvalue))) + (loop (cddr plist))))) + (free gtype) + (free pspec) + (free gvalue)) + unspecific) + +(define (gobject-get-gclass alien) + (let ((ret (make-alien '|GObjectClass|))) + (C-call "G_OBJECT_GET_CLASS" ret alien) + ret)) + +(define (gclass-get-name gclass) + ;; GCLASS should be an alien of type GObjectClass. + (let ((c* (make-alien '(* |gchar|)))) + (C-call "G_OBJECT_CLASS_NAME" c* gclass) + (c-peek-cstring c*))) + +(define (gobject-get-gtype gobject) + (let ((ret (make-alien '|GType|))) + (C-call "G_OBJECT_TYPE" ret (gobject-alien gobject)) + ret)) + +(define (flag-set? fixnum mask) + (not (fix:zero? (fix:and fixnum mask)))) + +(define (check-gobject obj) + (if (gobject? obj) + (if (gobject-finalized? obj) obj + (ferror "The object "obj" has been finalized.")) + (ferror "The object "obj" is not a instance."))) + +(define (check-prop-name name) + ;; Allows NAME to be a symbol OR string. + (cond ((symbol? name) (symbol-name name)) + ((string? name) name) + (else (check-prop-name + (ferror "Invalid property name "name"."))))) + +(define (check-prop-value value property verb-phrase type-predicate) + (if (type-predicate value) value + (check-prop-value + (ferror "The value ("value") for the " + property" property must "verb-phrase".") + property verb-phrase type-predicate))) + +(define (check-prop-char value name) + (check-prop-value value name "fit in a char" + (lambda (x) (and (fixnum? x) + (fix:<= -128 x) (fix:< x 128))))) + +(define (check-prop-uchar value name) + (check-prop-value value name "fit in an unsigned char" + (lambda (x) (and (fixnum? x) (fix:<= 0 x) (fix:< x 256))))) + +(define (check-prop-int value name) + (check-prop-value value name "fit in an int" + (lambda (x) (and (exact-integer? x) + (<= (expt -2 31) x (- (expt 2 32) 1)))))) + +(define (uint? x) + (and (exact-integer? x) (<= 0 x (- (expt 2 32) 1)))) + +(define (check-prop-uint value name) + (check-prop-value value name "fit in an unsigned int" uint?)) + +;(define (check-prop-long value name) +; (check-prop-value value name "fit in a long" +; (lambda (x) (and (exact-integer? x) +; (<= (expt -2 63) x (- (expt 2 64) 1)))))) + +;(define (check-prop-ulong value name) +; (check-prop-value value name "fit in an unsigned long" +; (lambda (x) (and (exact-integer? x) +; (<= 0 x (- (expt 2 64) 1)))))) + +(define (check-prop-flonum value name) + (check-prop-value value name "be a flonum" flo:flonum?)) + +(define (check-prop-string value name) + (check-prop-value value name "be a string" string?)) + +(define (check-prop-boolean value name) + (check-prop-value value name "be a boolean" + (lambda (x) (or (eq? #t x) (eq? #f x))))) + +(define (check-prop-enum value name) + (check-prop-value value name "be an enum" uint?)) + +(define (check-prop-flags value name) + (check-prop-value value name "be a flagset" uint?)) + +(define (check-prop-gobject value name) + (check-prop-value value name "be a gobject" gobject?)) + + +;;; GQuarks + +;;; No way (nor need) to GC. Cache them here and toss cache when +;;; restored or reloaded. + +(define gquark-from-string-cache (make-string-hash-table)) + +(define gquark-to-string-cache (make-eqv-hash-table)) + +(define (gquark-from-string string) + ;; Returns the GQuark, an integer. + (or (hash-table/get gquark-from-string-cache string #f) + (let ((gq (C-call "g_quark_from_string" string))) + (hash-table/put! gquark-from-string-cache string gq) + (hash-table/put! gquark-to-string-cache gq string) + gq))) + +(define (gquark-to-string gquark) + (or (hash-table/get gquark-to-string-cache gquark #f) + (ferror "This GQuark ("gquark") has never been cached!"))) + +(define (reset-quark-cache!) + (set! gquark-from-string-cache (make-string-hash-table)) + (set! gquark-to-string-cache (make-eqv-hash-table)) + unspecific) + + +;;;; GdkPixbufLoaders + +(define-class ( (constructor ())) + () + (port define standard initial-value #f) + (thread define standard initial-value #f) + (error-message define standard initial-value #f) + (pixbuf define standard initializer (lambda () (make-alien '|GdkPixbuf|)))) + +(define-method initialize-instance ((loader )) + (call-next-method loader) + (add-gc-cleanup loader (pixbuf-loader-finalize-thunk + (pixbuf-loader-pixbuf loader))) + (C-call "gdk_pixbuf_loader_new" (gobject-alien loader)) + (g-signal-connect loader (C-callback "area_prepared") + (pixbuf-loader-area-prepared loader))) + +(define (pixbuf-loader-finalize-thunk pixbuf-alien) + (named-lambda (pixbuf-loader::finalize-thunk) + + (if (not (alien-null? pixbuf-alien)) + (begin + (C-call "g_object_unref" pixbuf-alien) + (alien-null! pixbuf-alien))) + ;; Signals finalized by initialize-instance(...) method's + ;; gc-cleanup. + )) + +(define (pixbuf-loader-area-prepared loader) + (named-lambda (pixbuf-loader::area-prepared GdkPixbufLoader) + + (let ((pixbuf (pixbuf-loader-pixbuf loader))) + (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf GdkPixbufLoader) + (C-call "g_object_ref" pixbuf)))) + +(define-integrable (pixbuf-loader-started? loader) + (not (eq? #f (pixbuf-loader-port loader)))) + +(define-integrable (pixbuf-loader-done? loader) + (let ((port (pixbuf-loader-port loader))) + (and port (not (port/input-open? port))))) + +(define (start-pixbuf-loader loader input-port) + (without-interrupts + (lambda () + (if (pixbuf-loader-started? loader) + (if (pixbuf-loader-done? loader) + (ferror loader" is already finished.") + (ferror loader" has already started."))) + (set-pixbuf-loader-port! loader input-port))) + (set-pixbuf-loader-thread! + loader (create-pixbuf-loader-thread loader))) + +(define (create-pixbuf-loader-thread loader) + (create-thread + #f (lambda () + (let ((port (pixbuf-loader-port loader)) + (alien (gobject-alien loader)) + (GError-ptr (malloc (C-sizeof "*") '(* |GError|))) + (buff (allocate-external-string 4200))) + (C->= GError-ptr "* GError" 0) + (let ((buff-address (external-string-descriptor buff))) + + (define (note-error) + (let* ((GError (C-> GError-ptr "*" (make-alien '|GError|))) + (message (and (not (alien-null? GError)) + (c-peek-cstring + (C-> GError "GError message"))))) + (set-pixbuf-loader-error-message! + loader (or message "Bogus GError address.")) + (C-call "g_error_free" GError) + (free GError-ptr))) + + (let loop () + (let ((n (input-port/read-string! port buff))) + ;; Adaptively grow the buff if n == 4200? + (cond ((and (fix:zero? n) (eof-object? (peek-char port))) + (if (fix:zero? + (C-call "gdk_pixbuf_loader_close" alien GError-ptr)) + (note-error) + (close-input-port port)) + ;; (gobject-unref loader) Need to ref the pixbuf first! + unspecific) + ((not (fix:zero? + (C-call "gdk_pixbuf_loader_write" + alien buff-address n GError-ptr))) + (loop)) + (else + (note-error) + unspecific))))))))) + +(define (load-pixbuf-from-file loader filename) + (start-pixbuf-loader + loader (open-binary-input-file (->namestring (->truename filename))))) + +(define (initialize-package!) + (add-event-receiver! event:after-restore reset-quark-cache!) + (add-event-receiver! event:after-restore reset-gc-cleanups!) + unspecific) \ No newline at end of file diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm new file mode 100644 index 000000000..8aa92ec3b --- /dev/null +++ b/src/gtk/gtk-ev.scm @@ -0,0 +1,541 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; An event viewer, a translation of Havoc Pennington's GtkEv example. +;;; package: (gtk) + +(declare (usual-integrations)) + + +(c-include "gtk") + +(define (gtk-event-viewer) + (let ((window (gtk-window-new 'toplevel)) + (gtk-ev (gtk-event-viewer-new))) + (gtk-container-add window gtk-ev) + (gtk-window-set-title window "gtk-event-viewer") + (gtk-container-set-border-width window 10) + (g-signal-connect window (C-callback "delete_event") + (let ((counter 0)) + (named-lambda (gtk-event-viewer::delete-event w e) + (trace2 ";(gtk-event-viewer::delete_event "w" "e")\n") + (let ((num (number->string (- 2 counter)))) + (push-text gtk-ev (list (string-append "Delete me "num" times.")))) + (outf-console ";Delete me "(- 2 counter)" times.\n") + (set! counter (1+ counter)) + ;; Three or more is the charm. + (if (> counter 2) 0 1)))) + (gtk-widget-show-all window) + gtk-ev)) + +(define-class ( + (constructor make-gtk-event-viewer ())) + () + + ;; GdkWindow alien, and the window geometry (allocation). + (window define standard + initializer (lambda () (make-alien '|GdkWindow|))) + (geometry define standard + initializer make-rect) + + ;; GdkWindow alien, and the window geometry (computed from the allocation). + (event-window define standard + initializer (lambda () (make-alien '|GdkWindow|))) + (event-box define standard + initializer make-rect) + + ;; Geometry of the description area. + (description-box define standard + initializer make-rect) + + ;; List of lines (strings, no newlines) to be displayed in the + ;; description area. + (buffer define standard + initial-value '())) + +(define (gtk-event-viewer-new) + (let ((w (make-gtk-event-viewer))) + (set-scm-widget-size-request! w (gtk-event-viewer-size-request w)) + (set-scm-widget-size-allocate! w (gtk-event-viewer-size-allocate w)) + (set-scm-widget-realize! w (gtk-event-viewer-realize w)) + (set-scm-widget-unrealize! w (gtk-event-viewer-unrealize w)) + (set-scm-widget-event! w (gtk-event-viewer-event w)) + w)) + +(define (gtk-event-viewer-realize widget) + (named-lambda (gtk-event-viewer::realize GtkWidget) + + (trace2 ";((gtk-event-viewer-realize "widget") "GtkWidget")\n") + (guarantee-my-alien 'gtk-event-viewer::realize widget GtkWidget) + + ;; ScmWidget automatically sets GTK_REALIZED. + + (let ((attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) + (main-GdkWindow (gtk-event-viewer-window widget)) + (event-GdkWindow (gtk-event-viewer-event-window widget)) + (parent-GdkWindow (make-alien '|GdkWindow|)) + ;(GdkVisual (make-alien '|GdkVisual|)) + ;(GdkColormap (make-alien '|GdkColormap|)) + (GdkCursor (make-alien '|GdkCursor|)) + (GtkStyle (make-alien '(struct |_GtkStyle|)))) + + ;; Main widget window. + + ;(C-call "gtk_widget_get_visual" GdkVisual GtkWidget) + ;(check-!null GdkVisual "Could not get GdkVisual.") + ;(C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) + ;(check-!null GdkColormap "Could not get GdkColormap.") + + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (let ((b (gtk-event-viewer-geometry widget))) + (C->= attr "GdkWindowAttr x" (rect-x b)) + (C->= attr "GdkWindowAttr y" (rect-y b)) + (C->= attr "GdkWindowAttr width" (rect-width b)) + (C->= attr "GdkWindowAttr height" (rect-height b))) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + ;;(C->= attr "GdkWindowAttr visual" GdkVisual) + ;;(C->= attr "GdkWindowAttr colormap" GdkColormap) + (C->= attr "GdkWindowAttr event_mask" + (bit-or (C-call "gtk_widget_get_events" GtkWidget) + (C-enum "GDK_EXPOSURE_MASK"))) + + (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) + (check-!null parent-GdkWindow "Could not get parent.") + + (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr + (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") + ;;(C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP") + )) + (check-!null main-GdkWindow "Could not create main window.") + (C->= GtkWidget "GtkWidget window" main-GdkWindow) + (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) + + ;; Event window + (C-call "gdk_cursor_new" GdkCursor (C-enum "GDK_CROSSHAIR")) + (check-!null GdkCursor "Could not create cursor.") + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (let ((b (gtk-event-viewer-event-box widget))) + (C->= attr "GdkWindowAttr x" (rect-x b)) + (C->= attr "GdkWindowAttr y" (rect-y b)) + (C->= attr "GdkWindowAttr width" (rect-width b)) + (C->= attr "GdkWindowAttr height" (rect-height b))) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + ;;(C->= attr "GdkWindowAttr visual" GdkVisual) + ;;(C->= attr "GdkWindowAttr colormap" GdkColormap) + (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) + (C->= attr "GdkWindowAttr cursor" GdkCursor) + (C-call "gdk_window_new" event-GdkWindow main-GdkWindow attr + (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") + ;;(C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP") + (C-enum "GDK_WA_CURSOR"))) + (check-!null event-GdkWindow "Could not create event window.") + (C-call "gdk_window_set_user_data" event-GdkWindow GtkWidget) + (C-call "gdk_window_show" event-GdkWindow) + (C-call "gdk_cursor_destroy" GdkCursor) + + ;; Style + + (C-call "gtk_style_attach" GtkStyle + (C-> GtkWidget "GtkWidget style") main-GdkWindow) + (C->= GtkWidget "GtkWidget style" GtkStyle) + (C-call "gtk_style_set_background" + GtkStyle main-GdkWindow (C-enum "GTK_STATE_NORMAL")) + (C-call "gdk_window_set_background" + event-GdkWindow + (C-array-loc! (C-> GtkStyle "struct _GtkStyle base") + "GdkColor" (C-enum "GTK_STATE_NORMAL"))) + unspecific))) + +(define (gtk-event-viewer-unrealize widget) + (named-lambda (gtk-event-viewer::unrealize GtkWidget) + + (trace2 ";((gtk-event-viewer-unrealize "widget") "GtkWidget")\n") + (guarantee-my-alien 'GTK-EVENT-VIEWER::UNREALIZE widget GtkWidget) + + ;; ScmWidget automatically unmaps if necessary. + + ;; Destroy our child window. + (let ((event-GdkWindow (gtk-event-viewer-event-window widget))) + (if (not (alien-null? event-GdkWindow)) + (begin + (C-call "gdk_window_set_user_data" event-GdkWindow null-alien) + (C-call "gdk_window_destroy" event-GdkWindow) + (alien-null! event-GdkWindow)))) + + ;; The ScmWidget will chain up, calling parent_class->unrealize, + ;; as required by the toolkit. + unspecific)) + +(define (gtk-event-viewer-size-request widget) + (named-lambda (gtk-event-viewer::size-request GtkWidget GtkRequisition) + + (trace2 ";((gtk-event-viewer-size-request "widget") "GtkWidget" "GtkRequisition")\n") + (guarantee-my-alien 'GTK-EVENT-VIEWER::SIZE-REQUEST widget GtkWidget) + + ;; GtkEv always wants to be the same fixed size. + + (C->= GtkRequisition "GtkRequisition width" 450) + (C->= GtkRequisition "GtkRequisition height" 300) + unspecific)) + +(define (gtk-event-viewer-size-allocate widget) + (named-lambda (gtk-event-viewer::size-allocate GtkWidget GtkAllocation) + + (trace2 ";((gtk-event-viewer-size-allocate "widget") "GtkWidget" "GtkAllocation")\n") + (guarantee-my-alien 'GTK-EVENT-VIEWER::SIZE-ALLOCATE widget GtkWidget) + + (let ((x (C-> GtkAllocation "GtkAllocation x")) + (y (C-> GtkAllocation "GtkAllocation y")) + (width (C-> GtkAllocation "GtkAllocation width")) + (height (C-> GtkAllocation "GtkAllocation height")) + (spacing 10)) + (set-rect! (gtk-event-viewer-geometry widget) x y width height) + (C->= GtkWidget "GtkWidget allocation x" x) + (C->= GtkWidget "GtkWidget allocation y" y) + (C->= GtkWidget "GtkWidget allocation width" width) + (C->= GtkWidget "GtkWidget allocation height" height) + (let ((event-width (max (- width (* 2 spacing)) 0)) + (event-height (max (- (quotient height 5) spacing) 0))) + (let ((event-x (quotient (- width event-width) 2)) + (event-y (min height spacing))) + (set-rect! (gtk-event-viewer-event-box widget) + event-x event-y event-width event-height) + (let* ((desc-x event-x) + (desc-y (+ event-y (+ event-height spacing))) + (desc-width event-width) + (desc-height (max (- height (+ event-height (* 3 spacing))) + 0))) + (set-rect! (gtk-event-viewer-description-box widget) + desc-x desc-y desc-width desc-height)) + + (if (not (alien-null? (gtk-event-viewer-window widget))) ;GTK_WIDGET_REALIZED + (begin + (C-call "gdk_window_move_resize" + (gtk-event-viewer-window widget) x y width height) + (C-call "gdk_window_move_resize" + (gtk-event-viewer-event-window widget) + event-x event-y event-width event-height))) + unspecific))))) + +;;; For debugging. +;;;(define gtk-event-viewer-events '()) + +(define (gtk-event-viewer-event widget) + (named-lambda (gtk-event-viewer::event GtkWidget GdkEvent) + + (trace2 ";((gtk-event-viewer-event "widget") "GtkWidget" "GdkEvent")\n") + (guarantee-my-alien 'gtk-event-viewer::event widget GtkWidget) + (let ((window (C-> GdkEvent "GdkEvent any window")) + (type (C-> GdkEvent "GdkEvent any type"))) + (let ((addr (alien/address-string window)) + (name (C-enum "GdkEventType" type))) + (trace "; "name" on window 0x"addr".\n")) + +;;; (set! gtk-event-viewer-events (cons (let ((alien (make-alien '|GdkEvent|))) +;;; (C-call "gdk_event_copy" alien GdkEvent) +;;; (check-!null alien "could not copy event") +;;; alien) +;;; gtk-event-viewer-events)) + + (if (not (alien=? window (gtk-event-viewer-window widget))) + (push-text widget (event-to-text GdkEvent))) + + (if (= type (C-enum "GDK_EXPOSE")) + (expose-handler widget GdkEvent) + (begin + (if (and (= type (C-enum "GDK_KEY_PRESS")) + (= (C-> GdkEvent "GdkEvent key keyval") + (C-enum "GDK_D"))) + ;; Test debugging in a callback. + (bkpt 'Test)) + + (if (= type (C-enum "GDK_MOTION_NOTIFY")) + (C-call "gdk_window_get_pointer" #f + (C-> GdkEvent "GdkEventMotion window") + null-alien null-alien null-alien)) + 0 ;;FALSE -- not handled. + ))))) + +(define (expose-handler widget GdkEventExpose) + + (let ((window (C-> GdkEventExpose "GdkEventExpose window")) + (x (C-> GdkEventExpose "GdkEventExpose area x")) + (y (C-> GdkEventExpose "GdkEventExpose area y")) + (width (C-> GdkEventExpose "GdkEventExpose area width")) + (height (C-> GdkEventExpose "GdkEventExpose area height"))) + (trace "; Expose "x","y" "width"x"height"\n") + (cond ((alien=? (gtk-event-viewer-window widget) window) + (paint-window widget x y width height)) + ((alien=? (gtk-event-viewer-event-window widget) window) + (paint-event-window widget x y width height)) + (else (ferror "gtk-event-viewer-expose: unexpected window "window)))) + 1 ;;TRUE -- handled. + ) + +(define (paint-window widget x y width height) + (trace2 ";(paint-window "widget" "x" "y" "width" "height")\n") + (let* ((alien (gobject-alien widget)) + (window (gtk-event-viewer-window widget)) + (rect (gtk-event-viewer-event-box widget)) + (style (C-> alien "GtkWidget style")) + (state (C-> alien "GtkWidget state")) + (black-gc (C-> style "GtkStyle black_gc")) + (exposed-area (gdk-rectangle x y width height))) + + ;; No longer needed in Gtk+2.0. + ;;(C-call "gdk_window_clear_area" window x y width height) + ;;(C-call "gdk_gc_set_clip_rectangle" black-gc exposed-area) + + ;; Draw a black rectangle around the event window + + (C-call "gdk_draw_rectangle" window black-gc 0 + (-1+ (rect-x rect)) + (-1+ (rect-y rect)) + (+ 2 (rect-width rect)) + (+ 2 (rect-height rect))) + (C-call "gdk_gc_set_clip_rectangle" black-gc null-alien) + + ;; Draw text in the description area, if applicable. + + (if (gtk-event-viewer-buffer widget) + (let* ((descrip-box (gtk-event-viewer-description-box widget)) + (descrip-gdkrect (gdk-rectangle-from-rect descrip-box)) + (intersection (gdk-rectangle))) + (if (not (= 0 (C-call "gdk_rectangle_intersect" + exposed-area descrip-gdkrect intersection))) + (let ((space 2) + (desc-bottom (rect-max-y descrip-box)) + (layout (make-alien '|PangoLayout|))) + (C-call "gtk_widget_create_pango_layout" layout + alien null-alien) + (let loop ((y (rect-y descrip-box)) + (lines (gtk-event-viewer-buffer widget))) + (if (null? lines) + unspecific + (let ((line (car lines)) + (iter (make-alien '|PangoLayoutIter|))) + (C-call "pango_layout_set_text" layout line -1) + (C-call "pango_layout_get_iter" iter layout) + (let ((baseline + (pangos->pixels + (C-call "pango_layout_iter_get_baseline" + iter)))) + (C-call "gtk_paint_layout" + style window state 1 ;; Use the text gc. + intersection alien "gtk-event-viewer" + 10 y layout) + (C-call "pango_layout_iter_free" iter) + (alien-null! iter) + (let ((new-y (+ y (+ baseline space)))) + (if (> new-y desc-bottom) + (begin + (set-cdr! lines '()) + unspecific) + (loop new-y (cdr lines)))))))) + (C-call "g_object_unref" layout))) + (free descrip-gdkrect) + (free intersection))) + + (if (gtk-widget-has-focus? widget) + (C-call "gtk_paint_focus" + style window state null-alien alien "gtk-event-viewer" + x y (-1+ width) (-1+ height))) + (free exposed-area) + unspecific)) + +(define (paint-event-window widget x y width height) + (trace2 ";(paint-event-window "widget" "x" "y" "width" "height")\n") + (let ((alien (gobject-alien widget)) + (event-window (gtk-event-viewer-event-window widget)) + (extent (pango-rectangle)) + (layout (make-alien '|PangoLayout|)) + (area (pango-rectangle x y width height))) + (C-call "gdk_window_clear_area" event-window x y width height) + (let ((title (string-append "Event Window (0x" + (alien/address-string event-window)")"))) + (C-call "gtk_widget_create_pango_layout" layout alien title)) + (C-call "pango_layout_get_pixel_extents" layout extent null-alien) + (C-call "gtk_paint_layout" + (C-> alien "GtkWidget style") + event-window + (C-> alien "GtkWidget state") + 1 ;; Use the text gc, not the fg gc. + area alien "gtk-event-viewer" + ;;center + (quotient (- (rect-width (gtk-event-viewer-event-box widget)) + (C-> extent "PangoRectangle width")) + 2) + 0 + layout) + (C-call "g_object_unref" layout) + (free extent) + (free area) + unspecific)) + +(define (push-text ev lines) + (set-gtk-event-viewer-buffer! ev (append lines (gtk-event-viewer-buffer ev))) + (if (gtk-widget-drawable? ev) + (let ((a (gobject-alien ev)) + (r (gtk-event-viewer-description-box ev))) + (C-call "gtk_widget_queue_draw_area" + a (rect-x r) (rect-y r) (rect-width r) (rect-height r))))) + + +(define (event-to-text GdkEvent) + (let ((name-line (event-name-line GdkEvent)) + (any-line (any-event-line GdkEvent)) + (detail (event-detail-line GdkEvent)) + (state (event-state-line GdkEvent))) + (append! + (list name-line) + (list (string-append " " any-line)) + (if detail (list (string-append " " detail)) '()) + (if state (list (string-append " " state)) '())))) + +(define (event-name-line GdkEvent) + (let ((type (C-> GdkEvent "GdkEvent any type"))) + (string-append (symbol-name (C-enum "GdkEventType" type)) "\n"))) + +(define (any-event-line GdkEvent) + (let ((event-time (C-call "gdk_event_get_time" GdkEvent)) + (addr (alien/address-string (C-> GdkEvent "GdkEvent any window"))) + (send (if (not (= 0 (C-> GdkEvent "GdkEvent any send_event"))) + "True" "False"))) + (if (not (= event-time (C-enum "GDK_CURRENT_TIME"))) + (cat "Window: 0x"addr" Time: "event-time" send_event: "send"\n") + (cat "Window: 0x"addr" send_event: "send"\n")))) + +(define (cat . objects) + (apply string-append (map (lambda (obj) + (if (string? obj) obj (write-to-string obj))) + objects))) + +(define (event-state-line GdkEvent) + (let* ((type (C-> GdkEvent "GdkEvent any type")) + (state ;;GdkModifierType + (cond ((= type (C-enum "GDK_MOTION_NOTIFY")) + (C-> GdkEvent "GdkEvent motion state")) + ((memv type `(,(C-enum "GDK_BUTTON_PRESS") + ,(C-enum "GDK_2BUTTON_PRESS") + ,(C-enum "GDK_3BUTTON_PRESS") + ,(C-enum "GDK_BUTTON_RELEASE"))) + (C-> GdkEvent "GdkEvent button state")) + ((memv type `(,(C-enum "GDK_KEY_PRESS") + ,(C-enum "GDK_KEY_RELEASE"))) + (C-> GdkEvent "GdkEvent key state")) + (else #f))) + (line + (and state + (string-append + (decorated-string-append + "" " | " "" + (append! + (if (not (= 0 (bit-and state (C-enum "GDK_SHIFT_MASK")))) + (list "Shift") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_LOCK_MASK")))) + (list "Lock") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_CONTROL_MASK")))) + (list "Ctrl") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_MOD1_MASK")))) + (list "Mod1") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_MOD2_MASK")))) + (list "Mod2") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_MOD3_MASK")))) + (list "Mod3") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_MOD4_MASK")))) + (list "Mod4") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_MOD5_MASK")))) + (list "Mod5") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON1_MASK")))) + (list "Button1") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON2_MASK")))) + (list "Button2") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON3_MASK")))) + (list "Button3") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON4_MASK")))) + (list "Button4") '()) + (if (not (= 0 (bit-and state (C-enum "GDK_RELEASE_MASK")))) + (list "Release") '()))) + "\n")))) + (if (or (not line) (string=? line "\n")) #f line))) + +(define (event-detail-line GdkEvent) + (let ((type (C-> GdkEvent "GdkEvent any type"))) + (cond ((= type (C-enum "GDK_EXPOSE")) + (let ((x (C-> GdkEvent "GdkEvent expose area x")) + (y (C-> GdkEvent "GdkEvent expose area y")) + (width (C-> GdkEvent "GdkEvent expose area width")) + (height (C-> GdkEvent "GdkEvent expose area height")) + (count (C-> GdkEvent "GdkEvent expose count"))) + (cat "Area: "x","y" "width"x"height" Count: "count"\n"))) + ((= type (C-enum "GDK_MOTION_NOTIFY")) + (let ((x (C-> GdkEvent "GdkEvent motion x")) + (y (C-> GdkEvent "GdkEvent motion y"))) + (cat "x: "x" y: "y"\n"))) + ((memq type `(,(C-enum "GDK_BUTTON_PRESS") + ,(C-enum "GDK_2BUTTON_PRESS") + ,(C-enum "GDK_3BUTTON_PRESS") + ,(C-enum "GDK_BUTTON_RELEASE"))) + (cat "Button: "(C-> GdkEvent "GdkEvent button button")"\n")) + ((memq type `(,(C-enum "GDK_KEY_PRESS") + ,(C-enum "GDK_KEY_RELEASE"))) + (let ((keyval (C-enum "enum GdkKeysyms" + (C-> GdkEvent "GdkEvent key keyval"))) + (text (let ((alien (make-alien '|gchar|))) + (C-> GdkEvent "GdkEvent key string" alien) + (c-peek-cstring alien)))) + (cat "Keyval: "keyval" Text: "text"\n"))) + (else + #f)))) + +(define (check-!null alien message) + (if (alien-null? alien) + (begin + (ferror "gtk-event-viewer: "message)) + alien)) + +(define (guarantee-my-alien name widget alien) + ;; Complain if the WIDGET's alien does not match ALIEN. NAME is the + ;; widget method name or other debugging help. Just warn, since + ;; this is used in callbacks. + + (cond ((alien-null? (gobject-alien widget)) + (fwarn "in "name", "widget" has been finalized (or never" + " initialized).")) + ((not (alien=? alien (gobject-alien widget))) + (fwarn "in "name", "alien" is not the expected " + (gobject-alien widget)".")))) + + +(define trace? #f) +(define trace2? #f) + +(define-syntax trace + (syntax-rules () + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + +(define-syntax trace2 + (syntax-rules () + ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm new file mode 100644 index 000000000..16f4268d0 --- /dev/null +++ b/src/gtk/gtk-object.scm @@ -0,0 +1,326 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; GtkObjects/GtkWidgets/GtkContainers +;;; package: (gtk object) + + +(c-include "gtk") + +(define-class () + (destroyed? define standard initial-value #f)) + +(define-method initialize-instance ((object )) + ;; Arrange for all gtk-objects to be destroyed by gtk_object_destroy + ;; when GCed. Does NOT chain (further) up; gtk-object-cleanup is + ;; sufficient. g_object_unref probably should NOT be called! + (add-gc-cleanup object + (gtk-object-cleanup-thunk + (gobject-alien object) + (gobject-signals object)))) + +(define (gtk-object-cleanup-thunk alien signals) + ;; Return a thunk closed over ALIEN and SIGNALS (but not the gtk-object). + (lambda () + (gtk-object-cleanup alien signals))) + +(define (gtk-object-cleanup alien signals) + (without-interrupts + (lambda () + (if (not (alien-null? alien)) + (begin + (C-call "gtk_object_destroy" alien) + (alien-null! alien))))) + ;; De-register signals. Nulled alien will not be g_object_unrefed. + (gobject-finalize! alien signals)) + +(define-generic gtk-object-destroy (object)) + +(define-method gtk-object-destroy ((object )) + ;; Calls gtk_object_destroy and sets the destroyed? flag. + (if (not (gtk-object-destroyed? object)) + (begin + (set-gtk-object-destroyed?! object #t) + (gtk-object-cleanup (gobject-alien object) (gobject-signals object))))) + + +;;;; GtkAdjustments + +(define-class ( (constructor ())) ()) + +;(define-integrable (gtk-adjustment-value adjustment) +; (C-> (live-alien-adjustment adjustment) "GtkAdjustment value")) +;(define-integrable (gtk-adjustment-lower adjustment) +; (C-> (live-alien-adjustment adjustment) "GtkAdjustment lower")) +;(define-integrable (gtk-adjustment-upper adjustment) +; (C-> (live-alien-adjustment adjustment) "GtkAdjustment upper")) +;(define-integrable (gtk-adjustment-step-increment adjustment) +; (C-> (live-alien-adjustment adjustment) "GtkAdjustment step_increment")) +;(define-integrable (gtk-adjustment-page-increment adjustment) +; (C-> (live-alien-adjustment adjustment) "GtkAdjustment page_increment")) +;(define-integrable (gtk-adjustment-page-size adjustment) +; (C-> (live-alien-adjustment adjustment) "GtkAdjustment page_size")) +(define (live-alien-adjustment object) + (if (gtk-adjustment? object) + (if (not (gobject-finalized? object)) + (gobject-alien object) + (ferror "The gtk-adjustment "object" has been finalized.")) + (ferror "The object "object" is not a instance."))) + +(define (set-gtk-adjustment! adjustment value + lower upper page-size + step-incr page-incr) + (let ((alien (live-alien-adjustment adjustment)) + (new-lower (floor->exact (check-real lower))) + (new-upper (floor->exact (check-real upper))) + (new-value (floor->exact (check-real value))) + (new-page-size (floor->exact (check-real page-size))) + (new-step-incr (floor->exact (check-real step-incr))) + (new-page-incr (floor->exact (check-real page-incr)))) + (let ((old-lower (floor->exact (C-> alien "GtkAdjustment lower"))) + (old-upper (floor->exact (C-> alien "GtkAdjustment upper"))) + (old-value (floor->exact (C-> alien "GtkAdjustment value"))) + (old-page-size + (floor->exact (C-> alien "GtkAdjustment page_size"))) + (old-step-incr + (floor->exact (C-> alien "GtkAdjustment step_increment"))) + (old-page-incr + (floor->exact (C-> alien "GtkAdjustment page_increment")))) + (if (not (int:= new-lower old-lower)) + (C->= alien "GtkAdjustment lower" new-lower)) + (if (not (int:= new-upper old-upper)) + (C->= alien "GtkAdjustment upper" new-upper)) + (if (not (int:= new-value old-value)) + (C->= alien "GtkAdjustment value" new-value)) + (if (not (int:= new-page-size old-page-size)) + (C->= alien "GtkAdjustment page_size" new-page-size)) + (if (not (int:= new-step-incr old-step-incr)) + (C->= alien "GtkAdjustment step_increment" new-step-incr)) + (if (not (int:= new-page-incr old-page-incr)) + (C->= alien "GtkAdjustment page_increment" new-page-incr)) + (if (or (not (int:= new-lower old-lower)) + (not (int:= new-upper old-upper)) + (not (int:= new-page-size old-page-size)) + (not (int:= new-step-incr old-step-incr)) + (not (int:= new-page-incr old-page-incr))) + (C-call "gtk_adjustment_changed" alien)) + (if (not (int:= new-value old-value)) + (C-call "gtk_adjustment_value_changed" alien))))) + +(define (check-real object) + (if (real? object) object + (ferror "The object "object" is not a real number."))) + + +;;;; GtkWidgets, GtkContainers + +(define-class () + + ;; The parent or #f. + (parent define standard initial-value #f)) + +(define (gtk-widget-has-focus? widget) + (let* ((alien (gobject-alien (check-gtk-widget widget))) + (flags (C-> alien "GtkWidget object flags"))) + (not (int:zero? (bit-and flags (C-enum "GTK_HAS_FOCUS")))))) + +(define (gtk-widget-drawable? widget) + (let* ((alien (gobject-alien (check-gtk-widget widget))) + (flags (C-> alien "GtkWidget object flags"))) + (and (not (int:zero? (bit-and flags (C-enum "GTK_VISIBLE")))) + (not (int:zero? (bit-and flags (C-enum "GTK_MAPPED"))))))) + +(define (gtk-widget-show-all widget) + (C-call "gtk_widget_show_all" + (gobject-alien (check-gtk-widget widget)))) + +(define-class () + + ;; A list of child gtk-widgets. + (children define standard initial-value '())) + +(define-method gtk-object-destroy ((widget )) + ;; Calls gtk_object_destroy for WIDGET and all its children. + + (call-next-method widget) + (for-each (lambda (child) (gtk-container-destroy-child child)) + (gtk-container-children widget))) + +(define (gtk-container-destroy-child child) + ;; Destroy the child of a container without actually calling + ;; gtk_object_destroy, since an earlier call to gtk_object_destroy + ;; with an ancestor gtk-widget has already destroyed this child in + ;; the toolkit. Just mark these wrappers as destroyed (implicitly). + (if (not (gtk-object-destroyed? child)) + (let ((alien (gobject-alien child))) + (alien-null! alien) + (gtk-object-destroy child)))) + +(define (gtk-container-add parent child) + ;; gtk_container_add with some Scheme-side bookkeeping. + (let ((children (gtk-container-children parent))) + (if (memq child children) + (ferror child" is already contained in "parent".")) + (set-gtk-container-children! parent (cons child children))) + (set-gtk-widget-parent! child parent) + (C-call "gtk_container_add" + (gobject-alien parent) (gobject-alien child)) + unspecific) + +(define (gtk-container-set-border-width container width) + (C-call "gtk_container_set_border_width" + (gobject-alien (check-gtk-container container)) + width)) + +(define (check-gtk-widget object) + (if (gtk-widget? object) object + (ferror object" is not a instance."))) + +(define (check-gtk-container object) + (if (gtk-container? object) object + (ferror object" is not a instance."))) + + +;;; GtkLabels + +(define-class ( (constructor ())) ()) + +(define (gtk-label-new string) + (let* ((s (if (string? string) string + (ferror "The gtk-label string ("string") is not a string."))) + (l (make-gtk-label)) + (a (gobject-alien l))) + (C-call "gtk_label_new" a s) + (if (alien-null? a) (ferror "Could not create label "string".")) + l)) + +(define (gtk-label-get-text label) + (let ((retval (make-alien '|gchar|))) + (C-call "gtk_label_get_text" retval (gobject-alien label)) + (c-peek-cstring retval))) + +(define (gtk-label-set-text label string) + (let ((s (if (string? string) string + (ferror "The gtk-label string ("string") is not a string.")))) + (C-call "gtk_label_set_text" (gobject-alien label) s))) + + +;;; GtkButtons + +(define-class ( (constructor ())) ()) + +(define (gtk-button-new) + (let* ((b (make-gtk-button)) + (a (gobject-alien b))) + (C-call "gtk_button_new" a) + (if (alien-null? a) (ferror "Could not create button.")) + b)) + + +;;; GtkVBox + +(define-class ( (constructor ())) ()) + +(define (gtk-vbox-new homogeneous? spacing) + ;; homogeneous : TRUE if all children are to be given equal space allotments. + ;; spacing : the number of pixels to place by default between children. + + (let* ((vbox (make-gtk-vbox)) + (alien (gobject-alien vbox))) + (C-call "gtk_vbox_new" alien (if homogeneous? 1 0) spacing) + (if (alien-null? alien) (ferror "Could not create vbox.")) + vbox)) + +(define (gtk-box-pack-start box child expand? fill? padding) + (let ((children (gtk-container-children box))) + (if (memq child children) + (ferror "Child "child" is already packed in parent "box".")) + (set-gtk-container-children! box (cons child children))) + (set-gtk-widget-parent! child box) + (C-call "gtk_box_pack_start" (gobject-alien box) (gobject-alien child) + (if expand? 1 0) (if fill? 1 0) padding) + unspecific) + +(define (gtk-box-pack-end box child expand? fill? padding) + (let ((children (gtk-container-children box))) + (if (memq child children) + (ferror "Child "child" is already packed in parent "box".")) + (set-gtk-container-children! box (cons child children))) + (set-gtk-widget-parent! child box) + (C-call "gtk_box_pack_end" (gobject-alien box) (gobject-alien child) + (if expand? 1 0) (if fill? 1 0) padding) + unspecific) + + +;;;; GtkScrolledWindows + +(define-class ( + (constructor make-gtk-scrolled-window ())) + ()) + +(define (gtk-scrolled-window-new) + (let* ((window (make-gtk-scrolled-window)) + (alien (gobject-alien window))) + (C-call "gtk_scrolled_window_new" alien null-alien null-alien) + (if (alien-null? alien) (ferror "Could not create GtkScrolledWindow.")) + window)) + + +;;;; GtkWindows + +(define-class ( (constructor make-gtk-window (type))) + () + ;; 'POPUP or 'TOPLEVEL + (type define accessor)) + +(define (gtk-window-new type) + (let* ((type (check-window-type type)) + (window (make-gtk-window type)) + (alien (gobject-alien window))) + (C-call "gtk_window_new" alien + (case type + ((TOPLEVEL) (C-enum "GTK_WINDOW_TOPLEVEL")) + ((POPUP) (C-enum "GTK_WINDOW_POPUP")))) + (if (alien-null? alien) (ferror "Could not create window.")) + (g-signal-connect window (C-callback "destroy") + (named-lambda (gtk-window-new::destroy GtkObject) + GtkObject ;;ignore + (gtk-object-destroy window))) + (C-call "gtk_window_set_default_size" alien -1 -1) + window)) + +(define (check-window-type type) + (case type + ((TOPLEVEL POPUP) type) + (else + (check-window-type + (ferror "The argument to gtk-window-new must be one of" + " the symbols TOPLEVEL or POPUP (not "type")."))))) + +(define (gtk-window-set-title window string) + (C-call "gtk_window_set_title" (gobject-alien window) string)) + +(define (gtk-window-set-default-size window width height) + (C-call "gtk_window_set_default_size" (gobject-alien window) width height)) \ No newline at end of file diff --git a/src/gtk/gtk-shim.h b/src/gtk/gtk-shim.h new file mode 100644 index 000000000..96919ce81 --- /dev/null +++ b/src/gtk/gtk-shim.h @@ -0,0 +1,69 @@ +/* -*-C-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* Header for gtk-shim.c, gtk-const.c and scmwidget.c. */ + +#include +#include +#include +#include + +#define GTK_TYPE_SCMWIDGET (scm_widget_get_type ()) +#define GTK_SCMWIDGET(obj) (G_TYPE_CHECK_INSTANCE_CAST ((obj), GTK_TYPE_SCMWIDGET, ScmWidget)) +#define GTK_IS_SCMWIDGET(obj) (G_TYPE_CHECK_INSTANCE_TYPE ((obj), GTK_TYPE_SCMWIDGET)) + +typedef unsigned int uint; +typedef struct _ScmWidgetClass ScmWidgetClass; +typedef struct _ScmWidget ScmWidget; + +struct _ScmWidgetClass +{ + GtkWidgetClass parent_class; + void (*set_scroll_adjustments) (GtkWidget *widget, + GtkAdjustment *hadjustment, + GtkAdjustment *vadjustment); + + /* Padding for future expansion */ + void (*_gtk_reserved1) (void); + void (*_gtk_reserved2) (void); + void (*_gtk_reserved3) (void); + void (*_gtk_reserved4) (void); +}; + +struct _ScmWidget +{ + GtkWidget widget; + /* Callback ids, for the methods to use when calling the callback tramps. */ + gint finalize; + gint destroy; + gint realize; + gint unrealize; + gint size_request; + gint size_allocate; + gint event; + gint set_scroll_adjustments; +}; + +extern GtkWidget* scm_widget_new (void); diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl new file mode 100644 index 000000000..cd8d90b57 --- /dev/null +++ b/src/gtk/gtk.cdecl @@ -0,0 +1,170 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; C declarations for gtk.so. + + +(include "Includes/gdkkeysyms") +(include "Includes/gdk-pixbuf") +(include "Includes/gtk") +(include "Includes/pango") +(include "Includes/cairo") +;;(include "Includes/cairo-xlib") Needs definitions for Drawable, Display... +(include "Includes/pangocairo") + +;;; ScmWidget + +(typedef ScmWidget + (struct _ScmWidget + (widget GtkWidget) + (finalize gint) + (destroy gint) + (realize gint) + (unrealize gint) + (size_request gint) + (size_allocate gint) + (event gint) + (set_scroll_adjustments gint))) + +(extern (* GtkWidget) scm_widget_new) + +(callback void widget_finalize + (ID int) (object (* GObject))) +(callback void widget_destroy + (ID int) (object (* GtkObject))) +(callback void widget_realize + (ID int) (widget (* GtkWidget))) +(callback void widget_unrealize + (ID int) (widget (* GtkWidget))) +(callback void widget_size_request + (ID int) (widget (* GtkWidget)) (requisition (* GtkRequisition))) +(callback void widget_size_allocate + (ID int) (widget (* GtkWidget)) (allocation (* GtkAllocation))) +(callback gint widget_event + (ID int) (widget (* GtkWidget)) (event (* GdkEvent))) +(callback void widget_set_scroll_adjustments + (ID int) (widget (* GtkWidget)) + (hadj (* GtkAdjustment)) (vadj (* GtkAdjustment))) + + +;;; Signal handlers. + +(callback void destroy + (object (* GtkObject)) + (ID gpointer)) + +(callback gboolean delete_event + (window (* GtkWidget)) + (event (* GdkEventAny)) + (ID gpointer)) + +(callback void clicked + (widget (* GtkWidget)) + (ID gpointer)) + +(callback void value_changed + (adjustment (* GtkAdjustment)) + (ID gpointer)) + +(callback void size_prepared + (loader (* GdkPixbufLoader)) + (width gint) + (height gint) + (ID gpointer)) + +(callback void area_prepared + (loader (* GdkPixbufLoader)) + (ID gpointer)) + +(callback void area_updated + (loader (* GdkPixbufLoader)) + (x gint) + (y gint) + (width gint) + (height gint) + (ID gpointer)) + + +;;; Random + +(extern void g_free ;glib-2.8.6/glib/gmem.h + (mem gpointer)) + +(extern gboolean gtk_init_check + (argc (* int)) + (argv (* (* (* char))))) + +(extern void + gtk_widget_queue_resize + (widget (* GtkWidget))) + +(extern void ;gtk+-2.4.0/gtk/gtkcontainer.h + gtk_container_add + (container (* GtkContainer)) + (widget (* GtkWidget))) + +(extern void ;gtk+-2.4.0/gtk/gtkcontainer.h + gtk_container_set_border_width + (container (* GtkContainer)) + (border_width guint)) + +(extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtkwindow.h + gtk_window_new + (type GtkWindowType)) + +(extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtkbutton.h + gtk_button_new) + +(extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtklabel.h + gtk_label_new + (str (* (const char)))) + +(extern void ;gtk+-2.4.0/gtk/gtkwindow.h + gtk_window_set_title + (window (* GtkWindow)) + (title (* (const gchar)))) + +(extern void ;gtk+-2.10.14/gtk/gtkwindow.h + gtk_window_set_default_size + (window (* GtkWindow)) + (width gint) + (height gint)) + +(extern (* (const gchar)) ;gtk+-2.4.0/gtk/gtklabel.h + gtk_label_get_text + (label (* GtkLabel))) + +(extern void gtk_label_set_text ;gtk+-2.4.0/gtk/gtklabel.h + (label (* GtkLabel)) + (str (* (const char)))) + +(extern void gdk_rgb_find_color ;gtk+-2.8.20/gdk/gdkrgb.h + (colormap (* GdkColormap)) + (color (* GdkColor))) + +(extern (* GtkWidget) ;gtk+-2.8.20/gtk/gtkscrolledwindow.h + gtk_scrolled_window_new + (hadjustment (* GtkAdjustment)) + (vadjustment (* GtkAdjustment))) \ No newline at end of file diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg new file mode 100644 index 000000000..f2c604997 --- /dev/null +++ b/src/gtk/gtk.pkg @@ -0,0 +1,127 @@ +#| -*-Scheme-*- + +$Id: $ + +Gtk System Packaging |# + +(global-definitions "../runtime/runtime") +(global-definitions "../ffi/ffi") +(global-definitions "../sos/sos") + +(define-package (gtk) + (parent ()) + (files "gtk")) + +(define-package (gtk main) + (parent (gtk)) + (files "main") + (import (runtime load) + *unused-command-line* + hook/process-command-line + default/process-command-line) + (export (gtk) + gtk-time-slice-window? + gtk-time-slice-window! + gtk-select-trace? + gtk-select-trace!) + (initialization (initialize-package!))) + +(define-package (gtk thread) + (parent (runtime thread)) + (files "thread") + (export (gtk) + create-gtk-thread + kill-gtk-thread) + (import (runtime primitive-io) + select-registry-handle)) + +(define-package (gtk gobject) + (parent (gtk)) + (files "gobject") + (export (gtk) + gobject-alien + gobject-unref gobject-finalized? gobject-finalize! + g-signal-connect g-signal-disconnect add-gc-cleanup + gobject-get-property gobject-set-properties + gquark-from-string gquark-to-string + make-pixbuf-loader load-pixbuf-from-file + pixbuf-loader-started? pixbuf-loader-done?) + (initialization (initialize-package!))) + +(define-package (gtk object) + (parent (gtk)) + (files "gtk-object") + (export (gtk) + gtk-object-destroyed? gtk-object-destroy + make-gtk-adjustment set-gtk-adjustment! + gtk-widget? gtk-widget-parent + gtk-widget-has-focus? gtk-widget-drawable? gtk-widget-show-all + gtk-container? + gtk-container-children gtk-container-add + gtk-container-set-border-width + gtk-window-type + gtk-window-new gtk-window-set-title gtk-window-set-default-size + gtk-button-new + gtk-label-new + gtk-label-get-text gtk-label-set-text + gtk-vbox-new gtk-box-pack-start gtk-box-pack-end + gtk-scrolled-window-new + pango-rectangle pangos->pixels pixels->pangos + pango-font-families pango-context-list-families + pango-font-family-get-name pango-font-family-is-monospace? + pango-font-family-faces pango-font-face-get-name) + (import (gtk gobject) gobject-finalize! gobject-signals)) + +(define-package (gtk widget) + (parent (gtk)) + (files "scm-widget") + (export (gtk) + + set-scm-widget-destroy! + set-scm-widget-realize! set-scm-widget-unrealize! + set-scm-widget-size-request! set-scm-widget-size-allocate! + set-scm-widget-event! set-scm-widget-set-scroll-adjustments!)) + +(define-package (gtk layout) + (parent (gtk)) + (files "scm-layout") + (export (gtk) + + scm-layout-new + scm-layout-geometry set-scm-layout-size! + scm-layout-drawing set-scm-layout-drawing! + scm-layout-on-screen-area set-scm-layout-scroll-pos! + + make-drawing set-drawing-size! drawing-pick-list + + drawn-item-area set-drawn-item-position! + drawn-item-widgets set-drawn-item-widgets! + + add-box-item set-box-item-size! + set-box-item-pos-size! set-box-item-shadow! + + add-hline-item set-hline-item-size! + add-vline-item set-vline-item-size! + + add-text-item text-item-text set-text-item-text! + text-item? text-item-xy-to-index + call-with-text-item-grapheme-rect + + add-image-item-from-file + + image-item-area-updated image-item-area-prepared + image-item-size-prepared)) + +(define-package (gtk event-viewer) + (parent (gtk)) + (files "gtk-ev") + (export () + gtk-event-viewer)) + +(define-package (gtk demo) + (parent (gtk)) + (files "demo") + (import (gtk layout) + scm-layout-event) + (export () + scm-layout-demo)) \ No newline at end of file diff --git a/src/gtk/gtk.scm b/src/gtk/gtk.scm new file mode 100644 index 000000000..31bca4a3a --- /dev/null +++ b/src/gtk/gtk.scm @@ -0,0 +1,334 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Core utilities. +;;; package: (gtk) + + +(c-include "gtk") + +(define (bit-and . numbers) + (bit-string->unsigned-integer + (fold-left + (lambda (bits num) + (let ((bits2 (unsigned-integer->bit-string 32 num))) + (bit-string-and! bits bits2) + bits)) + (signed-integer->bit-string 32 -1) + numbers))) + +(define (bit-or . numbers) + (bit-string->unsigned-integer + (fold-left + (lambda (bits num) + (let ((bits2 (unsigned-integer->bit-string 32 num))) + (bit-string-or! bits bits2) + bits)) + (unsigned-integer->bit-string 32 0) + numbers))) + + +;;;; Rectangles. + +(define-structure (rect (constructor make-rect (#!optional x y width height)) + (print-procedure + (standard-unparser-method 'RECT + (lambda (rect port) + (write-string + (let ((x (number->string (rect-x rect))) + (y (number->string (rect-y rect))) + (w (number->string (rect-width rect))) + (h (number->string (rect-height rect)))) + (string-append " "w"x"h" at "x","y)) + port))))) + (x #f) (y #f) (width #f) (height #f)) + +(define-integrable (set-rect! rect x y width height) + (set-rect-x! rect x) + (set-rect-y! rect y) + (set-rect-width! rect width) + (set-rect-height! rect height)) + +(define-integrable (set-rect-pos! rect x y) + (set-rect-x! rect x) + (set-rect-y! rect y)) + +(define-integrable (set-rect-size! rect width height) + (set-rect-width! rect width) + (set-rect-height! rect height)) + +(define-integrable (rect-nominal? rect) + ;; An integer in every slot. + (and (integer? (rect-x rect)) + (integer? (rect-y rect)) + (integer? (rect-width rect)) + (integer? (rect-height rect)))) + +;;; The rest of these procedures assume a "nominal" rectangle. + +(define-integrable (rect-max-y rect) (int:+ (rect-y rect) (rect-height rect))) +(define-integrable (rect-max-x rect) (int:+ (rect-x rect) (rect-width rect))) +(define-integrable rect-min-x rect-x) +(define-integrable rect-min-y rect-y) + +(define-integrable (call-with-rect-bounds rect receiver) + ;; Tail-calls RECEIVER with the RECT's minx, maxx, miny and maxy (in + ;; that order). Assumes RECT is nominal. + (let ((x (rect-x rect)) + (y (rect-y rect)) + (width (rect-width rect)) + (height (rect-height rect))) + (receiver x (int:+ x width) y (int:+ y height)))) + +(define-integrable (int:max integer1 integer2) + (if (int:> integer1 integer2) integer1 integer2)) +(define-integrable (int:min integer1 integer2) + (if (int:< integer1 integer2) integer1 integer2)) + +(define-integrable (point-in-rect? x y rect) + (call-with-rect-bounds rect + (lambda (min-x max-x min-y max-y) + (and (int:<= min-x x) (int:<= x max-x) + (int:<= min-y y) (int:<= y max-y))))) + +(define-integrable (rect-intersect? rect1 rect2) + ;; Useful when you do not need to cons a new rect. + (call-with-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (call-with-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (cond ((int:< max-x1 min-x2) #f) + ((int:< max-y1 min-y2) #f) + ((int:< max-x2 min-x1) #f) + ((int:< max-y2 min-y1) #f) + (else #t))))))) + +(define (rect-intersection rect1 rect2) + ;; Returns #f if RECT1 and RECT2 do not intersect, else returns a + ;; new rect -- the intersection. Assumes both rectangles are + ;; nominal. + (call-with-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (call-with-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (cond ((int:< max-x1 min-x2) #f) + ((int:< max-y1 min-y2) #f) + ((int:< max-x2 min-x1) #f) + ((int:< max-y2 min-y1) #f) + (else + (let ((min-x (int:max min-x1 min-x2)) + (min-y (int:max min-y1 min-y2)) + (max-x (int:min max-x1 max-x2)) + (max-y (int:min max-y1 max-y2))) + (make-rect min-x min-y + (int:- max-x min-x) + (int:- max-y min-y)))))))))) + +(define (window-intersection window item) + ;; Returns #f if WINDOW and ITEM do not intersect, else returns a + ;; new rect -- the intersection *translated* to WINDOW's coords. + ;; Assumes both rectangles are nominal. + (call-with-rect-bounds window + (lambda (window-x-start window-x-end window-y-start window-y-end) + (call-with-rect-bounds item + (lambda (item-x-start item-x-end item-y-start item-y-end) + (cond ((< window-x-end item-x-start) #f) + ((< window-y-end item-y-start) #f) + ((< item-x-end window-x-start) #f) + ((< item-y-end window-y-start) #f) + (else + (let ((x (int:max window-x-start item-x-start)) + (y (int:max window-y-start item-y-start)) + (x-end (int:min window-x-end item-x-end)) + (y-end (int:min window-y-end item-y-end))) + (make-rect (int:- x window-x-start) + (int:- y window-y-start) + (int:- x-end x) + (int:- y-end y)))))))))) + +(define (gdk-rectangle #!optional x y width height) + (let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|))) + (if (default-object? x) alien + (begin + (C->= alien "GdkRectangle x" (check-integer x)) + (if (default-object? y) alien + (begin + (C->= alien "GdkRectangle y" (check-integer y)) + (if (default-object? width) alien + (begin + (C->= alien "GdkRectangle width" (check-integer width)) + (if (default-object? height) alien + (begin + (C->= alien "GdkRectangle height" + (check-integer height)) + alien)))))))))) + +(define (gdk-rectangle-from-rect rect) + (gdk-rectangle (rect-x rect) (rect-y rect) + (rect-width rect) (rect-height rect))) + +(define-integrable (check-integer obj) + (if (integer? obj) obj + (ferror "not an integer: "obj))) + + +;;;; Ferror + +(define condition-type:ferror + (make-condition-type + 'FORMATTED-ERROR + condition-type:error + '(ARGS) + (lambda (condition port) + (write-string ";Error: " port) + (for-each (lambda (arg) + (if (string? arg) + (write-string arg port) + (write arg port))) + (access-condition condition 'ARGS)) + (newline port)))) + +(define ferror + (let ((signal (condition-signaller condition-type:ferror '(ARGS) + standard-error-handler))) + (named-lambda (ferror . args) + (call-with-current-continuation + (lambda (continuation) + (with-restart + 'USE-VALUE ;name + "Return a value from the call to ferror." ;reporter + continuation ;effector + (lambda () ;interactor + (values (prompt-for-evaluated-expression + "Value to return from ferror"))) + (lambda () ;thunk + (signal args)))))))) + +(define condition-type:fwarn + (make-condition-type + 'FORMATTED-WARNING + condition-type:warning + '(ARGS) + (lambda (condition port) + (write-string ";Warning: " port) + (for-each (lambda (arg) + (if (string? arg) + (write-string arg port) + (write arg port))) + (access-condition condition 'ARGS)) + (newline port)))) + +(define fwarn + (let ((signal (condition-signaller condition-type:fwarn '(ARGS) + standard-warning-handler))) + (named-lambda (fwarn . args) + (with-simple-restart 'MUFFLE-WARNING "Ignore warning." + (lambda () (signal args)))))) + + +;;;; Pango + +(define (pango-rectangle #!optional x y width height) + (if (default-object? x) + (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|) + (let ((rect (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|))) + (C->= rect "PangoRectangle x" x) + (C->= rect "PangoRectangle y" y) + (C->= rect "PangoRectangle width" width) + (C->= rect "PangoRectangle height" height) + rect))) + +(define-integrable (pangos->pixels pango-units) + (quotient (int:+ pango-units 512) 1024)) + +(define-integrable (pixels->pangos pixel-units) + (* pixel-units 1024)) + +(define (pango-font-families widget) + (let ((PangoContext (make-alien '|PangoContext|))) + (C-call "gtk_widget_get_pango_context" PangoContext + (gobject-alien widget)) + (pango-context-list-families PangoContext))) + +(define (pango-context-list-families PangoContext) + (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFamily|)))) + (count-arg (malloc (C-sizeof "int") 'int))) + (C-call "pango_context_list_families" PangoContext data-arg count-arg) + (let ((data (C-> data-arg "*" (make-alien '(* |PangoFontFamily|)))) + (count (C-> count-arg "int"))) + (free data-arg) (free count-arg) + (let* ((scan (copy-alien data)) + (family (make-alien '|PangoFontFamily|)) + (alist + (let loop ((i 0) (entries '())) + (if (fix:< i count) + (begin + (C-> scan "*" family) + (alien-byte-increment! scan (C-sizeof "*")) + (loop (fix:1+ i) + (cons + (cons* (pango-font-family-get-name family) + (pango-font-family-is-monospace? family) + (pango-font-family-faces family)) + entries))) + entries)))) + (C-call "g_free" data) + alist)))) + +(define (pango-font-family-get-name PangoFontFamily) + (let ((name (make-alien '(const char)))) + (C-call "pango_font_family_get_name" name PangoFontFamily) + (c-peek-cstring name))) + +(define (pango-font-family-is-monospace? PangoFontFamily) + (not (fix:zero? (C-call "pango_font_family_is_monospace" PangoFontFamily)))) + +(define (pango-font-family-faces PangoFontFamily) + (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFace|)))) + (count-arg (malloc (C-sizeof "int") 'int))) + (C-call "pango_font_family_list_faces" PangoFontFamily data-arg count-arg) + (let ((data (C-> data-arg "*" (make-alien '(* |PangoFontFace|)))) + (count (C-> count-arg "int"))) + (free data-arg) (free count-arg) + (let* ((scan (copy-alien data)) + (face (make-alien '|PangoFontFace|)) + (faces + (let loop ((i 0) (faces '())) + (if (fix:< i count) + (begin + (C-> scan "*" face) + (alien-byte-increment! scan (C-sizeof "*")) + (loop (fix:1+ i) + (cons + (pango-font-face-get-name face) + faces))) + faces)))) + (C-call "g_free" data) + faces)))) + +(define (pango-font-face-get-name PangoFontFace) + (let ((name (make-alien '(const char)))) + (C-call "pango_font_face_get_face_name" name PangoFontFace) + (c-peek-cstring name))) \ No newline at end of file diff --git a/src/gtk/hello.scm b/src/gtk/hello.scm new file mode 100644 index 000000000..3ca0d753e --- /dev/null +++ b/src/gtk/hello.scm @@ -0,0 +1,37 @@ +#| -*-Scheme-*- + +$Id: $ + +This is Havoc Pennington's Hello World example from GGAD, nicely wrapped. |# + +(declare (usual-integrations)) + +(C-include "gtk") + +(define (hello) + (let ((window (gtk-window-new 'toplevel)) + (button (gtk-button-new)) + (label (gtk-label-new "Hello, World!"))) + (gtk-container-add button label) + (gtk-container-add window button) + (gtk-window-set-title window "Hello") + (gtk-container-set-border-width button 10) + (let ((counter 0)) + (g-signal-connect window (C-callback "delete_event") + (lambda (w e) + (outf-console ";Delete me "(- 2 counter)" times.\n") + (set! counter (1+ counter)) + ;; Three or more is the charm. + (if (> counter 2) 0 1))) + (g-signal-connect button (C-callback "clicked") + (lambda (w) + (if (= counter 1) + (begin + (outf-console "\n;Erroring in "(current-thread)"...\n") + (error "Testing error handling."))) + (let ((text (gtk-label-get-text label))) + (gtk-label-set-text + label (list->string (reverse! (string->list text))))) + unspecific))) + (gtk-widget-show-all window) + window)) \ No newline at end of file diff --git a/src/gtk/load.scm b/src/gtk/load.scm new file mode 100644 index 000000000..014bfb064 --- /dev/null +++ b/src/gtk/load.scm @@ -0,0 +1,11 @@ +#| -*-Scheme-*- + +$Id: $ + +Load the Gtk option. |# + +(load-option 'SOS) +(with-loader-base-uri (system-library-uri "gtk/") + (lambda () + (load-package-set "gtk"))) +(add-subsystem-identification! "Gtk" '(0 1)) \ No newline at end of file diff --git a/src/gtk/main.scm b/src/gtk/main.scm new file mode 100644 index 000000000..292fecc3d --- /dev/null +++ b/src/gtk/main.scm @@ -0,0 +1,105 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Main Loop Hack +;;; package: (gtk main) + + +(c-include "gtk") + +(define-syntax ucode-primitive + (sc-macro-transformer + (lambda (form environment) + environment + (apply make-primitive-procedure (cdr form))))) + +(define (initialize-package!) + (let ((processor hook/process-command-line)) + (set! hook/process-command-line + (lambda (line) + (processor (list->vector (gtk-init (vector->list line)))) + (gtk-main+)))) + (gtk-init *unused-command-line*) + (gtk-main+)) + +(define (gtk-init args) + ;; Call gtk_init_check. Signals an error if gtk_init_check returns 0. + ;; Returns a list of unused ARGS. + (let ((arg-count (guarantee-list-of-type->length + args string? "list of commandline arguments (strings)" + 'GTK-INIT)) + (vars-size (+ (C-sizeof "int") ;gtk_init_check return var + (C-sizeof "* * char")))) ;gtk_init_check return var + (let* ((vector-size + (* (C-sizeof "* char") (+ arg-count 1))) ; null terminated vector + (total-size + (+ vars-size vector-size + (fold-left (lambda (sum arg) + (+ sum (string-length arg) 1)) ;null terminated + 0 args))) + (bytes (malloc total-size #f)) + (vector (alien-byte-increment bytes vars-size)) + (arg-scan (alien-byte-increment vector vector-size)) + (vector-scan (copy-alien vector)) + (count-var bytes) + (vector-var (alien-byte-increment count-var (C-sizeof "int")))) + (for-each (lambda (arg) + (c-poke-pointer! vector-scan arg-scan) + (c-poke-string! arg-scan arg)) + args) + (C->= count-var "int" arg-count) + (C->= vector-var "* * char" vector) + (if (fix:zero? (C-call "gtk_init_check" count-var vector-var)) + (error "Could not initialize Gtk.") + (let ((new-argc (C-> count-var "int"))) + (C-> vector-var "* * char" vector-scan) + (let ((new-args + (let loop ((i 0)(args '())) + (if (fix:< i new-argc) + (loop (fix:1+ i) + (cons (c-peek-cstringp! vector-scan) args)) + (reverse! args))))) + (free bytes) + new-args)))))) + +(define (gtk-main+) + ;; Establishes a GMainLoop in which scheme is an idle task. + (load-library-object-file "prgtkio" #t) + (without-interrupts + (lambda () + ((ucode-primitive gtk-main+)) + (create-gtk-thread)))) + +(define (gtk-main+-quit) + ;; Sortof does the opposite of gtk-main+. + (without-interrupts + (lambda () + (kill-gtk-thread) + ((ucode-primitive gtk-main+-quit))))) + +(define gtk-time-slice-window? (ucode-primitive gtk-time-slice-window? 0)) +(define gtk-time-slice-window! (ucode-primitive gtk-time-slice-window! 1)) +(define gtk-select-trace? (ucode-primitive gtk-select-trace? 0)) +(define gtk-select-trace! (ucode-primitive gtk-select-trace! 1)) \ No newline at end of file diff --git a/src/gtk/pango-cairo.scm b/src/gtk/pango-cairo.scm new file mode 100644 index 000000000..7a6e9b935 --- /dev/null +++ b/src/gtk/pango-cairo.scm @@ -0,0 +1,59 @@ +#| -*-Scheme-*- + +This is example 1 from section "Cairo Rendering" of the "Pango +Reference Manual for Pango 1.18.3". |# + +(define (pango-cairo #!optional filename) + + (define pi (* 4 (atan 1 1))) + (define radius 150) + (define n_words 10) + (define font "Sans Bold 27") + + (define (draw-text cr) + (let ((layout (make-alien '|PangoLayout|)) + (extent (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|)) + (desc (make-alien '|PangoFontDescription|))) + ;; Center coordinates on the middle of the region we are drawing + (C-call "cairo_translate" cr radius radius) + ;; Create a PangoLayout, set the font and text + (C-call "pango_cairo_create_layout" layout cr) + (C-call "pango_layout_set_text" layout "Text" 4) + (C-call "pango_font_description_from_string" desc font) + (C-call "pango_layout_set_font_description" layout desc) + (C-call "pango_font_description_free" desc) + ;; Draw the layout N_WORDS times in a circle + (do ((i 0 (1+ i))) + ((fix:= i n_words)) + (C-call "cairo_save" cr) + (let* ((angle (* 360. (/ i n_words))) + ;; Gradient from red at angle == 60 to blue at angle == 240 + (red (/ (+ 1. (cos (* (- angle 60.) (/ pi 180.)))) 2.))) + (C-call "cairo_set_source_rgb" cr red 0 (- 1. red)) + (C-call "cairo_rotate" cr (* angle (/ pi 180.))) + ;; Inform Pango to re-layout the text with the new transformation + (C-call "pango_cairo_update_layout" cr layout) + (C-call "pango_layout_get_pixel_extents" layout 0 extent) + (C-call "cairo_move_to" cr + (- (/ (C-> extent "PangoRectangle width") 2)) + (- radius)) + (C-call "pango_cairo_show_layout" cr layout) + (C-call "cairo_restore" cr))) + (C-call "g_object_unref" layout) + (free extent))) + + (let ((surface (make-alien '|cairo_surface_t|)) + (cr (make-alien '|cairo_t|)) + (filename (if (default-object? filename) "pango-cairo.png" filename))) + (C-call "cairo_image_surface_create" surface + (C-enum "CAIRO_FORMAT_ARGB32") + (* 2 radius) (* 2 radius)) + (C-call "cairo_create" cr surface) + (C-call "cairo_set_source_rgb" cr 1.0 1.0 1.0) + (C-call "cairo_paint" cr) + (draw-text cr) + (C-call "cairo_destroy" cr) + (let ((status (C-call "cairo_surface_write_to_png" surface filename))) + (C-call "cairo_surface_destroy" surface) + (if (not (= status (C-enum "CAIRO_STATUS_SUCCESS"))) + (ferror "Could not save png to '"filename"'."))))) \ No newline at end of file diff --git a/src/gtk/scm-layout.scm b/src/gtk/scm-layout.scm new file mode 100644 index 000000000..b0ce10865 --- /dev/null +++ b/src/gtk/scm-layout.scm @@ -0,0 +1,920 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; A implementing a scrollable GtkDrawingArea-like widget. +;;; package: (gtk layout) + +(declare (usual-integrations)) + + +(c-include "gtk") + +(define-class ( (constructor make-scm-layout ())) + () + + ;; Our window, a GdkWindow alien, and its geometry (allocation). + ;; Until realized, these are null and #f (x, y, width and height). + ;; If realized, they are non-null and fixnums (respectively). + (window define accessor + initializer (lambda () (make-alien '|GdkWindow|))) + (geometry define accessor initializer make-rect) + + (vadjustment define standard initial-value #f) + (hadjustment define standard initial-value #f) + + ;; Scrollable area (drawing size), in logical device coords. + ;; The rectangle contains integers (or #f if uninitialized). + (scrollable-area define accessor + initializer (lambda () (make-rect 0 0 100 100))) + + ;; Scroll offset and window size (on-screen area). + ;; The rectangle contains integers (or #f if uninitialized). + ;; The width and height should match the window geometry. + (on-screen-area define accessor + initializer (lambda () (make-rect 0 0 100 100))) + + ;; The drawing. + (drawing define standard + modifier %set-scm-layout-drawing! + initial-value #f)) + +(define (scm-layout-new width height) + (let ((w (check-non-negative-fixnum width)) + (h (check-non-negative-fixnum height)) + (layout (make-scm-layout))) + (let ((alien (gobject-alien layout))) + (C->= alien "GtkWidget requisition width" w) + (C->= alien "GtkWidget requisition height" h)) + (set-scm-widget-size-request! layout (scm-layout-size-request layout)) + (set-scm-widget-size-allocate! layout (scm-layout-size-allocate layout)) + (set-scm-widget-realize! layout (scm-layout-realize layout)) + (set-scm-widget-event! layout (scm-layout-event layout)) + (set-scm-widget-set-scroll-adjustments! + layout (scm-layout-set-scroll-adjustments layout)) + layout)) + +(define (set-scm-layout-size! widget width height) + ;; Tells WIDGET to (re)request the given WIDTH and HEIGHT in pixels. + (let ((w (check-non-negative-fixnum width)) + (h (check-non-negative-fixnum height)) + (alien (check-scm-layout-alien widget))) + (let ((rw (C-> alien "GtkWidget requisition width")) + (rh (C-> alien "GtkWidget requisition height"))) + (if (not (and (fix:= w rw) (fix:= h rh))) + (begin + (if (not (fix:= w rw)) + (C->= alien "GtkWidget requisition width" w)) + (if (not (fix:= h rh)) + (C->= alien "GtkWidget requisition height" h)) + (if (not (alien-null? (scm-layout-window widget))) ;;realized + (C-call "gtk_widget_queue_resize" alien))))))) + +(define (set-scm-layout-scroll-size! widget width height) + ;; Tells WIDGET to adjust its scrollable area. Notifies any + ;; scrollbars. + (set-rect-size! (scm-layout-scrollable-area widget) width height) + (adjust-adjustments widget)) + +(define (set-scm-layout-scroll-pos! widget x y) + (let ((xI (check-non-negative-integer x)) + (yI (check-non-negative-integer y)) + (window-area (scm-layout-on-screen-area widget)) + (alien-window (scm-layout-window widget))) + (let ((xW (rect-x window-area)) (yW (rect-y window-area))) + (set-rect-pos! window-area xI yI) + (adjust-adjustments widget) + + (if (not (alien-null? alien-window)) + (let ((dx (int:- xI xW)) (dy (int:- yI yW))) + (if (not (or (int:zero? dx) (int:zero? dy))) + ;; If more than 25% will remain onscreen, scroll; else jump. + (let ((width (rect-width window-area)) + (height (rect-height window-area))) + (if (< 0.25 (/ (* dx dy) (* width height))) + ;; Scroll. + (C-call "gdk_window_scroll" alien-window + (int:* -1 dx) (int:* -1 dy)) + ;; Jump. + (C-call "gtk_widget_queue_draw_area" + (gobject-alien widget) 0 0 width height)) + (C-call "gdk_window_process_updates" alien-window 0)))))))) + +(define (set-scm-layout-drawing! widget drawing) + (let ((old (scm-layout-drawing widget)) + (new (check-drawing drawing)) + (alien (check-scm-layout-alien widget))) + (if old (drawing-remove-widget! old widget)) + (%set-scm-layout-drawing! widget new) + (drawing-add-widget! new widget) + (let ((a (drawing-area new))) + (set-scm-layout-scroll-size! widget (rect-width a) (rect-height a))) + (if (not (alien-null? (scm-layout-window widget))) ;;realized + (let ((geo (scm-layout-geometry widget))) + (C-call "gtk_widget_queue_draw_area" alien + 0 0 (rect-width geo) (rect-height geo)))))) + +(define-integrable (check-scm-layout-alien obj) + (if (scm-layout? obj) (gobject-alien obj) + (ferror "Not a instance: "obj))) + + +;;;; Callback handlers. + +(define (scm-layout-size-request widget) + (named-lambda (scm-layout::size-request GtkWidget GtkRequisition) + GtkWidget ;;Ignored. + +;;; (%trace ";((scm-layout-size-request "widget") "GtkWidget" " +;;; GtkRequisition")\n") + + (let ((alien (gobject-alien widget))) + (let ((width (C-> alien "GtkWidget requisition width")) + (height(C-> alien "GtkWidget requisition height"))) + (C->= GtkRequisition "GtkRequisition width" width) + (C->= GtkRequisition "GtkRequisition height" height) + (%trace "; Requisition: "widget"x"height" from "widget"\n") + )))) + +(define (scm-layout-size-allocate widget) + (named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation) + +;;; (%trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n") + + (let ((x (C-> GtkAllocation "GtkAllocation x")) + (y (C-> GtkAllocation "GtkAllocation y")) + (width (C-> GtkAllocation "GtkAllocation width")) + (height (C-> GtkAllocation "GtkAllocation height")) + (rect (scm-layout-geometry widget))) + (set-rect! rect x y width height) + (%trace "; Allocation: "rect" to "widget"\n") + (set-rect-size! (scm-layout-on-screen-area widget) width height) + ;; For the random toolkit GtkWidget method. + (C->= GtkWidget "GtkWidget allocation x" x) + (C->= GtkWidget "GtkWidget allocation y" y) + (C->= GtkWidget "GtkWidget allocation width" width) + (C->= GtkWidget "GtkWidget allocation height" height) + (let ((window (scm-layout-window widget))) + (if (not (alien-null? window)) ;;realized + (begin + (C-call "gdk_window_move_resize" window x y width height) + (adjust-adjustments widget))))))) + +(define (scm-layout-realize widget) + (named-lambda (scm-layout::realize GtkWidget) + +;;; (%trace ";((scm-layout-realize "widget") "GtkWidget")\n") + + ;; ScmWidget automatically sets GTK_REALIZED. + + (let ((attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) + (main-GdkWindow (scm-layout-window widget)) + (GtkStyle (C-> GtkWidget "GtkWidget style")) + (parent-GdkWindow (make-alien '|GdkWindow|)) + (GdkVisual (make-alien '|GdkVisual|)) + (GdkColormap (make-alien '|GdkColormap|))) + + ;; Create widget window. + + (C-call "gtk_widget_get_visual" GdkVisual GtkWidget) + (check-!null GdkVisual "Could not get GdkVisual.") + (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) + (check-!null GdkColormap "Could not get GdkColormap.") + + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (let ((r (scm-layout-geometry widget))) + ;; Just assume geometry has been allocated?! + (C->= attr "GdkWindowAttr x" (rect-x r)) + (C->= attr "GdkWindowAttr y" (rect-y r)) + (C->= attr "GdkWindowAttr width" (rect-width r)) + (C->= attr "GdkWindowAttr height" (rect-height r))) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + (C->= attr "GdkWindowAttr visual" GdkVisual) + (C->= attr "GdkWindowAttr colormap" GdkColormap) + (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) + + (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) + (check-!null parent-GdkWindow "Could not get parent.") + + (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr + (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") + (C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP"))) + (check-!null main-GdkWindow "Could not create main window.") + (C->= GtkWidget "GtkWidget window" main-GdkWindow) + (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) + (%trace "; Realize "widget" on "main-GdkWindow"\n") + + ;; Style + + (C-call "gtk_style_attach" GtkStyle + (C-> GtkWidget "GtkWidget style") main-GdkWindow) + (C->= GtkWidget "GtkWidget style" GtkStyle) + (C-call "gtk_style_set_background" + GtkStyle main-GdkWindow (C-enum "GTK_STATE_NORMAL")) + unspecific))) + +(define (scm-layout-event widget) + (named-lambda (scm-layout::event GtkWidget GdkEvent) + GtkWidget widget ;;Ignored, thus far. +;;; (%trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n") + + (let ((type (C-> GdkEvent "GdkEvent any type"))) + + (cond ((fix:= type (C-enum "GDK_EXPOSE")) + (let ((window (C-> GdkEvent "GdkEvent any window")) + (x (C-> GdkEvent "GdkEventExpose area x")) + (y (C-> GdkEvent "GdkEventExpose area y")) + (width (C-> GdkEvent "GdkEventExpose area width")) + (height (C-> GdkEvent "GdkEventExpose area height")) + ;;(count (C-> GdkEvent "GdkEventExpose count")) + (drawing (scm-layout-drawing widget)) + (widget-window (scm-layout-window widget))) + (cond ((not (alien=? window widget-window)) + (%trace "; Expose a strange window "window + " (not "widget-window").\n")) + (drawing + (let* ((scroll (scm-layout-on-screen-area widget)) + (offx (rect-x scroll)) + (offy (rect-y scroll))) + (%trace "; Expose area "widget"x"height"+"x"+"y + " of "widget".\n") + (drawing-expose drawing widget window + (make-rect (int:+ x offx) (int:+ y offy) + width height))))))) + + (else + (let ((name (C-enum "GdkEventType" type)) + (addr (alien/address-string + (C-> GdkEvent "GdkEvent any window")))) + (%trace "; "name" on "GtkWidget" (window 0x"addr").\n"))))) + 1 ;;TRUE -- "handled" -- done. + )) + +(define (scm-layout-set-scroll-adjustments widget) + (named-lambda (scm-layout::set-scroll-adjustments + GtkWidget hGtkAdjustment vGtkAdjustment) + GtkWidget ;;Ignored. + +;;; (%trace ";((scm-layout-set-scroll-adjustments "widget")" +;;; " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n") + (let ((haddr (alien/address-string hGtkAdjustment)) + (vaddr (alien/address-string vGtkAdjustment))) + (%trace "; Adjustments: 0x"haddr" 0x"vaddr"\n")) + (connect-adjustment (scm-layout-hadjustment widget) hGtkAdjustment + widget set-scm-layout-hadjustment!) + (connect-adjustment (scm-layout-vadjustment widget) vGtkAdjustment + widget set-scm-layout-vadjustment!) + (adjust-adjustments widget) + 0 ;; What does this mean? + )) + +(define (connect-adjustment old-adjustment new-alien widget setter) + ;; Disconnects OLD-ADJUSTMENT (if any) and applies SETTER to WIDGET + ;; and the new adjustment (if any). + + (let ((old-alien (and old-adjustment (gobject-alien old-adjustment)))) + ;; Disconnect. + (cond ((not old-adjustment)) + ((alien=? new-alien old-alien)) + (else + (gobject-unref old-adjustment))) + ;; Connect. + (cond ((alien-null? new-alien)) + ((and old-adjustment (alien=? new-alien old-alien))) + (else + (let ((new-adjustment (make-gtk-adjustment))) + (copy-alien-address! (gobject-alien new-adjustment) new-alien) + (C-call "g_object_ref_sink" new-alien new-alien) + (setter widget new-adjustment) + (g-signal-connect + new-adjustment (C-callback "value_changed") + (scm-layout-adjustment-value-changed widget new-adjustment))))))) + +(define (scm-layout-adjustment-value-changed widget adjustment) + (named-lambda (scm-layout::adjustment-value-changed GtkAdjustment) + GtkAdjustment ;;Ignored. + +;;; (%trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")" +;;; " "GtkAdjustment")\n") + + (let ((alien-widget (gobject-alien widget)) + (alien-window (scm-layout-window widget)) + (window-area (scm-layout-on-screen-area widget)) + (vadjustment (scm-layout-vadjustment widget)) + (hadjustment (scm-layout-hadjustment widget)) + (alien-adjustment (gobject-alien adjustment))) + (let ((value + (floor->exact (C-> alien-adjustment "GtkAdjustment value")))) + (cond ((eq? adjustment vadjustment) + (let* ((y (rect-y window-area)) + (dy (int:- value y))) + (%trace "; Vadjustment to "value" (dy:"dy")\n") + (if (not (int:zero? dy)) + (let ((width (rect-width window-area))) + (set-rect-y! window-area value) + (if (> (abs dy) (* 0.90 width)) + (let ((height (rect-height window-area))) + (if (not (alien-null? alien-window)) ;;realized + (C-call "gtk_widget_queue_draw_area" + alien-widget 0 0 width height))) + (C-call "gdk_window_scroll" + alien-window 0 (int:* -1 dy))) + (C-call "gdk_window_process_updates" alien-window 0))))) + ((eq? adjustment hadjustment) + (let* ((x (rect-x window-area)) + (height (rect-height window-area)) + (dx (int:- value x))) + (%trace "; Hadjustment to "value" (dx:"dx")\n") + (if (not (int:zero? dx)) + (begin + (set-rect-x! window-area value) + (if (> (abs dx) (* 0.90 height)) + (let ((width (rect-width window-area))) + (if (not (alien-null? alien-window)) ;;realized + (C-call "gtk_widget_queue_draw_area" + alien-widget 0 0 width height))) + (C-call "gdk_window_scroll" + alien-window (int:* -1 dx) 0)) + (C-call "gdk_window_process_updates" alien-window 0))))) + (else (fwarn "Unexpected adjustment "adjustment + " (not "vadjustment" nor "hadjustment")."))))))) + +(define (adjust-adjustments widget) + ;; Called when the widget gets new adjustments or its size or + ;; scrollable area changes. + + (let ((hadj (scm-layout-hadjustment widget)) + (vadj (scm-layout-vadjustment widget))) + (if (and vadj (not (gobject-finalized? vadj))) + (let* ((total-height (rect-height (scm-layout-scrollable-area widget))) + (scroll (scm-layout-on-screen-area widget)) + (window-height (rect-height scroll)) + (value (rect-y scroll))) + (set-gtk-adjustment! + vadj value ;value + 0 total-height ;lower (top), upper (bottom) + window-height 10 ;page-size, step-increment + (- window-height ;page-increment + (* 0.05 window-height))))) + (if (and hadj (not (gobject-finalized? hadj))) + (let* ((total-width (rect-width (scm-layout-scrollable-area widget))) + (scroll (scm-layout-on-screen-area widget)) + (window-width (rect-width scroll)) + (value (rect-x scroll))) + (set-gtk-adjustment! + hadj value + 0 total-width + window-width 10 + (- window-width (* 0.05 window-width))))))) + + +;;;; Drawings + +(define-class ( (constructor () 1)) + () + (area define accessor initializer (lambda () (make-rect 0 0 0 0))) + (widgets define standard initial-value '()) + (display-list define standard initial-value '())) + +(define-method initialize-instance ((d ) widget) + (set-drawing-widgets! d (list widget))) + +(define (check-drawing obj) + (if (drawing? obj) obj + (ferror "Not a instance: "obj))) + +(define (drawing-damage item #!optional rect) + ;; Invalidates any widget areas affected by RECT in ITEM. By + ;; default, RECT is ITEM's entire area. +;;; (%trace ";(drawing-damage "drawing" "item")\n") + + (let ((area (if (default-object? rect) + (drawn-item-area item) + rect)) + (drawing (drawn-item-drawing item))) + (if (not (rect-nominal? area)) + (ferror "Cannot damage an item ("item") with an ill-defined area.")) + (if (and (not (int:zero? (rect-width area))) + (not (int:zero? (rect-height area)))) + (for-each + (lambda (widget) + (let ((intersect (let ((a (scm-layout-on-screen-area widget))) + (and (rect-nominal? a) + (window-intersection a area))))) + (if (and intersect (not (gtk-object-destroyed? widget))) + (C-call "gtk_widget_queue_draw_area" + (gobject-alien widget) + (rect-x intersect) (rect-y intersect) + (rect-width intersect) (rect-height intersect))))) + (let ((widgets (drawn-item-widgets item))) + (if (eq? #f widgets) + (drawing-widgets drawing) + widgets)))))) + +(define-integrable (drawing-pick-list drawing widget x y) + ;; Return a list of s in DRAWING that are tangible in + ;; WIDGET at (X,Y). + + (keep-matching-items (drawing-display-list drawing) + (lambda (item) + (let ((widgets (drawn-item-widgets item)) + (area (drawn-item-area item))) + (and (or (eq? widgets #f) + (memq widget widgets)) + (point-in-rect? x y area)))))) + +(define (drawing-expose drawing widget window area) + ;; AREA is in drawing coords. + + (if (rect-nominal? area) + (for-each + (lambda (item) + (let ((item-area (drawn-item-area item)) + (widgets (drawn-item-widgets item))) + (if (and (or (eq? widgets #f) + (memq widget widgets)) + (rect-nominal? item-area) + (rect-intersect? item-area area)) + (drawn-item-expose item widget window area)))) + (drawing-display-list drawing)))) + +(define-generic drawn-item-expose (item widget window expose-area) + ;; Due to the checks in drawing-expose, methods of this generic can + ;; assume expose-area and the draw item's area are well-defined (all + ;; four members are integers), intersecting, and ITEM is visible in + ;; WIDGET. Methods may also assume the widget is realized and its + ;; window's (gc's) clipping is already set. The widget's scroll + ;; offset (on-screen area) is also always well-defined. + ) + +(define (drawing-add-widget! drawing widget) + (if (not (scm-layout? widget)) + (ferror "Not a : "widget)) + (let ((widgets (drawing-widgets drawing))) + (if (not (memq widget widgets)) + (set-drawing-widgets! drawing (cons widget widgets))))) + +(define (drawing-remove-widget! drawing widget) + (if (not (scm-layout? widget)) + (ferror "Not a : "widget)) + (let ((widgets (drawing-widgets drawing))) + (if (not (memq widget widgets)) + (ferror "Widget "widget" not found on list for drawing "drawing".")) + (set-drawing-widgets! drawing (delq! widget widgets)))) + +(define (drawing-add-item! drawing item where) + (cond ((or (eq? #f where) + (eq? 'TOP where)) + (set-drawing-display-list! + drawing (append! (drawing-display-list drawing) (list item)))) + ((eq? 'BOTTOM where) + (set-drawing-display-list! + drawing (cons item (drawing-display-list drawing)))) + (else (ferror "Bad where: "where))) + (drawing-damage item)) + +(define (set-drawing-size! drawing width height) + (let ((w (check-non-negative-integer width)) + (h (check-non-negative-integer height))) + (set-rect-size! (drawing-area drawing) w h) + (for-each + (lambda (widget) (set-scm-layout-scroll-size! widget w h)) + (drawing-widgets drawing)))) + + +;;;; Drawn items. + +(define-class + () + (area define standard initializer (lambda () (make-rect 0 0 0 0))) + (drawing define standard initial-value #f) + ;; #f if the item is visible in all widgets. + ;; Else, a list of widgets in which the item should be drawn. + (widgets define standard modifier %set-drawn-item-widgets! initial-value #f)) + +(define-method initialize-instance ((item ) where) + (drawing-add-item! (drawn-item-drawing item) item where)) + +(define (set-drawn-item-position! item x y) + (let ((area (drawn-item-area item)) + (ix (check-non-negative-integer x)) + (iy (check-non-negative-integer y))) + (let ((curr-x (rect-x area)) + (curr-y (rect-y area)) + (width (rect-width area)) + (height (rect-height area))) + + ;; Two trivial cases, and a general one. + (cond ((and (integer? curr-x) (int:= x curr-x) + (integer? curr-y) (int:= y curr-y)) + unspecific) + ((or (not (integer? width)) (int:zero? width) + (not (integer? height)) (int:zero? height)) + (set-rect-pos! area ix iy)) + (else + (drawing-damage item) + (set-rect-pos! area ix iy) + (drawing-damage item)))))) + +(define (%set-drawn-item-size! item width height) + (let ((area (drawn-item-area item))) + (drawing-damage item) + (set-rect-size! area width height) + (drawing-damage item))) + +(define (set-drawn-item-widgets! item new) + ;; Draw ITEM only on the NEW widgets. If NEW is #f, ITEM will + ;; appear in all views. + (let ((old (drawn-item-widgets item))) + (if (not (equal? old new)) + (begin + (drawing-damage item) + (%set-drawn-item-widgets! item new) + (drawing-damage item))))) + +(define (drawn-item-widget item) + ;; Return a widget that will display the item. + (let* ((drawing (drawn-item-drawing item)) + (widgets (drawing-widgets drawing))) + (if (null? widgets) + (ferror "No widgets display drawing "drawing".") + (car widgets)))) + + +;;;; Simple Items (e.g. the toolkit's gtk_paint_* operators). + +(define-class ( (constructor add-box-item (drawing) 1)) + () + (shadow define standard + accessor %box-item-shadow + modifier %set-box-item-shadow! + initial-value (C-enum "GTK_SHADOW_NONE"))) + +(define-method drawn-item-expose ((item ) widget window area) + area ;;Ignored. Assumed clipping already set. +;;; (%trace "; (Re)Drawing "item" on "widget".\n") + + (let ((widgets (drawn-item-widgets item))) + (if (or (eq? #f widgets) + (memq widget widgets)) + (let ((alien (gobject-alien widget)) + (scroll (scm-layout-on-screen-area widget))) + (let ((scroll-x (rect-x scroll)) + (scroll-y (rect-y scroll)) + (style (C-> alien "GtkWidget style")) + (state (C-enum "GTK_STATE_ACTIVE")) + (area (drawn-item-area item))) + (C-call "gtk_paint_box" + style window state (%box-item-shadow item) + null-alien alien null-alien ;area widget detail + (int:- (rect-x area) scroll-x) + (int:- (rect-y area) scroll-y) + (rect-width area) + (rect-height area))))))) + +(define (set-box-item-size! item width height) + (let ((w (check-non-negative-fixnum width)) + (h (check-non-negative-fixnum height))) + (%set-drawn-item-size! item w h))) + +(define (set-box-item-pos-size! item x y width height) + (let ((area (drawn-item-area item)) + (xI (if (and (integer? x) (not (int:negative? x))) x 0)) + (yI (if (and (integer? y) (not (int:negative? y))) y 0)) + (wI (if (and (fixnum? width) (not (fix:negative? width))) width 0)) + (hI (if (and (fixnum? height) (not (fix:negative? height))) height 0))) + (drawing-damage item) + (set-rect! area xI yI wI hI) + (drawing-damage item))) + +(define (box-item-shadow item) + (case (%box-item-shadow item) + (((C-enum "GTK_SHADOW_NONE")) 'NONE) + (((C-enum "GTK_SHADOW_IN")) 'IN) + (((C-enum "GTK_SHADOW_OUT")) 'OUT) + (((C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN) + (((C-enum "GTK_SHADOW_ETCHED_OUT")) 'ETCHED-OUT))) + +(define (set-box-item-shadow! item type) + (let ((new + (case type + ((NONE) (C-enum "GTK_SHADOW_NONE")) + ((IN) (C-enum "GTK_SHADOW_IN")) + ((OUT) (C-enum "GTK_SHADOW_OUT")) + ((ETCHED-IN) (C-enum "GTK_SHADOW_ETCHED_IN")) + ((ETCHED-OUT) (C-enum "GTK_SHADOW_ETCHED_OUT")) + (else (ferror "Not a shadow type: "type"."))))) + (if (not (fix:= new (%box-item-shadow item))) + (begin + (%set-box-item-shadow! item new) + (drawing-damage item))))) + +(define-class ( (constructor add-hline-item (drawing) 1)) + ()) + +(define-method drawn-item-expose ((item ) widget window area) + area ;;Ignored. Assumed clipping already set. +;;; (%trace "; (Re)Drawing "item" on "widget".\n") + + (let ((widgets (drawn-item-widgets item))) + (if (or (eq? #f widgets) + (memq widget widgets)) + (let ((alien (gobject-alien widget)) + (scroll (scm-layout-on-screen-area widget))) + (let ((scroll-x (rect-x scroll)) + (scroll-y (rect-y scroll)) + (style (C-> alien "GtkWidget style")) + (state (C-enum "GTK_STATE_NORMAL")) + (area (drawn-item-area item))) + (C-call "gtk_paint_hline" + style window state + null-alien alien null-alien ;area widget detail + (int:- (rect-min-x area) scroll-x) + (int:- (rect-max-x area) scroll-x) + (int:- (rect-y area) scroll-y))))))) + +(define (set-hline-item-size! item width) + (let ((w (check-non-negative-fixnum width)) + (hline (check-hline-item item))) + (%set-drawn-item-size! hline w (rect-height (drawn-item-area hline))))) + +(define (check-hline-item obj) + (if (hline-item? obj) obj + (ferror "Not an instance: "obj))) + +(define-class ( (constructor add-vline-item (drawing) 1)) + ()) + +(define-method drawn-item-expose ((item ) widget window area) + area ;;Ignored. Assumed clipping already set. +;;; (%trace "; (Re)Drawing "item" on "widget".\n") + + (let ((widgets (drawn-item-widgets item))) + (if (or (eq? #f widgets) + (memq widget widgets)) + (let ((alien (gobject-alien widget)) + (scroll (scm-layout-on-screen-area widget))) + (let ((scroll-x (rect-x scroll)) + (scroll-y (rect-y scroll)) + (style (C-> alien "GtkWidget style")) + (state (C-enum "GTK_STATE_NORMAL")) + (area (drawn-item-area item))) + (C-call "gtk_paint_vline" + style window state + null-alien alien null-alien ;area widget detail + (int:- (rect-min-y area) scroll-y) + (int:- (rect-max-y area) scroll-y) + (int:- (rect-x area) scroll-x))))))) + +(define (set-vline-item-size! item height) + (let ((h (check-non-negative-fixnum height)) + (vline (check-vline-item item))) + (%set-drawn-item-size! vline (rect-width (drawn-item-area vline)) h))) + +(define (check-vline-item obj) + (if (vline-item? obj) obj + (ferror "Not a instance: "obj))) + + +;;;; Text Items (aka PangoLayouts) + +(define-class ( (constructor add-text-item (drawing) 1)) + () + (pango-layout define accessor + initializer (lambda () (make-alien '|PangoLayout|))) + (text define standard + modifier %set-text-item-text! + initial-value #f)) + +(define-method initialize-instance ((item ) where) + (call-next-method item where) + (add-gc-cleanup item + (text-item-finalize-thunk (text-item-pango-layout item)))) + +(define (text-item-finalize-thunk pango-layout) + ;; Return a thunk closed over PANGO-LAYOUT (NOT the item). + (lambda () + (if (not (alien-null? pango-layout)) + (begin + (C-call "g_object_unref" pango-layout) + (alien-null! pango-layout))))) + +(define-method drawn-item-expose ((item ) widget window area) + area ;;Ignored. Assumed clipping already set. +;;; (%trace "; (Re)Drawing "item" on "widget".\n") + + (let ((widgets (drawn-item-widgets item))) + (if (or (eq? #f widgets) + (memq widget widgets)) + (let ((alien (gobject-alien widget)) + (scroll (scm-layout-on-screen-area widget))) + (let ((scroll-x (rect-x scroll)) + (scroll-y (rect-y scroll)) + (style (C-> alien "GtkWidget style")) + (state (C-> alien "GtkWidget state")) + (area (drawn-item-area item)) + (layout (text-item-pango-layout item))) + (if (not (alien-null? layout)) + (C-call "gtk_paint_layout" + style window state 1 + null-alien alien null-alien ;area widget detail + (int:- (rect-x area) scroll-x) + (int:- (rect-y area) scroll-y) + layout))))))) + +(define (set-text-item-text! text-item text) + (let ((layout (text-item-pango-layout text-item))) + + (drawing-damage text-item) + + (if (alien-null? layout) + (begin + (C-call "gtk_widget_create_pango_layout" layout + (gobject-alien (drawn-item-widget text-item)) text)) + (begin + (C-call "pango_layout_set_text" layout text -1))) + (let ((log-extent (pango-rectangle)) + (ink-extent null-alien)) + (C-call "pango_layout_get_pixel_extents" layout ink-extent log-extent) + (set-rect-size! (drawn-item-area text-item) + (C-> log-extent "GdkRectangle width") + (C-> log-extent "GdkRectangle height")) + (%set-text-item-text! text-item text) + (free log-extent)) + + (drawing-damage text-item) + + unspecific)) + +(define (text-item-xy-to-index item x y) + ;; Assumes (X,Y) is in ITEM's area (all logical dev. coords.). + (let ((layout (text-item-pango-layout item)) + (area (drawn-item-area item))) + (if (not (alien-null? layout)) + (let ((index-alien (malloc (C-sizeof "int") '(* int))) + ;;-> layout coords. + (xL (int:- x (rect-x area))) + (yL (int:- y (rect-y area)))) + (if (fix:= 0 (C-call "pango_layout_xy_to_index" layout + (pixels->pangos xL) (pixels->pangos yL) + index-alien null-alien)) + (begin + (free index-alien) + #f) + (let ((index (C-> index-alien "int"))) + (free index-alien) + index))) + #f))) + +(define (call-with-text-item-grapheme-rect item index receiver) + ;; Calls RECEIVER with the x, y, width and height of the grapheme at + ;; INDEX in ITEM. + (let ((layout (text-item-pango-layout item)) + (rect (pango-rectangle))) + (C-call "pango_layout_index_to_pos" layout index rect) + (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) + (y (pangos->pixels (C-> rect "PangoRectangle y"))) + (width (pangos->pixels (C-> rect "PangoRectangle width"))) + (height (pangos->pixels (C-> rect "PangoRectangle height")))) + (free rect) + (receiver x y width height)))) + + +;;;; Images (aka GdkPixbufLoaders) + +(define-class ( (constructor add-image-item (drawing) 1)) + () + (pixbuf-loader define accessor + initializer make-pixbuf-loader) + (pixbuf define standard initial-value #f)) + +(define-method initialize-instance ((item ) where) + (call-next-method item where) + (let ((loader (image-item-pixbuf-loader item))) + (g-signal-connect loader (C-callback "size_prepared") + (image-item-size-prepared item)) + (g-signal-connect loader (C-callback "area_prepared") + (image-item-area-prepared item)) + (g-signal-connect loader (C-callback "area_updated") + (image-item-area-updated item)))) + +(define (image-item-size-prepared item) + (named-lambda (image-item::size-prepared GdkPixbufLoader width height) + GdkPixbufLoader ;;Ignored. + (%trace "; image-item::size-prepared "item" "width" "height"\n") + + (%set-drawn-item-size! item width height))) + +(define (image-item-area-prepared item) + (named-lambda (image-item::area-prepared GdkPixbufLoader) + GdkPixbufLoader ;;Ignored. + + (let ((loader (image-item-pixbuf-loader item)) + (pixbuf (if (not (image-item-pixbuf item)) + (let ((a (make-alien '|GdkPixbuf|))) + (set-image-item-pixbuf! item a) + a) + (ferror "Image-item "item" already has a pixbuf!")))) + (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf (gobject-alien loader)) + ;; Fill with non-background (non-fg) color? (Pick from a GtkStyle!!!) + (%trace "; image-item::area-prepared "item" ("pixbuf")\n")))) + +(define (image-item-area-updated item) + (named-lambda (image-item::area-updated GdkPixbufLoader x y width height) + GdkPixbufLoader ;;Ignored. + + (let ((rect (make-rect x y width height))) + (%trace "; image-item::area-updated "item" "rect"\n") + (drawing-damage item rect)))) + +(define-method drawn-item-expose ((item ) widget window area) +;;; (%trace "; (Re)Drawing "item" on "widget".\n") + + (let ((widgets (drawn-item-widgets item))) + (if (or (eq? #f widgets) + (memq widget widgets)) + (let ((pixbuf (image-item-pixbuf item))) + (if (and pixbuf (not (alien-null? pixbuf))) + (let ((item-area (drawn-item-area item)) + (scroll (scm-layout-on-screen-area widget)) + (GdkGC* (let ((alien (make-alien '(* |GdkGC|)))) + (C-> (gobject-alien widget) "GtkWidget style" + alien) + (C-> alien "GtkStyle fg_gc" alien) + (C-array-loc! alien "* GdkGC" + (C-enum "GTK_STATE_NORMAL")) + (C-> alien "* GdkGC" alien) + alien))) + (let ((i (rect-intersection item-area area)) + (scroll-x (rect-x scroll)) + (scroll-y (rect-y scroll))) + (C-call "gdk_draw_pixbuf" + window GdkGC* pixbuf + ;; drawing->image + (int:- (rect-x i) (rect-x item-area)) ;src_x + (int:- (rect-y i) (rect-y item-area)) ;src_y + ;; drawing->window + (int:- (rect-x i) scroll-x) ;dest_x + (int:- (rect-y i) scroll-y) ;dest_y + (rect-width i) (rect-height i) + (C-enum "GDK_RGB_DITHER_NONE") + 0 0 ;x_dither, y_dither + )))))))) + +(define (add-image-item-from-file drawing where filename) + ;; WHERE can be 'TOP (or #f) or 'BOTTOM. + (let ((item (add-image-item drawing (check-where where)))) + (load-pixbuf-from-file (image-item-pixbuf-loader item) filename) + item)) + +(define (check-where where) + (cond ((eq? where #f) 'TOP) + ((eq? where 'TOP) 'TOP) + ((eq? where 'BOTTOM) 'BOTTOM) + (else (ferror "The WHERE argument ("where") must be TOP (or #f)" + " or BOTTOM if it is not optional.")))) + +(define (check-non-negative-fixnum obj) + (if (fixnum? obj) + (if (fix:negative? obj) + (ferror "Not a NON-NEGATIVE fixnum: "obj) + obj) + (ferror "Not a non-negative fixnum: "obj))) + +(define (check-non-negative-integer obj) + (if (integer? obj) + (if (int:negative? obj) + (ferror "Not a NON-NEGATIVE integer: "obj) + obj) + (ferror "Not a non-negative integer: "obj))) + +(define (check-!null alien message) + (if (alien-null? alien) + (ferror "scm-layout: "message) + alien)) + +(define %trace? #f) +(define (%trace . objects) + (if %trace? + (apply outf-console objects))) \ No newline at end of file diff --git a/src/gtk/scm-widget.scm b/src/gtk/scm-widget.scm new file mode 100644 index 000000000..d0ba57999 --- /dev/null +++ b/src/gtk/scm-widget.scm @@ -0,0 +1,116 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; A representing a ScmWidget. +;;; package: (gtk widget) + + +(c-include "gtk") + +(define-class ()) + +(define-method initialize-instance ((new )) + ;; Calls scm_widget_new, modifying NEW's alien. + (let ((a (gobject-alien new))) + (C-call "scm_widget_new" a) + (if (alien-null? a) (ferror "Could not create a Scheme widget.")) + (let ((id (register-c-callback + (named-lambda (scm-widget::finalize GObject) + (scm-widget-finalize! GObject))))) + (C->= a "ScmWidget finalize" id) + unspecific))) + +(define (scm-widget-finalize! GObject) + (define (de-register id) + (if (zero? id) unspecific (de-register-c-callback id))) + (de-register + (C-> GObject "ScmWidget finalize")) + (C->= GObject "ScmWidget finalize" 0) + (de-register + (C-> GObject "ScmWidget destroy")) + (C->= GObject "ScmWidget destroy" 0) + (de-register + (C-> GObject "ScmWidget realize")) + (C->= GObject "ScmWidget realize" 0) + (de-register + (C-> GObject "ScmWidget unrealize")) + (C->= GObject "ScmWidget unrealize" 0) + (de-register + (C-> GObject "ScmWidget size_request")) + (C->= GObject "ScmWidget size_request" 0) + (de-register + (C-> GObject "ScmWidget size_allocate")) + (C->= GObject "ScmWidget size_allocate" 0) + (de-register + (C-> GObject "ScmWidget event")) + (C->= GObject "ScmWidget event" 0) + (de-register + (C-> GObject "ScmWidget set_scroll_adjustments")) + (C->= GObject "ScmWidget set_scroll_adjustments" 0) + unspecific) + +(define (set-scm-widget-destroy! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget destroy"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien "ScmWidget destroy" (register-c-callback proc)))) + +(define (set-scm-widget-realize! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget realize"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien "ScmWidget realize" (register-c-callback proc)))) + +(define (set-scm-widget-unrealize! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget unrealize"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien "ScmWidget unrealize" (register-c-callback proc)))) + +(define (set-scm-widget-size-request! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget size_request"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien "ScmWidget size_request" (register-c-callback proc)))) + +(define (set-scm-widget-size-allocate! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget size_allocate"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien "ScmWidget size_allocate" (register-c-callback proc)))) + +(define (set-scm-widget-event! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget event"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien "ScmWidget event" (register-c-callback proc)))) + +(define (set-scm-widget-set-scroll-adjustments! widget proc) + (let* ((alien (gobject-alien widget)) + (id (C-> alien "ScmWidget set_scroll_adjustments"))) + (if (not (zero? id)) (de-register-c-callback id)) + (C->= alien + "ScmWidget set_scroll_adjustments" + (register-c-callback proc)))) \ No newline at end of file diff --git a/src/gtk/scmwidget.c.stay b/src/gtk/scmwidget.c.stay new file mode 100644 index 000000000..f1f1925b6 --- /dev/null +++ b/src/gtk/scmwidget.c.stay @@ -0,0 +1,298 @@ +/* -*-C-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +*/ + +/* The ScmWidget, represented in Scheme by a . */ + +#include +#include "gtk-shim.h" + +static void scm_widget_class_init (ScmWidgetClass* klass); +static void scm_widget_init (ScmWidget* sw); +static void scm_widget_finalize (GObject* object); +static void scm_widget_destroy (GtkObject* object); +static void scm_widget_realize (GtkWidget* widget); +static void scm_widget_unrealize (GtkWidget* widget); +static void scm_widget_size_request (GtkWidget* widget, GtkRequisition* requisition); +static void scm_widget_size_allocate (GtkWidget* widget, GtkAllocation* allocation); +static gint scm_widget_event (GtkWidget* widget, GdkEvent* event); +static void scm_widget_set_scroll_adjustments (GtkWidget* widget, GtkAdjustment *hadj, GtkAdjustment *vadj); + +/* The callbacks in gtk.cdecl. */ +extern void Scm_widget_finalize (int ID, GObject* object); +extern void Scm_widget_destroy (int ID, GtkObject* object); +extern void Scm_widget_realize (int ID, GtkWidget* widget); +extern void Scm_widget_unrealize (int ID, GtkWidget* widget); +extern void Scm_widget_size_request (int ID, GtkWidget* w, GtkRequisition* r); +extern void Scm_widget_size_allocate (int ID, GtkWidget* w, GtkAllocation* a); +extern gint Scm_widget_event (int ID, GtkWidget* widget, GdkEvent* event); +extern void Scm_widget_set_scroll_adjustments (int ID, GtkWidget* widget, GtkAdjustment *hadj, GtkAdjustment *vadj); + +GType +scm_widget_get_type (void) +{ + static GType widget_type = 0; + + if (!widget_type) { + static const GTypeInfo widget_type_info = { + sizeof (ScmWidgetClass), + NULL, /* base_init */ + NULL, /* base_finalize */ + (GClassInitFunc) scm_widget_class_init, + NULL, /* class_finalize */ + NULL, /* class_data */ + sizeof (ScmWidget), + 0, /* n_preallocs */ + (GInstanceInitFunc) scm_widget_init, + NULL /* value_table */ + }; + + widget_type + = g_type_register_static (GTK_TYPE_WIDGET, "ScmWidget", + &widget_type_info, 0); + } + + return widget_type; +} + +static GtkWidgetClass* parent_class = NULL; + +/* VOID:OBJECT,OBJECT (./gtkmarshalers.list:91) */ +static void +marshal_VOID__OBJECT_OBJECT (GClosure *closure, + GValue *return_value G_GNUC_UNUSED, + guint n_param_values, + const GValue *param_values, + gpointer invocation_hint G_GNUC_UNUSED, + gpointer marshal_data) +{ + typedef void (*MarshalFunc) (gpointer data1, + gpointer arg_1, + gpointer arg_2, + gpointer data2); + register MarshalFunc callback; + register GCClosure *cc = (GCClosure*) closure; + register gpointer data1, data2; + + g_return_if_fail (n_param_values == 3); + + if (G_CCLOSURE_SWAP_DATA (closure)) + { + data1 = closure->data; + data2 = g_value_get_object (param_values + 0); + } + else + { + data1 = g_value_get_object (param_values + 0); + data2 = closure->data; + } + callback = (MarshalFunc) (marshal_data ? marshal_data : cc->callback); + + callback (data1, + g_value_get_object (param_values + 1), + g_value_get_object (param_values + 2), + data2); +} + +static void +scm_widget_class_init (ScmWidgetClass *klass) +{ + GObjectClass *gobject_class; + GtkObjectClass *object_class; + GtkWidgetClass *widget_class; + + gobject_class = G_OBJECT_CLASS (klass); + object_class = (GtkObjectClass*) klass; + widget_class = (GtkWidgetClass*) klass; + + parent_class = g_type_class_peek_parent (klass); + + gobject_class->finalize = scm_widget_finalize; + + object_class->destroy = scm_widget_destroy; + + widget_class->realize = scm_widget_realize; + widget_class->unrealize = scm_widget_unrealize; + + widget_class->size_request = scm_widget_size_request; + + widget_class->size_allocate = scm_widget_size_allocate; + + widget_class->event = scm_widget_event; + + klass->set_scroll_adjustments = scm_widget_set_scroll_adjustments; + widget_class->set_scroll_adjustments_signal = + g_signal_new ("set_scroll_adjustments", + G_OBJECT_CLASS_TYPE (gobject_class), + G_SIGNAL_RUN_LAST | G_SIGNAL_ACTION, + /* */ + G_STRUCT_OFFSET (ScmWidgetClass, set_scroll_adjustments), + NULL, NULL, /* Accumulator and accu_data. */ + marshal_VOID__OBJECT_OBJECT, + G_TYPE_NONE, 2, + GTK_TYPE_ADJUSTMENT, + GTK_TYPE_ADJUSTMENT); +} + +static void +scm_widget_init (ScmWidget* w) +{ + GTK_WIDGET_SET_FLAGS (GTK_WIDGET(w), GTK_CAN_FOCUS); + w->finalize = 0; + w->destroy = 0; + w->realize = 0; + w->unrealize = 0; + w->size_request = 0; + w->size_allocate = 0; + w->event = 0; + w->set_scroll_adjustments = 0; +} + +GtkWidget * +scm_widget_new (void) +{ + ScmWidget* sw = (ScmWidget*) g_object_new (GTK_TYPE_SCMWIDGET, NULL); + return ((GtkWidget*)sw); +} + + + +/* ScmWidget methods. + + These methods call the callback trampolines, adding the ID argument + previously stored in the ScmWidget. */ + +static void +scm_widget_finalize (GObject* object) +{ + ScmWidget* w = GTK_SCMWIDGET (object); + int ID = w->finalize; + if (ID == 0) { + outf_error ("ScmWidget (0x%x) had no finalize callback.\n", (uint)w); + outf_flush_error (); + } else { + Scm_widget_finalize (ID, object); + } + + G_OBJECT_CLASS (parent_class)->finalize (object); +} + +static void +scm_widget_destroy (GtkObject* object) +{ + ScmWidget* w = GTK_SCMWIDGET (object); + int ID = w->destroy; + if (ID != 0) { + Scm_widget_destroy (ID, object); + } + + GTK_OBJECT_CLASS(parent_class)->destroy (object); +} + +static void +scm_widget_realize (GtkWidget* widget) +{ + ScmWidget* w = GTK_SCMWIDGET (widget); + int ID = w->realize; + GTK_WIDGET_SET_FLAGS (widget, GTK_REALIZED); + if (ID == 0) { + outf_error ("ScmWidget (0x%x) had no realize callback.\n", (uint)w); + outf_flush_error (); + } else { + Scm_widget_realize (ID, widget); + } +} + +static void +scm_widget_unrealize (GtkWidget* widget) +{ + ScmWidget* w = GTK_SCMWIDGET (widget); + int ID = w->unrealize; + + if (GTK_WIDGET_MAPPED (widget)) { + gtk_widget_unmap (widget); + GTK_WIDGET_UNSET_FLAGS (widget, GTK_MAPPED); + } + + if (ID != 0) { + Scm_widget_unrealize (ID, widget); + } + + if (GTK_WIDGET_CLASS (parent_class) ->unrealize) { + (* GTK_WIDGET_CLASS (parent_class) ->unrealize) (widget); + } +} + +static void +scm_widget_size_request (GtkWidget* widget, GtkRequisition* requisition) +{ + ScmWidget* w = GTK_SCMWIDGET (widget); + int ID = w->size_request; + if (ID == 0) { + outf_error ("ScmWidget (0x%x) had no size_request callback.\n", (uint)w); + outf_flush_error (); + } else { + Scm_widget_size_request (ID, widget, requisition); + } +} + +static void +scm_widget_size_allocate (GtkWidget* widget, GtkAllocation* allocation) +{ + ScmWidget* w = GTK_SCMWIDGET (widget); + int ID = w->size_allocate; + if (ID == 0) { + outf_error ("ScmWidget (0x%x) had no size_allocate callback.\n", (uint)w); + outf_flush_error (); + } else { + Scm_widget_size_allocate (ID, widget, allocation); + } +} + +static gboolean +scm_widget_event (GtkWidget* widget, GdkEvent* event) +{ + ScmWidget* w = GTK_SCMWIDGET (widget); + int ID = w->event; + if (ID == 0) { + outf_error ("ScmWidget (0x%x) had no event callback.\n", (uint)w); + outf_flush_error (); + return FALSE; /* NOT handled */ + } else { + return Scm_widget_event (ID, widget, event); + } +} + +static void +scm_widget_set_scroll_adjustments (GtkWidget* widget, + GtkAdjustment *hadj, GtkAdjustment *vadj) +{ + ScmWidget* w = GTK_SCMWIDGET (widget); + int ID = w->set_scroll_adjustments; + if (ID == 0) { + /* This is nominal. */ + } else { + Scm_widget_set_scroll_adjustments (ID, widget, hadj, vadj); + } +} diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm new file mode 100644 index 000000000..066edf4ae --- /dev/null +++ b/src/gtk/thread.scm @@ -0,0 +1,79 @@ +#| -*-Scheme-*- + +$Id: $ + +Copyright (C) 2007, 2008, 2009 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; The Toolkit Thread +;;; package: (gtk thread) +;;; parent: (runtime thread) + + +(define tracing? #f) + +(define-syntax trace + (syntax-rules () + ((_ . MSG) + (if tracing? ((lambda () (outf-console . MSG))))))) + +(define gtk-thread #f) + +;;; With the following thread always running, the runtime system +;;; should no longer use wait-for-io, nor need to signal +;;; condition-type:no-thread! + +(define (create-gtk-thread) + (if gtk-thread (error "A GTk thread already exists.")) + (set! gtk-thread + (create-thread + #f (lambda () + (let ((self (current-thread))) + (let gtk-thread-loop () + (let ((time (time-limit self))) + (trace ";run-gtk until "time"\n") + ((ucode-primitive run-gtk 2) + (select-registry-handle io-registry) time) + (trace ";run-gtk done at "(real-time-clock)"\n")) + (signal-thread-events) + (yield-current-thread) + (gtk-thread-loop))))))) + +(define (signal-thread-events) + ;; NOTE: This should match the start of thread-timer-interrupt-handler. + (set! next-scheduled-timeout #f) + (deliver-timer-events) + (maybe-signal-io-thread-events)) + +(define (time-limit self) + (if (thread/next self) + 0 + (if (integer? next-scheduled-timeout) + next-scheduled-timeout + (begin + (outf-console + "\n;Warning: bogus timeout: "next-scheduled-timeout"\n") + (+ (real-time-clock) 1000))))) + +(define (kill-gtk-thread) + (if (not gtk-thread) (error "A GTk thread is not running.")) + (signal-thread-event + gtk-thread (lambda () (exit-current-thread #t)))) \ No newline at end of file diff --git a/src/microcode/achost.ac b/src/microcode/achost.ac new file mode 100644 index 000000000..bed103ac8 --- /dev/null +++ b/src/microcode/achost.ac @@ -0,0 +1,175 @@ +### -*-M4-*- +### +### $Id: $ +### +### Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, +### 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +### 2004, 2005, 2006, 2007, 2008 Massachusetts Institute of +### Technology +### +### This file is part of MIT/GNU Scheme. +### +### MIT/GNU Scheme is free software; you can redistribute it and/or +### modify it under the terms of the GNU General Public License as +### published by the Free Software Foundation; either version 2 of the +### License, or (at your option) any later version. +### +### MIT/GNU Scheme is distributed in the hope that it will be useful, +### but WITHOUT ANY WARRANTY; without even the implied warranty of +### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +### General Public License for more details. +### +### You should have received a copy of the GNU General Public License +### along with MIT/GNU Scheme; if not, write to the Free Software +### Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +### 02110-1301, USA. + +AC_CANONICAL_HOST + +dnl Save these prior to running AC_PROG_CC. +SAVED_CFLAGS=${CFLAGS} +SAVED_LDFLAGS=${LDFLAGS} + +dnl Checks for programs. +AC_PROG_CC +AC_C_BACKSLASH_A +AC_C_BIGENDIAN +AC_C_CONST +AC_C_RESTRICT +AC_C_VOLATILE +AC_C_INLINE +AC_C_STRINGIZE +AC_C_PROTOTYPES +AC_PROG_INSTALL +AC_PROG_LN_S +AC_PROG_MAKE_SET + +if test ${GCC} = yes; then + + dnl Discard flags computed by AC_PROG_CC; we'll use our own. + CFLAGS=${SAVED_CFLAGS} + LDFLAGS=${SAVED_LDFLAGS} + + if test "${enable_debugging}" = no; then + CFLAGS="${CFLAGS} -O3" + else + CFLAGS="${CFLAGS} -O0 -g -DENABLE_DEBUGGING_TOOLS" + LDFLAGS="${LDFLAGS} -g" + fi + CFLAGS="${CFLAGS} -Wall -Wundef -Wpointer-arith -Winline" + CFLAGS="${CFLAGS} -Wstrict-prototypes -Wnested-externs -Wredundant-decls" + + AC_MSG_CHECKING([for GCC>=4]) + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[ + #if __GNUC__ >= 4 + ; + #else + #error "gcc too old" + #endif + ]], + [[]] + )], + [ + AC_MSG_RESULT([yes]) + CFLAGS="${CFLAGS} -Wextra -Wno-sign-compare -Wno-unused-parameter" + CFLAGS="${CFLAGS} -Wold-style-definition" + ], + [AC_MSG_RESULT([no])]) + + # other possibilities: + # -Wmissing-prototypes -Wunreachable-code -Wwrite-strings +fi +FOO=`${INSTALL} --help 2> /dev/null | fgrep -e --preserve-timestamps` +if test "x${FOO}" != x; then + INSTALL="${INSTALL} --preserve-timestamps" +fi +CCLD=${CC} + +dnl Add OS-dependent customizations. This must happen before checking +dnl any headers or library routines, because it may add CFLAGS or +dnl LDFLAGS that the subsequent checks require. + +DO_GCC_TESTS=no +GNU_LD=no +case ${host_os} in +linux-gnu) + DO_GCC_TESTS=yes + GNU_LD=yes + ;; +freebsd*) + M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" + DO_GCC_TESTS=yes + GNU_LD=yes + ;; +dragonfly*) + M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" + DO_GCC_TESTS=yes + GNU_LD=yes + ;; +darwin*) + MACOSX=yes + MACOSX_SYSROOT=/Developer/SDKs/MacOSX10.4u.sdk + if test -d ${MACOSX_SYSROOT}; then + MACOSX_CFLAGS="-mmacosx-version-min=10.4 -isysroot ${MACOSX_SYSROOT}" + MACOSX_LDFLAGS="${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}" + CFLAGS="${CFLAGS} ${MACOSX_CFLAGS}" + LDFLAGS="${LDFLAGS} ${MACOSX_LDFLAGS}" + fi + MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle -bundle_loader "'${SCHEME_EXE}' + SHIM_LDFLAGS="${SHIM_LDFLAGS} -bundle -bundle_loader "'${SCHEME_EXE}' + ;; +netbsd*) + DO_GCC_TESTS=yes + GNU_LD=yes + dnl NetBSD, by default, has programs find non-base libraries via RPATH + if test "x${x_libraries}" != x; then + FOO=-Wl,-rpath,`echo ${x_libraries} | sed -e "s/:/ -Wl,-rpath,/g"` + LDFLAGS="${LDFLAGS} ${FOO}" + fi + ;; +openbsd*) + M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" + DO_GCC_TESTS=yes + GNU_LD=yes + ;; +solaris*) + # How do we tell whether we're using GNU ld or Solaris ld? + if test ${GCC} = yes; then + DO_GCC_TESTS=yes + M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" + fi + LDFLAGS="${LDFLAGS} -lsocket -lnsl" + ;; +esac + +if test "${DO_GCC_TESTS}" = yes; then + if test "x${STATIC_LIBS}" != x; then + STATIC_PREFIX="-Xlinker -Bstatic" + STATIC_SUFFIX="-Xlinker -Bdynamic" + fi + if test "${GNU_LD}" = yes; then + SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -export-dynamic" + fi + MODULE_CFLAGS="${MODULE_CFLAGS} -fPIC" + MODULE_LDFLAGS="${MODULE_LDFLAGS} -shared -fPIC" + SHIM_CFLAGS="${SHIM_CFLAGS} -fPIC" + SHIM_LDFLAGS="${SHIM_LDFLAGS} -shared -fPIC" + AC_MSG_CHECKING([for ELF binaries]) + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[]], + [[ + #ifdef __ELF__ + return 0; + #endif + return 1; + ]] + )], + [ + AC_MSG_RESULT([yes]) + M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" + ], + [AC_MSG_RESULT([no])]) +fi diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 97ff83e09..823f77e66 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -164,6 +164,11 @@ AC_ARG_WITH([libpq], [Use PostgreSQL libpq library if available [[yes]]])) : ${with_libpq='yes'} +AC_ARG_WITH([gtk], + AS_HELP_STRING([--with-gtk], + [Support the GNOME Toolkit if available [[yes]]])) +: ${with_gtk='yes'} + if test ${enable_static_libs} != no && test ${enable_native_code} = c; then AC_MSG_ERROR( [--enable-native-code=c incompatible with --enable-static-libs]) @@ -196,152 +201,7 @@ AUXDIR_NAME=mit-scheme EXE_NAME=mit-scheme-native INSTALL_INCLUDE= -AC_CANONICAL_HOST - -dnl Save these prior to running AC_PROG_CC. -SAVED_CFLAGS=${CFLAGS} -SAVED_LDFLAGS=${LDFLAGS} - -dnl Checks for programs. -AC_PROG_CC -AC_C_BACKSLASH_A -AC_C_BIGENDIAN -AC_C_CONST -AC_C_RESTRICT -AC_C_VOLATILE -AC_C_INLINE -AC_C_STRINGIZE -AC_C_PROTOTYPES -AC_PROG_INSTALL -AC_PROG_LN_S -AC_PROG_MAKE_SET - -if test ${GCC} = yes; then - - dnl Discard flags computed by AC_PROG_CC; we'll use our own. - CFLAGS=${SAVED_CFLAGS} - LDFLAGS=${SAVED_LDFLAGS} - - if test ${enable_debugging} = no; then - CFLAGS="${CFLAGS} -O3" - else - CFLAGS="${CFLAGS} -O0 -g -DENABLE_DEBUGGING_TOOLS" - LDFLAGS="${LDFLAGS} -g" - fi - CFLAGS="${CFLAGS} -Wall -Wundef -Wpointer-arith -Winline" - CFLAGS="${CFLAGS} -Wstrict-prototypes -Wnested-externs -Wredundant-decls" - - AC_MSG_CHECKING([for GCC>=4]) - AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM( - [[ - #if __GNUC__ >= 4 - ; - #else - #error "gcc too old" - #endif - ]], - [[]] - )], - [ - AC_MSG_RESULT([yes]) - CFLAGS="${CFLAGS} -Wextra -Wno-sign-compare -Wno-unused-parameter" - CFLAGS="${CFLAGS} -Wold-style-definition" - ], - [AC_MSG_RESULT([no])]) - - # other possibilities: - # -Wmissing-prototypes -Wunreachable-code -Wwrite-strings -fi -FOO=`${INSTALL} --help 2> /dev/null | fgrep -e --preserve-timestamps` -if test "x${FOO}" != x; then - INSTALL="${INSTALL} --preserve-timestamps" -fi -CCLD=${CC} - -dnl Add OS-dependent customizations. This must happen before checking -dnl any headers or library routines, because it may add CFLAGS or -dnl LDFLAGS that the subsequent checks require. - -DO_GCC_TESTS=no -GNU_LD=no -case ${host_os} in -linux-gnu) - DO_GCC_TESTS=yes - GNU_LD=yes - ;; -freebsd*) - M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" - DO_GCC_TESTS=yes - GNU_LD=yes - ;; -dragonfly*) - M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" - DO_GCC_TESTS=yes - GNU_LD=yes - ;; -darwin*) - MACOSX=yes - MACOSX_SYSROOT=/Developer/SDKs/MacOSX10.4u.sdk - if test -d ${MACOSX_SYSROOT}; then - MACOSX_CFLAGS="-mmacosx-version-min=10.4 -isysroot ${MACOSX_SYSROOT}" - MACOSX_LDFLAGS="${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}" - CFLAGS="${CFLAGS} ${MACOSX_CFLAGS}" - LDFLAGS="${LDFLAGS} ${MACOSX_LDFLAGS}" - fi - MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle -bundle_loader "'${SCHEME_EXE}' - ;; -netbsd*) - DO_GCC_TESTS=yes - GNU_LD=yes - dnl NetBSD, by default, has programs find non-base libraries via RPATH - if test "x${x_libraries}" != x; then - FOO=-Wl,-rpath,`echo ${x_libraries} | sed -e "s/:/ -Wl,-rpath,/g"` - LDFLAGS="${LDFLAGS} ${FOO}" - fi - ;; -openbsd*) - M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" - DO_GCC_TESTS=yes - GNU_LD=yes - ;; -solaris*) - # How do we tell whether we're using GNU ld or Solaris ld? - if test ${GCC} = yes; then - DO_GCC_TESTS=yes - M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" - fi - LDFLAGS="${LDFLAGS} -lsocket -lnsl" - ;; -esac - -if test "${DO_GCC_TESTS}" = yes; then - if test "x${STATIC_LIBS}" != x; then - STATIC_PREFIX="-Xlinker -Bstatic" - STATIC_SUFFIX="-Xlinker -Bdynamic" - fi - if test "${GNU_LD}" = yes; then - SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -export-dynamic" - fi - MODULE_CFLAGS="${MODULE_CFLAGS} -fPIC" - MODULE_LDFLAGS="${MODULE_LDFLAGS} -shared -fPIC" - AC_MSG_CHECKING([for ELF binaries]) - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [[]], - [[ - #ifdef __ELF__ - return 0; - #endif - return 1; - ]] - )], - [ - AC_MSG_RESULT([yes]) - M4_FLAGS="${M4_FLAGS} -P SUPPRESS_LEADING_UNDERSCORE,1" - ], - [AC_MSG_RESULT([no])]) -fi +m4_include(achost.ac) dnl Checks for libraries. AC_CHECK_LIB([m], [exp]) @@ -917,6 +777,26 @@ if test "${no_x}" != yes; then OPTIONAL_BASES="${OPTIONAL_BASES} x11base x11term x11graph x11color" fi +dnl Add support for Gtk if present. +AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) +if test ${with_gtk} = yes; then + AC_MSG_CHECKING([for gtk]) + if test ${enable_static_libs} != no; then + AC_MSG_RESULT([no, requires dynamic loader support]) + else + if test "${PKG_CONFIG}" != yes; then + AC_MSG_RESULT([no, no pkg-config]) + else + if pkg-config --exists gtk+-2.0; then + AC_MSG_RESULT([yes]) + MODULE_TARGETS="${MODULE_TARGETS} prgtkio.so" + else + AC_MSG_RESULT([no, ! pkg-config --exists gtk+-2.0]) + fi + fi + fi +fi + AC_MSG_CHECKING([for native-code support]) OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl" GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h" diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index 807ed990a..fe335292a 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -218,8 +218,14 @@ prdb4.so: prdb4.o scheme prpgsql.so: prpgsql.o scheme $(LINK_MODULE) prpgsql.o -lpq $(MODULE_LIBS) +prgtkio.so: prgtkio.o scheme + $(LINK_MODULE) prgtkio.o `pkg-config --libs gtk+-2.0` $(MODULE_LIBS) + @MODULE_RULES@ +prgtkio.o: prgtkio.c + $(COMPILE_MODULE) `pkg-config --cflags gtk+-2.0` -c $< + tags: TAGS TAGS: etags -r '/^DEF[A-Z0-9_]*[ \t]*(\("[^"]+"\|[a-zA-Z_][a-zA-Z0-9_]*\)/' \ diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 5431e4472..1e1fb467d 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -37,6 +37,7 @@ USA. "prpgsql" "pruxdld" "pruxffi" +"prgtkio" "svm1-interp" "termcap" "terminfo" diff --git a/src/microcode/makegen/makeinit.sh b/src/microcode/makegen/makeinit.sh index 78cad8db1..a7e9df0e0 100755 --- a/src/microcode/makegen/makeinit.sh +++ b/src/microcode/makegen/makeinit.sh @@ -24,7 +24,7 @@ # 02110-1301, USA. # Script to create "Makefile.in". -# Requires `gcc' and `scheme'. +# Requires `gcc' and `mit-scheme'. # generate "config.h". [ -f Makefile.in ] || touch Makefile.in @@ -34,7 +34,7 @@ # because dependencies are generated by running GCC -M on the source # files, which refer to "config.h". if [ -z "${SCHEME_LARGE}" ]; then - SCHEME_LARGE="scheme --large" + SCHEME_LARGE="mit-scheme --large --batch-mode" fi ${SCHEME_LARGE} < +#include + +struct _SchemeSource +{ + GSource source; + + /* This is in GSource, but is private(?). */ + GMainContext* main_context; + + /* The main loop running in main_context (if any). */ + GMainLoop* main_loop; + + /* The list of GPollFDs that have been added to the main_context. */ + GSList* gpollfds; + + /* When to give up waiting. */ + double time_limit; +}; +typedef struct _SchemeSource SchemeSource; + +static gboolean scheme_source_prepare (GSource* source, gint* timeout); +static gboolean scheme_source_check (GSource* source); +static int pending_io (SchemeSource* source); +static gboolean scheme_source_dispatch (GSource* source, GSourceFunc callback, gpointer user_data); +SchemeSource* scheme_source_new (void); +void scheme_source_destroy (SchemeSource* source); +static void clear_registry (SchemeSource* source); +static void set_registry (SchemeSource* source, GSList* new, double time); + +static SchemeSource* scheme_source; +extern int cstack_depth; /* in pruxffi.c */ +static SCHEME_OBJECT tracing_gtk_select; +static GSList* gtk_registry (select_registry_t registry); + +static int slice_counter = 0; +static GtkWidget* slice_window; +static GtkWidget* slice_label; +static GtkWidget* status_label; +static void open_slice_window (void); +static void close_slice_window (void); +static gchar* gpollfds_string (GSList* gpollfds); + +static gboolean +scheme_source_prepare (GSource* source, gint* timeout) +{ + /* Return TRUE when ready to dispatch (without a poll). + + Return FALSE and set `timeout' to do a poll/check before + dispatching. */ + + SchemeSource* src = (SchemeSource*)source; + double dtime = OS_real_time_clock (); + int timeo = src->time_limit - dtime; + if (timeo <= 0 + || pending_interrupts_p () + || OS_process_any_status_change ()) + { + if (tracing_gtk_select == SHARP_T) + { + if (timeo > 0) + { + outf_console (";scheme_source_prepare: %s\n", + pending_interrupts_p () + ? "interrupt" : "subprocess"); + } + else + { + outf_console + (";scheme_source_prepare: timeout at %.1f (in %dmsec)\n", + dtime, timeo); + } + outf_flush_console (); + } + return (TRUE); /* Ready for immediate dispatch. */ + } + + if (tracing_gtk_select == SHARP_T) + { + outf_console (";scheme_source_prepare: polling for %dmsec\n", timeo); + outf_flush_console (); + } + *timeout = timeo; + return (FALSE); /* Poll/check before dispatching. */ +} + +static gboolean +scheme_source_check (GSource* source) +{ + /* Return TRUE when ready to dispatch (after the poll). */ + + SchemeSource* src = (SchemeSource*)source; + double time = OS_real_time_clock (); + if (time > src->time_limit + || pending_io (src) + || pending_interrupts_p () + || OS_process_any_status_change ()) + { + if (tracing_gtk_select == SHARP_T + && (time > src->time_limit + || pending_interrupts_p () + || OS_process_any_status_change ())) + { + outf_console (";scheme_source_check: %s\n", + pending_interrupts_p () ? "interrupt" + : OS_process_any_status_change () ? "subprocess" + : time > src->time_limit ? "timeout" + : "i/o ready"); + outf_flush_console (); + } + return (TRUE); /* Ready for immediate dispatch. */ + } + return (FALSE); /* No I/O ready; no timeout. */ +} + +static int +pending_io (SchemeSource* src) +{ + GSList* scan; + + if (tracing_gtk_select == SHARP_T) + { + scan = src->gpollfds; + while (scan != NULL) + { + GPollFD* gfd = scan->data; + if (gfd->revents != 0) + { + outf_console (";scheme_source_check: i/o ready on %d\n", + gfd->fd); + } + scan = scan->next; + } + } + + scan = src->gpollfds; + while (scan != NULL) + { + GPollFD* gfd = scan->data; + if (gfd->revents != 0) + return (TRUE); + scan = scan->next; + } + return (FALSE); +} + +static gboolean +scheme_source_dispatch (GSource* source, + GSourceFunc callback, gpointer user_data) +{ + /* Executes our "idle" task. Ignore the callback and user_data + arguments. Must return TRUE to stay on the list of mainloop + event sources. */ + + SchemeSource* src = (SchemeSource*)source; + + slice_counter += 1; + if (slice_window != NULL) + { + gchar* fdstr, * text; + + text = g_strdup_printf ("Scheme time-slice: %d\n", slice_counter); + gtk_label_set_text(GTK_LABEL(slice_label), text); + g_free (text); + + fdstr = gpollfds_string (src->gpollfds); + text = g_strdup_printf ("Channels:%s", fdstr); + if (fdstr[0] != '\0') g_free (fdstr); + gtk_label_set_text(GTK_LABEL(status_label), text); + g_free (text); + } + if (tracing_gtk_select == SHARP_T) + { + outf_console (";scheme_source_dispatch: running time slice %d\n", + slice_counter); + outf_flush_console (); + } + Interpret (1); + if (tracing_gtk_select == SHARP_T) + { + outf_console (";scheme_source_dispatch: finished time slice %d\n", + slice_counter); + outf_flush_console (); + } + return (TRUE); /* Not a once-only. */ +} + +GSourceFuncs scheme_source_funcs = +{ + scheme_source_prepare, + scheme_source_check, + scheme_source_dispatch, + NULL, + NULL, + NULL +}; + +SchemeSource* +scheme_source_new (void) +{ + GSource* source = g_source_new (&scheme_source_funcs, sizeof (SchemeSource)); + SchemeSource* src = (SchemeSource*)source; + GMainContext* context = g_main_context_default (); + src->main_context = context; + src->main_loop = g_main_loop_new (context, FALSE); + src->gpollfds = NULL; + src->time_limit = 0.0; + g_source_attach (source, context); + return (src); +} + +void +scheme_source_destroy (SchemeSource* source) +{ + clear_registry (source); + if (source->main_loop != NULL) + { + g_main_loop_unref (source->main_loop); + source->main_loop = NULL; + } + g_source_destroy ((GSource*) source); +} + +static void +clear_registry (SchemeSource* source) +{ + GSList* gpollfds = source->gpollfds; + if (gpollfds != NULL) + { + GMainContext* context = source->main_context; + GSList* scan = gpollfds; + while (scan != NULL) + { + GPollFD* gfd = scan->data; + g_main_context_remove_poll (context, gfd); + g_free (gfd); + scan->data = NULL; + scan = scan->next; + } + g_slist_free (gpollfds); + } + source->gpollfds = NULL; +} + +static void +set_registry (SchemeSource* source, GSList* new, double time) +{ + /* Set the source's current gpollfds to match NEW. Warns if the + registry is already set. */ + + if (source->gpollfds != NULL) + clear_registry (source); + + source->time_limit = time; + source->gpollfds = new; + { + GMainContext* context = source->main_context; + while (new != NULL) + { + GPollFD* gfd = new->data; + g_main_context_add_poll (context, gfd, G_PRIORITY_DEFAULT); + new = new->next; + } + } +} + + +/* Invoking main_loop_run. */ + +DEFINE_PRIMITIVE ("GTK-MAIN+", Prim_gtk_main_plus, 0, 0, 0) +{ + /* Runs a GMainLoop with scheme_source attached. */ + + PRIMITIVE_HEADER (0); + + canonicalize_primitive_context (); + { + if (scheme_source != NULL) + error_external_return (); + + scheme_source = scheme_source_new (); + g_main_loop_run (scheme_source->main_loop); + /* Heap may have been GCed! Luckily we don't need it. */ + scheme_source_destroy (scheme_source); + scheme_source = NULL; + } + PRIMITIVE_RETURN (SHARP_T); +} + +DEFINE_PRIMITIVE ("GTK-MAIN+-QUIT", Prim_gtk_main_plus_quit, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); + + canonicalize_primitive_context (); + { + if (scheme_source == NULL) + error_external_return (); + + g_main_loop_quit (scheme_source->main_loop); + } + PRIMITIVE_RETURN (SHARP_F); +} + +DEFINE_PRIMITIVE ("RUN-GTK", Prim_run_gtk, 2, 2, 0) +{ + /* Return to the toolkit with the scheme_source set up to dispatch + to Scheme again when I/O is ready, or a certain TIME has passed. + If TIME has already passed, the I/O registry is ignored and + Scheme is ready to run again immediately. If I/O is empty, the + simulated poll should not re-enter Scheme until TIME. */ + + PRIMITIVE_HEADER (2); + canonicalize_primitive_context (); + { + select_registry_t r = arg_select_registry (1); + double time = arg_real_number (2); + set_registry (scheme_source, gtk_registry (r), time); + if (tracing_gtk_select == SHARP_T) + { + GSList* gpollfds = scheme_source->gpollfds; + gchar* fdstr = gpollfds_string (gpollfds); + outf_console (";run_gtk%s%s until %.1f\n", + gpollfds == NULL ? "" : " waiting on", fdstr, time); + outf_flush_console (); + if (fdstr[0] != '\0') g_free (fdstr); + } + POP_PRIMITIVE_FRAME (2); + SET_EXP (SHARP_F); + PRIMITIVE_ABORT (PRIM_RETURN_TO_C); + /*NOTREACHED*/ + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + + +/* Gtk Select Registries -- GSLists of GPollFDs. */ + +/* SELECT_MODE_ -> GIOCondition */ +#define DECODE_MODE(mode) \ +(((((mode) & SELECT_MODE_READ) != 0) ? G_IO_IN : 0) \ + | ((((mode) & SELECT_MODE_WRITE) != 0) ? G_IO_OUT : 0)) + +/* GIOCondition -> SELECT_MODE_ */ +#define ENCODE_MODE(revents) \ +(((((revents) & G_IO_IN) != 0) ? SELECT_MODE_READ : 0) \ + | ((((revents) & G_IO_OUT) != 0) ? SELECT_MODE_WRITE : 0) \ + | ((((revents) & G_IO_ERR) != 0) ? SELECT_MODE_ERROR : 0) \ + | ((((revents) & G_IO_HUP) != 0) ? SELECT_MODE_HUP : 0)) + +static GSList* +gtk_registry (select_registry_t registry) +{ + /* Construct Gtk's version of a select_registry_t. */ + + int len = OS_select_registry_length (registry); + int i = 0; + GSList* list = NULL; + + while (i < len) + { + int fd; + unsigned int mode; + GPollFD* item = g_malloc (sizeof (GPollFD)); + OS_select_registry_entry (registry, i, (&fd), (&mode)); + item->fd = fd; + item->events = DECODE_MODE (mode) | G_IO_ERR | G_IO_HUP; + item->revents = 0; + list = g_slist_prepend (list, item); + i += 1; + } + return (list); +} + +static gchar* +gpollfds_string (GSList* gpollfds) +{ + /* Construct a string describing the fds and r/w flags in GPOLLFDS, + e.g. " 0(r)" */ + + gchar* string = ""; + GSList* scan = gpollfds; + while (scan != NULL) + { + GPollFD* gfd = scan->data; + int mode = (gfd->events) & (~(G_IO_HUP|G_IO_ERR)); + gchar* next = g_strdup_printf ("%s %d(%s)", string, gfd->fd, + (mode == (G_IO_IN|G_IO_OUT) ? "rw" + : mode == G_IO_IN ? "r" + : mode == G_IO_OUT ? "w" : "?")); + if (string[0] != '\0') + g_free (string); + string = next; + scan = scan->next; + } + return (string); +} + +static void +open_slice_window (void) +{ + slice_window = gtk_window_new(GTK_WINDOW_TOPLEVEL); + GtkWidget* vbox = gtk_vbox_new(FALSE, 5); + status_label = gtk_label_new("Channels:"); + slice_label = gtk_label_new("Scheme time-slice: 0"); + gtk_container_add(GTK_CONTAINER(slice_window), vbox); + gtk_box_pack_start (GTK_BOX (vbox), status_label, FALSE, FALSE, 2); + gtk_box_pack_end (GTK_BOX (vbox), slice_label, FALSE, FALSE, 2); + gtk_window_set_title(GTK_WINDOW(slice_window), "Scheme Time-Slice Counter"); + gtk_window_set_type_hint (GTK_WINDOW(slice_window), + GDK_WINDOW_TYPE_HINT_UTILITY); + gtk_widget_show_all (slice_window); + gtk_window_parse_geometry (GTK_WINDOW (slice_window), "250x50+0-40"); +} + +static void +close_slice_window (void) +{ + gtk_widget_destroy (GTK_WIDGET (slice_window)); + slice_window = NULL; + status_label = NULL; + slice_label = NULL; +} + +DEFINE_PRIMITIVE ("GTK-TIME-SLICE-WINDOW?", Prim_gtk_time_slice_window_p, 0,0,0) +{ + PRIMITIVE_HEADER (0); + + PRIMITIVE_RETURN (slice_window == NULL ? SHARP_F : SHARP_T); +} + +DEFINE_PRIMITIVE ("GTK-TIME-SLICE-WINDOW!", Prim_gtk_time_slice_window, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + SCHEME_OBJECT arg = ARG_REF(1); + if (arg == SHARP_F) + { + if (slice_window != NULL) + close_slice_window(); + } + else + { + if (slice_window == NULL) + open_slice_window(); + } + PRIMITIVE_RETURN (arg); + } +} + +DEFINE_PRIMITIVE ("GTK-SELECT-TRACE?", Prim_gtk_select_trace_p, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); + + PRIMITIVE_RETURN (tracing_gtk_select); +} + +DEFINE_PRIMITIVE ("GTK-SELECT-TRACE!", Prim_gtk_select_trace, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + SCHEME_OBJECT arg = ARG_REF(1); + tracing_gtk_select = (arg == SHARP_F ? SHARP_F : SHARP_T); + PRIMITIVE_RETURN (arg); + } +} + + +#ifdef COMPILE_AS_MODULE + +char* +dload_initialize_file (void) +{ + scheme_source = NULL; + slice_window = NULL; + tracing_gtk_select = SHARP_F; + + declare_primitive ("GTK-MAIN+", Prim_gtk_main_plus, 0, 0, 0); + declare_primitive ("GTK-MAIN+-QUIT", Prim_gtk_main_plus_quit, 0, 0, 0); + declare_primitive ("RUN-GTK", Prim_run_gtk, 2, 2, 0); + declare_primitive ("GTK-TIME-SLICE-WINDOW?", Prim_gtk_time_slice_window_p, 0, 0, 0); + declare_primitive ("GTK-TIME-SLICE-WINDOW!", Prim_gtk_time_slice_window, 1, 1, 0); + declare_primitive ("GTK-SELECT-TRACE?", Prim_gtk_select_trace_p, 0, 0, 0); + declare_primitive ("GTK-SELECT-TRACE!", Prim_gtk_select_trace, 1, 1, 0); + return ("#prgtkio"); +} + +#endif /* COMPILE_AS_MODULE */ diff --git a/src/microcode/prosio.c b/src/microcode/prosio.c index 42aafbe54..37252fa08 100644 --- a/src/microcode/prosio.c +++ b/src/microcode/prosio.c @@ -256,7 +256,7 @@ DEFINE_PRIMITIVE ("NEW-MAKE-PIPE", Prim_new_make_pipe, 2, 2, /* Select registry */ -static select_registry_t +select_registry_t arg_select_registry (int arg_number) { return ((select_registry_t) (arg_ulong_integer (arg_number))); diff --git a/src/microcode/utabmd.sh b/src/microcode/utabmd.sh index 2194182f3..448c8decd 100755 --- a/src/microcode/utabmd.sh +++ b/src/microcode/utabmd.sh @@ -24,6 +24,7 @@ # 02110-1301, USA. if [ -z "${SCHEME_COMPILER}" ]; then - SCHEME_COMPILER="scheme --compiler --heap 3000" + SCHEME_COMPILER="mit-scheme --compiler --heap 3000 --batch-mode" fi +echo "echo '(sf \"utabmd\")' | $SCHEME_COMPILER" echo '(sf "utabmd")' | ${SCHEME_COMPILER} diff --git a/src/microcode/uxio.c b/src/microcode/uxio.c index 9d6739dbd..c80695425 100644 --- a/src/microcode/uxio.c +++ b/src/microcode/uxio.c @@ -537,6 +537,17 @@ OS_select_registry_length (select_registry_t registry) return (SR_N_FDS (r)); } +void +OS_select_registry_entry (select_registry_t registry, + unsigned int index, + int * fd_r, + unsigned int * mode_r) +{ + struct select_registry_s * r = registry; + (*fd_r) = ((SR_ENTRY (r, index)) -> fd); + (*mode_r) = (ENCODE_MODE ((SR_ENTRY (r, index)) -> events)); +} + void OS_select_registry_result (select_registry_t registry, unsigned int index, diff --git a/src/runtime/Makefile-fragment b/src/runtime/Makefile-fragment index 660e08fe3..0d9854075 100644 --- a/src/runtime/Makefile-fragment +++ b/src/runtime/Makefile-fragment @@ -6,6 +6,7 @@ install: rm -rf $(DESTDIR)$(RUNDIR) $(mkinstalldirs) $(DESTDIR)$(RUNDIR) $(INSTALL_DATA) *.bci $(DESTDIR)$(RUNDIR)/. + $(INSTALL_DATA) runtime-*.pkd $(DESTDIR)$(RUNDIR)/. @for F in $(RUNOPTS); do \ CMD="$(INSTALL_COM) $${F}.com $(DESTDIR)$(RUNDIR)/.";\ echo "$${CMD}"; eval "$${CMD}";\ diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index d18c1fb0a..a733820fe 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -4,7 +4,7 @@ $Id: thread.scm,v 1.51 2009/04/29 18:34:55 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008 Massachusetts Institute of Technology + 2006, 2007, 2008, 2009 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -102,6 +102,7 @@ USA. (set! timer-interval 100) (initialize-io-blocking) (add-event-receiver! event:after-restore initialize-io-blocking) + (set! tracing? #f) (detach-thread (make-thread #f)) (add-event-receiver! event:before-exit stop-thread-timer)) @@ -206,6 +207,7 @@ USA. unspecific) (define (thread-not-running thread state) + (trace ";thread-not-running: stopping "thread" in state "state"\n") (set-thread/execution-state! thread state) (let ((thread* (thread/next thread))) (set-thread/next! thread #f) @@ -213,6 +215,7 @@ USA. (run-first-thread)) (define (run-first-thread) + (trace ";run-first-thread "first-running-thread"\n") (if first-running-thread (run-thread first-running-thread) (begin @@ -291,21 +294,34 @@ USA. value)) (define (thread-timer-interrupt-handler) + (trace ";Thread timer: interrupt in "first-running-thread"\n") (set! next-scheduled-timeout #f) - (set-interrupt-enables! interrupt-mask/gc-ok) (deliver-timer-events) (maybe-signal-io-thread-events) (let ((thread first-running-thread)) + (trace ";Thread timer: first runnable: "thread".\n") (cond ((not thread) - (%maybe-toggle-thread-timer)) + (%maybe-toggle-thread-timer) + (trace ";Thread timer: continuing with timer set for " + next-scheduled-timeout".\n")) ((thread/continuation thread) + (trace ";Thread timer: switching to "thread".\n") (run-thread thread)) ((not (eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state thread))) + (trace ";Thread timer: yielding to "(thread/next thread)".\n") (yield-thread thread)) (else + (trace ";Thread timer: continuing with "thread".\n") (%resume-current-thread thread))))) +(define tracing? #f) + +(define-syntax trace + (syntax-rules () + ((_ . MSG) + (if tracing? ((lambda () (outf-console . MSG))))))) + (define (yield-current-thread) (without-interrupts (lambda () @@ -327,6 +343,7 @@ USA. (set-thread/next! last-running-thread thread) (set! last-running-thread thread) (set! first-running-thread next) + (trace ";yield-thread: "thread" yields to "next"\n") (run-thread next)))))) (define (exit-current-thread value) @@ -424,6 +441,7 @@ USA. (define (wait-for-io) (%maybe-toggle-thread-timer #f) + (trace ";wait-for-io: next timeout = "next-scheduled-timeout"\n") (let ((catch-errors (lambda (thunk) (let ((thread (console-thread))) @@ -451,6 +469,7 @@ USA. (let ((result (catch-errors (lambda () + (trace ";wait-for-io: blocking for i/o\n") (set-interrupt-enables! interrupt-mask/all) (test-select-registry io-registry #t))))) (set-interrupt-enables! interrupt-mask/gc-ok) @@ -458,9 +477,15 @@ USA. (let ((thread first-running-thread)) (if thread (if (thread/continuation thread) - (run-thread thread) - (%maybe-toggle-thread-timer)) - (wait-for-io))))))) + (begin + (trace ";wait-for-io: running "thread"\n") + (run-thread thread)) + (begin + (trace ";wait-for-io: continuing "thread"\n") + (%maybe-toggle-thread-timer))) + (begin + (trace ";wait-for-io: looping\n") + (wait-for-io)))))))) (define (signal-select-result result) (cond ((vector? result) @@ -783,7 +808,9 @@ USA. signal-thread-event thread event)) (%signal-thread-event thread event) (if (and (not self) first-running-thread) - (run-thread first-running-thread) + (begin + (trace ";signal-thread-event running "first-running-thread"\n") + (run-thread first-running-thread)) (%maybe-toggle-thread-timer))))))) (define (%signal-thread-event thread event)