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:
Makefile
make-common
ffi/Makefile
+ gtk/Makefile
imail/Makefile
ref-manual/Makefile
sos/Makefile
--- /dev/null
+# $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
--- /dev/null
+\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{<gobject>} 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{<gtk-label>} instance, whose class is a specialization of the
+abstract @code{<gtk-object>} class. Here is the class hierarchy
+for @code{<gtk-button>}, a GtkContainer widget.
+
+@table @code
+
+@item <gtk-button>
+Wraps a GtkButton widget.
+
+@item <gtk-container>
+Adds a list of ``children'' to be implicitly destroyed along with
+their parent.
+
+@item <gtk-widget>
+Adds a ``parent'' slot.
+
+@item <gtk-object>
+Adds a ``destroyed?'' flag and the generic function
+@code{gtk-object-destroy} in support of the GtkObject notion of
+``destruction''.
+
+@item <gobject>
+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{<scm-widget>}. 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{<Gtk-Event-Viewer>}
+(@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{<Scm-Layout>} (@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{<drawing>}. Each @code{<drawn-item>}
+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{<scm-layout>} widget.
+Multiple widgets can display different views of a shared drawing.
+A @code{<scm-layout>} 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{<drawn-item>} so far:
+@code{<text-item>}, @code{<box-item>}, @code{<hline-item>},
+@code{<vline-item>} and @code{<image-item>}.
+
+A demo of two @code{<scm-layout>} 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
<li><a href="mit-scheme-sos/index.html">SOS Reference Manual</a></li>
<li><a href="mit-scheme-imail/index.html">IMAIL User's Manual</a></li>
<li><a href="mit-scheme-ffi/index.html">FFI User's Manual</a></li>
+<li><a href="mit-scheme-gtk/index.html">GTK User's Manual</a></li>
</ul>
</body>
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
# **** 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)
all: @ALL_TARGET@
all-native: compile-microcode
+ etc/make-in-subdirs.sh generate $(FFIS)
@$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" \
--compiler --batch-mode
$(MAKE) build-bands
+ etc/make-in-subdirs.sh build $(FFIS)
all-svm: microcode/svm1-defns.h
+ etc/make-in-subdirs.sh generate $(FFIS)
$(MAKE) compile-microcode
@$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)"
$(MAKE) build-bands
+ etc/make-in-subdirs.sh build $(FFIS)
microcode/svm1-defns.h: compiler/machines/svm/svm1-defns.h
if cmp compiler/machines/svm/svm1-defns.h microcode/svm1-defns.h; \
</dev/null )
all-liarc:
- @$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --compiler
+ etc/make-in-subdirs.sh generate $(FFIS)
+ @$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" \
+ --compiler --batch-mode
$(MAKE) compile-liarc-bundles build-bands
+ etc/make-in-subdirs.sh build $(FFIS)
macosx-app: stamp_macosx-app
$(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 all-native all-liarc all-svm macosx-app
.PHONY: compile-microcode build-bands
* "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
. etc/functions.sh
-INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml"
+INSTALLED_SUBDIRS="cref edwin ffi gtk imail sf sos ssp star-parser xml"
OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode"
# lib
maybe_link lib/runtime ../runtime
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}"
INSTALL="${INSTALL} --preserve-timestamps"
fi
+echo etc/create-makefiles.sh "${MIT_SCHEME_EXE}" "${mit_scheme_native_code}"
etc/create-makefiles.sh "${MIT_SCHEME_EXE}" "${mit_scheme_native_code}"
compiler/configure "${mit_scheme_native_code}"
AC_CONFIG_SUBDIRS([microcode])
+
+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_FILES([
Makefile
6001/Makefile
cref/Makefile
edwin/Makefile
ffi/Makefile
+gtk/Makefile
imail/Makefile
runtime/Makefile
sf/Makefile
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
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"
run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <<EOF
(begin
TARGET=${1}
shift
for SUBDIR in "${@}"; do
- run_cmd_in_dir "${SUBDIR}" make "${TARGET}"
+ run_cmd_in_dir "${SUBDIR}" make "${TARGET}" || exit $?
done
(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"))
# **** 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:
--- /dev/null
+#!/bin/sh
+#
+# $Id: $
+
+set -e
+
+if [ ${#} -ne 1 ]; then
+ echo "usage: ${0} <command>"
+ 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
--- /dev/null
+#| -*-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)))
--- /dev/null
+#| -*-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);
+\f
+
+;;; 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)))
+\f
+
+;;; 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)))
+\f
+
+;;; 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);
+\f
+
+;;; 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);
+\f
+
+;;; 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);
+\f
+
+;;; 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);
+\f
+
+;;; 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
+\f
+
+;;; 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);
+\f
+
+;;; 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)
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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))))
--- /dev/null
+#| -*-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")
--- /dev/null
+#| -*-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))))
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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)))
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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)))
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-2.0/gtk/gtkvbox.h |#
+
+(extern (* GtkWidget)
+ gtk_vbox_new
+ (homogeneous gboolean)
+ (spacing gint))
\ No newline at end of file
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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)))
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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)))
--- /dev/null
+#-*-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 $<
--- /dev/null
+#!/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
--- /dev/null
+#| -*-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
--- /dev/null
+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==
+====
--- /dev/null
+#| -*-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 (<demo-drawing> (constructor () 1))
+ (<drawing>)
+ ;; 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"))))))
+\f
+
+(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
--- /dev/null
+#| -*-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 <gobject> ()
+
+ ;; 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 <gobject>))
+ ;; 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))))))
+\f
+
+;;; 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)))))
+\f
+
+;;; 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"
+ " <gobject> 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 <gobject> 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?))
+\f
+
+;;; 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)
+\f
+
+;;;; GdkPixbufLoaders
+
+(define-class (<pixbuf-loader> (constructor ()))
+ (<gobject>)
+ (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 <pixbuf-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(<gobject>...) 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
--- /dev/null
+#| -*-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))
+\f
+
+(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 (<gtk-event-viewer>
+ (constructor make-gtk-event-viewer ()))
+ (<scm-widget>)
+
+ ;; 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)))))
+\f
+
+(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)"."))))
+\f
+
+(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
--- /dev/null
+#| -*-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 <gtk-object> (<gobject>)
+ (destroyed? define standard initial-value #f))
+
+(define-method initialize-instance ((object <gtk-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 <gtk-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)))))
+\f
+
+;;;; GtkAdjustments
+
+(define-class (<gtk-adjustment> (constructor ())) (<gtk-object>))
+
+;(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 <gtk-adjustment> 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.")))
+\f
+
+;;;; GtkWidgets, GtkContainers
+
+(define-class <gtk-widget> (<gtk-object>)
+
+ ;; The parent <gtk-widget> 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 <gtk-container> (<gtk-widget>)
+
+ ;; A list of child gtk-widgets.
+ (children define standard initial-value '()))
+
+(define-method gtk-object-destroy ((widget <gtk-container>))
+ ;; 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 <gtk-widget> instance.")))
+
+(define (check-gtk-container object)
+ (if (gtk-container? object) object
+ (ferror object" is not a <gtk-container> instance.")))
+\f
+
+;;; GtkLabels
+
+(define-class (<gtk-label> (constructor ())) (<gtk-widget>))
+
+(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)))
+\f
+
+;;; GtkButtons
+
+(define-class (<gtk-button> (constructor ())) (<gtk-container>))
+
+(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))
+\f
+
+;;; GtkVBox
+
+(define-class (<gtk-vbox> (constructor ())) (<gtk-container>))
+
+(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)
+\f
+
+;;;; GtkScrolledWindows
+
+(define-class (<gtk-scrolled-window>
+ (constructor make-gtk-scrolled-window ()))
+ (<gtk-container>))
+
+(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))
+\f
+
+;;;; GtkWindows
+
+(define-class (<gtk-window> (constructor make-gtk-window (type)))
+ (<gtk-container>)
+ ;; '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
--- /dev/null
+/* -*-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 <gdk/gdkkeysyms.h>
+#include <gtk/gtk.h>
+#include <gtk/gtkwidget.h>
+#include <cairo/cairo.h>
+
+#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);
--- /dev/null
+#| -*-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.
+\f
+
+(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)))
+\f
+
+;;; 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))
+\f
+
+;;; 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
--- /dev/null
+#| -*-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> 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
+ <pixbuf-loader> 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> gtk-object-destroyed? gtk-object-destroy
+ <gtk-adjustment> make-gtk-adjustment set-gtk-adjustment!
+ <gtk-widget> gtk-widget? gtk-widget-parent
+ gtk-widget-has-focus? gtk-widget-drawable? gtk-widget-show-all
+ <gtk-container> gtk-container?
+ gtk-container-children gtk-container-add
+ gtk-container-set-border-width
+ <gtk-window> gtk-window-type
+ gtk-window-new gtk-window-set-title gtk-window-set-default-size
+ <gtk-button> gtk-button-new
+ <gtk-label> gtk-label-new
+ gtk-label-get-text gtk-label-set-text
+ <gtk-vbox> gtk-vbox-new gtk-box-pack-start gtk-box-pack-end
+ <gtk-scrolled-window> 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)
+ <scm-widget>
+ 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> 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!
+
+ <drawing> make-drawing set-drawing-size! drawing-pick-list
+
+ <drawn-item> drawn-item-area set-drawn-item-position!
+ drawn-item-widgets set-drawn-item-widgets!
+
+ <box-item> add-box-item set-box-item-size!
+ set-box-item-pos-size! set-box-item-shadow!
+
+ <hline-item> add-hline-item set-hline-item-size!
+ <vline-item> add-vline-item set-vline-item-size!
+
+ <text-item> add-text-item text-item-text set-text-item-text!
+ text-item? text-item-xy-to-index
+ call-with-text-item-grapheme-rect
+
+ <image-item> 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
--- /dev/null
+#| -*-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)))
+\f
+
+;;;; 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)))
+\f
+
+;;;; 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))))))
+\f
+
+;;;; 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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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 <scm-widget> implementing a scrollable GtkDrawingArea-like widget.
+;;; package: (gtk layout)
+
+(declare (usual-integrations))
+\f
+
+(c-include "gtk")
+
+(define-class (<scm-layout> (constructor make-scm-layout ()))
+ (<scm-widget>)
+
+ ;; 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 <scm-layout> instance: "obj)))
+\f
+
+;;;; 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)))))))
+\f
+
+;;;; Drawings
+
+(define-class (<drawing> (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 <drawing>) widget)
+ (set-drawing-widgets! d (list widget)))
+
+(define (check-drawing obj)
+ (if (drawing? obj) obj
+ (ferror "Not a <drawing> 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 <drawn-item>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 <scm-layout>: "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 <scm-layout>: "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))))
+\f
+
+;;;; Drawn items.
+
+(define-class <drawn-item>
+ ()
+ (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 <drawn-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))))
+\f
+
+;;;; Simple Items (e.g. the toolkit's gtk_paint_* operators).
+
+(define-class (<box-item> (constructor add-box-item (drawing) 1))
+ (<drawn-item>)
+ (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 <box-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 (<hline-item> (constructor add-hline-item (drawing) 1))
+ (<drawn-item>))
+
+(define-method drawn-item-expose ((item <hline-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 <hline-item> instance: "obj)))
+
+(define-class (<vline-item> (constructor add-vline-item (drawing) 1))
+ (<drawn-item>))
+
+(define-method drawn-item-expose ((item <vline-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 <vline-item> instance: "obj)))
+\f
+
+;;;; Text Items (aka PangoLayouts)
+
+(define-class (<text-item> (constructor add-text-item (drawing) 1))
+ (<drawn-item>)
+ (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 <text-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 <text-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))))
+\f
+
+;;;; Images (aka GdkPixbufLoaders)
+
+(define-class (<image-item> (constructor add-image-item (drawing) 1))
+ (<drawn-item>)
+ (pixbuf-loader define accessor
+ initializer make-pixbuf-loader)
+ (pixbuf define standard initial-value #f))
+
+(define-method initialize-instance ((item <image-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 <image-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
--- /dev/null
+#| -*-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 <gtk-widget> representing a ScmWidget.
+;;; package: (gtk widget)
+
+
+(c-include "gtk")
+
+(define-class <scm-widget> (<gtk-widget>))
+
+(define-method initialize-instance ((new <scm-widget>))
+ ;; 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
--- /dev/null
+/* -*-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 <scm-widget>. */
+
+#include <mit-scheme.h>
+#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);
+}
+\f
+
+
+/* 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);
+ }
+}
--- /dev/null
+#| -*-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
--- /dev/null
+### -*-M4-*-
+###
+### Copyright (C) 2010 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_PROG_CC_STDC
+if test "x${ac_cv_prog_cc_c99}" != xno; then
+ AC_DEFINE([HAVE_STDC_99], [1], [Does the compiler support C99?])
+fi
+if test "x${ac_cv_prog_cc_c89}" != xno; then
+ AC_DEFINE([HAVE_STDC_89], [1], [Does the compiler support C89?])
+fi
+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_EGREP
+AC_PROG_FGREP
+AC_PROG_GREP
+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}
+
+MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
+
+if test x${mit_scheme_native_code} = xhppa; then
+ GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h"
+fi
+
+AUXDIR_NAME=mit-scheme-${mit_scheme_native_code}
+EXE_NAME=mit-scheme-${mit_scheme_native_code}
+
+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)
+ M4_FLAGS="${M4_FLAGS} -P __linux__,1"
+ 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*)
+ if test -n "${with_macosx_version}"; then
+ MACOSX=${with_macosx_version}
+ MACOSX_CFLAGS="-mmacosx-version-min=${MACOSX}"
+ else
+ MACOSX=`sw_vers | ${GREP} ^ProductVersion: \
+ | ${EGREP} -o '[[0-9]+\.[0-9]+]'`
+ if test -z "${MACOSX}"; then
+ AC_MSG_ERROR([Unable to determine MacOSX version])
+ fi
+ MACOSX_CFLAGS=
+ fi
+ if test "${MACOSX}" = 10.4; then
+ SDK=MacOSX${MACOSX}u
+ else
+ SDK=MacOSX${MACOSX}
+ fi
+ MACOSX_SYSROOT=/Developer/SDKs/${SDK}.sdk
+ if test ! -d "${MACOSX_SYSROOT}"; then
+ AC_MSG_ERROR([No MacOSX SDK for version: ${MACOSX}])
+ fi
+ MACOSX_CFLAGS="${MACOSX_CFLAGS} -isysroot ${MACOSX_SYSROOT}"
+ MACOSX_CFLAGS="${MACOSX_CFLAGS} -fconstant-cfstrings"
+ AC_MSG_NOTICE([Compiling for MacOSX version ${MACOSX}])
+ case ${mit_scheme_native_code} in
+ i386)
+ MACOSX_CFLAGS="-arch i386 ${MACOSX_CFLAGS}"
+ AS_FLAGS="-arch i386 ${AS_FLAGS}"
+ SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -Wl,-pagezero_size,04000000"
+ ;;
+ x86-64)
+ MACOSX_CFLAGS="-arch x86_64 ${MACOSX_CFLAGS}"
+ AS_FLAGS="-arch x86_64 ${AS_FLAGS}"
+ ;;
+ esac
+ CFLAGS="${CFLAGS} ${MACOSX_CFLAGS}"
+ LDFLAGS="${LDFLAGS} ${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}"
+ LDFLAGS="${LDFLAGS} -framework CoreFoundation"
+ MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle"
+ if test "${with_module_loader}" != no; then
+ if test "${with_module_loader}" = yes; then
+ MODULE_LOADER='${SCHEME_EXE}'
+ else
+ MODULE_LOADER="${with_module_loader}"
+ fi
+ MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle_loader ${MODULE_LOADER}"
+ fi
+ AUX_PROGRAMS="${AUX_PROGRAMS} macosx-starter"
+ ;;
+netbsd*)
+ DO_GCC_TESTS=yes
+ GNU_LD=yes
+ ;;
+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 "${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"
+ M4_FLAGS="${M4_FLAGS} -P __ELF__,1"
+ ],
+ [AC_MSG_RESULT([no])])
+fi
[Pathname of the Scheme executable, for building modules only]))
: ${with_module_loader='yes'}
+AC_ARG_WITH([gtk],
+ AS_HELP_STRING([--with-gtk],
+ [Support the GNOME Toolkit if available [[yes]]]))
+: ${with_gtk='yes'}
+
dnl Substitution variables to be filled in below.
AS_FLAGS=
GC_HEAD_FILES="gccode.h cmpgc.h cmpintmd-config.h cmpintmd.h"
EXE_NAME=
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_PROG_CC_STDC
-if test "x${ac_cv_prog_cc_c99}" != xno; then
- AC_DEFINE([HAVE_STDC_99], [1], [Does the compiler support C99?])
-fi
-if test "x${ac_cv_prog_cc_c89}" != xno; then
- AC_DEFINE([HAVE_STDC_89], [1], [Does the compiler support C89?])
-fi
-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_EGREP
-AC_PROG_FGREP
-AC_PROG_GREP
-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}
-
-MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
-
-if test x${mit_scheme_native_code} = xhppa; then
- GC_HEAD_FILES="${GC_HEAD_FILES} hppacach.h"
-fi
-
-AUXDIR_NAME=mit-scheme-${mit_scheme_native_code}
-EXE_NAME=mit-scheme-${mit_scheme_native_code}
-
-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)
- M4_FLAGS="${M4_FLAGS} -P __linux__,1"
- 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*)
- if test -n "${with_macosx_version}"; then
- MACOSX=${with_macosx_version}
- MACOSX_CFLAGS="-mmacosx-version-min=${MACOSX}"
- else
- MACOSX=`sw_vers | ${GREP} ^ProductVersion: \
- | ${EGREP} -o '[[0-9]+\.[0-9]+]'`
- if test -z "${MACOSX}"; then
- AC_MSG_ERROR([Unable to determine MacOSX version])
- fi
- MACOSX_CFLAGS=
- fi
- if test "${MACOSX}" = 10.4; then
- SDK=MacOSX${MACOSX}u
- else
- SDK=MacOSX${MACOSX}
- fi
- MACOSX_SYSROOT=/Developer/SDKs/${SDK}.sdk
- if test ! -d "${MACOSX_SYSROOT}"; then
- AC_MSG_ERROR([No MacOSX SDK for version: ${MACOSX}])
- fi
- MACOSX_CFLAGS="${MACOSX_CFLAGS} -isysroot ${MACOSX_SYSROOT}"
- MACOSX_CFLAGS="${MACOSX_CFLAGS} -fconstant-cfstrings"
- AC_MSG_NOTICE([Compiling for MacOSX version ${MACOSX}])
- case ${mit_scheme_native_code} in
- i386)
- MACOSX_CFLAGS="-arch i386 ${MACOSX_CFLAGS}"
- AS_FLAGS="-arch i386 ${AS_FLAGS}"
- SCHEME_LDFLAGS="${SCHEME_LDFLAGS} -Wl,-pagezero_size,04000000"
- ;;
- x86-64)
- MACOSX_CFLAGS="-arch x86_64 ${MACOSX_CFLAGS}"
- AS_FLAGS="-arch x86_64 ${AS_FLAGS}"
- ;;
- esac
- CFLAGS="${CFLAGS} ${MACOSX_CFLAGS} -frounding-math"
- LDFLAGS="${LDFLAGS} ${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}"
- LDFLAGS="${LDFLAGS} -framework CoreFoundation"
- MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle"
- if test "${with_module_loader}" != no; then
- if test "${with_module_loader}" = yes; then
- MODULE_LOADER='${SCHEME_EXE}'
- else
- MODULE_LOADER="${with_module_loader}"
- fi
- MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle_loader ${MODULE_LOADER}"
- fi
- AUX_PROGRAMS="${AUX_PROGRAMS} macosx-starter"
- ;;
-netbsd*)
- DO_GCC_TESTS=yes
- GNU_LD=yes
- ;;
-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 "${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"
- M4_FLAGS="${M4_FLAGS} -P __ELF__,1"
- ],
- [AC_MSG_RESULT([no])])
-fi
+m4_include(achost.ac)
dnl Checks for libraries.
AC_CHECK_LIB([m], [exp])
M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1"
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 "${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
+
OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl"
case ${mit_scheme_native_code} in
$(LINK_MODULE) prx11.o x11base.o x11color.o x11graph.o x11term.o \
-lX11 $(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_]*\)/' \
"pruxdld"
"pruxffi"
"prx11"
+"prgtkio"
"svm1-interp"
"termcap"
"terminfo"
(select_registry_t registry, int fd, unsigned int mode);
extern unsigned int OS_select_registry_length
(select_registry_t registry);
+extern void OS_select_registry_entry
+ (select_registry_t registry, unsigned int index,
+ int * fd_r, unsigned int * mode_r);
extern void OS_select_registry_result
(select_registry_t registry, unsigned int index,
int * fd_r, unsigned int * mode_r);
(select_registry_t registry, int blockp);
extern int OS_test_select_descriptor
(int fd, int blockp, unsigned int mode);
+extern select_registry_t arg_select_registry (int arg_number);
#endif /* SCM_OSIO_H */
--- /dev/null
+/* -*-C-*-
+
+$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.
+
+*/
+
+/* SchemeSource -- the custom GSource that runs Scheme in an idle task. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "pruxffi.h"
+
+#include "osio.h"
+#include "osenv.h"
+#include "ux.h"
+#include "uxio.h"
+#include "uxselect.h"
+#include "uxproc.h"
+
+#include <glib.h>
+#include <gtk/gtk.h>
+
+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;
+ }
+ }
+}
+\f
+
+/* 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);
+ }
+}
+\f
+
+/* 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 */
\f
/* Select registry */
-static select_registry_t
+select_registry_t
arg_select_registry (int arg_number)
{
return ((select_registry_t) (arg_ulong_integer (arg_number)));
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,
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}";\
(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))
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)
(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
;; Preserve the floating-point environment here to guarantee that the
;; thread timer won't raise or clear exceptions (particularly the
;; inexact result exception) that the interrupted thread cares about.
+ (trace ";Thread timer: interrupt in "first-running-thread"\n")
(let ((fp-env (flo:environment)))
(flo:set-environment! (flo:default-environment))
(set! next-scheduled-timeout #f)
(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 fp-env))
(else
+ (trace ";Thread timer: continuing with "thread".\n")
(flo:set-environment! fp-env)
(%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 ()
(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))))))
\f
(define (exit-current-thread value)
(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)))
(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)
(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))))))))
\f
(define (signal-select-result result)
(cond ((vector? result)
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)
projects / mit-scheme.git / commitdiff
