\input texinfo @c -*-Texinfo-*-
@comment %**start of header
@setfilename mit-scheme-gtk
-@set VERSION 0.1
+@set VERSION 0.2
@settitle Gtk @value{VERSION}
@comment %**end of header
+@macro bref {name}
+@ref{\name\,,@code{\name\}}
+@end macro
+
@copying
This manual documents @acronym{Gtk} @value{VERSION}.
@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.
+* Introduction::
+* API Reference::
+* Installation::
+* Implementation Notes:: This is for Scheme widget developers.
* GNU Free Documentation License::
@end menu
-
-@node Introduction, Hello World, Top, Top
+@node Introduction, API Reference, 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.
-The @file{gtk-shim.so}
-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.
+providing a Schemely interface to the GNOME toolkit(s), not entirely
+unlike Perl's Gtk2 ``binding''
+(@uref{http://gtk2-perl.sourceforge.net}) though by no means as
+extensive. Very little of the GNOME API has been wrapped --- just
+what is listed herein. As one might expect of a ``Schemely''
+interface, all toolkit resources are protected from ``leaking'' by the
+garbage collector. When Scheme's representative of a toolkit resource
+is dropped and collected, the toolkit resource is freed, just as the
+C/Unix FFI's malloced aliens are automatically freed.
+
+This manual assumes you are familiar with MIT Scheme's @code{src/}
+tree @emph{and} the GNOME toolkits. Thus a few examples, a terse API
+Reference, and The Code itself are all you have.
+
+@unnumberedsec Hello, World!
+
+Here is the ``Hello, World!'' program from the C/Unix FFI
@ifnothtml
-@xref{Top,, Introduction, mit-scheme-ffi, The FFI Reference Manual}.
+(@pxref{Top,, Hello World, mit-scheme-ffi, The FFI Reference Manual})
@end ifnothtml
@ifhtml
-See the @uref{../FFI/mit-scheme-ffi.html,, The FFI Reference Manual}.
+(@uref{mit-scheme-ffi.html#Hello%20World,, here})
@end ifhtml
+re-written to use the Gtk system. Notice that the program does not
+need the FFI; it uses no FFI syntax. There is no need to
+@code{(load-option 'FFI)}.
-@unnumberedsec Procedures
+@verbatiminclude ../../src/gtk/hello.scm
-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.
+To run this program, enter the following command lines in the
+@file{src/gtk} directory of your build tree.
@smallexample
- (let ((retval (make-alien '|gchar|)))
- (C-call "gtk_label_get_text" retval (gobject-alien label))
- (c-peek-cstring retval))
-@result{} "!dlrow ,olleH"
+ ../microcode/scheme --library ../lib
+ (load-option 'Gtk)
+ (ge '(gtk))
+ (load "hello")
+ (hello)
@end smallexample
-The @code{gtk-label-get-text} wrapper procedure hides these details.
+@unnumberedsec Gtk Event Viewer
-@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, The FFI Reference 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.
+The Gtk Event Viewer is a simple Scheme widget --- a GtkWidget
+whose methods are implemented by calls back into Scheme --- and a
+straightforward translation of Havoc Pennington's GtkEv (from
+@uref{http://developer.gnome.org/doc/GGAD/,, GGAD}). To see this
+widget, enter the following command lines in the @file{src/gtk}
+directory of your build tree.
@smallexample
- (extern (* (const gchar)) gtk_label_get_text (label (* GtkLabel)))
+ ../microcode/scheme --library ../lib
+ (load-option 'GTK)
+ (make-gtk-event-viewer-demo)
@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.
+The code can be found in @file{gtk-ev.scm}.
-@item <gtk-widget>
-Adds a ``parent'' slot.
+@unnumberedsec Fix Demo
-@item <gtk-object>
-Adds a ``destroyed?'' flag and the generic function
-@code{gtk-object-destroy} in support of the GtkObject notion of
-``destruction''.
+The Gtk system provides a fixnum-centric canvas abstraction based on
+the ancient X Window draw requests: XDrawLine, XDrawRectangle,
+XDrawArc, etc. The canvas is a fix-drawing composed of fix-inks, each
+rendered on fix-layout widgets according to ancient custom.
-@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.
+A demo of two fix-layout widgets displaying one drawing is provided.
+The drawing contains a sample of each type of fix-ink with animation
+and mouse tracking (highlighting the character under the pointer, and
+reporting the inks under a click). To see these widgets in action,
+enter the following command lines in the @file{src/gtk} directory of
+your build tree.
-@end table
+@smallexample
+ ../microcode/scheme --library ../lib
+ (load-option 'Gtk)
+ (make-fix-layout-demo)
+@end smallexample
-@unnumberedsec GObject Properties
+The code can be found in @file{fix-demo.scm}.
-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 SWAT
-@unnumberedsec Scheme Widgets
+The Gtk system contains a proof-of-concept emulation of the old Tk3.2
+interface --- SWAT, The Scheme Widget Application Toolkit, as
+described in @cite{Introduction to SWAT}, by Hal Abelson, Natalya
+Cohen and Jim Miller. The emulation lacks many widget types and
+options, and is @emph{just} sufficient to run Pole Zero.
-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}).
+To see the Pole Zero application, enter the following command lines in
+the @file{src/gtk} directory of your build tree.
-@code{<Scm-Layout>} (@pxref{Scm-Layout}) is a more sophisticated
-Scheme widget that displays a view of a Scheme canvas.
+@smallexample
+ ../microcode/scheme --library ../lib
+ (load-option 'Gtk)
+ (make-pole-zero)
+@end smallexample
-@unnumberedsec The @code{(gtk)} Package
+@unnumberedsec The 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.
+that modules mucking about with the toolkit(s) will be loaded in a
+subpackage where they will define Gtk-specific procedures, such as
+methods for generics imported from a more abstract interface.
@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:
+The Scheme machine can be configured (via the
+@code{--enable-debugging} option) to include some debugging
+facilities, like a time slice counter. Evaluating the following
+expression should cause a small window to pop up.
@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.
+The window is created and updated on the toolkit side of the
+interface, and 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. The count can be slowed and stopped
+by evaluating the first and second expressions below, respectively.
@smallexample
(set-thread-timer-interval! 1000)
(set-thread-timer-interval! #f)
@end smallexample
+@xref{Debugging Facilities}.
-@node Hello World, Gtk-Event-Viewer, Introduction, Top
-@chapter Hello World
+@node API Reference, Installation, Introduction, Top
+@appendix API Reference
-To run the example ``Hello, World!'' program, execute the following
-command lines in the @file{src/gtk} directory of your build tree.
+This appendix lists all of the procedures and data types that make up
+the Gtk interface.
+
+@menu
+* GObject::
+* Pixbuf Loader::
+* Pango Layout::
+* Gtk Object::
+* Gtk Adjustment::
+* Gtk Widget::
+* Gtk Container::
+* Gtk Window::
+* Gtk Label::
+* Gtk Button::
+* Gtk Check Button::
+* Gtk Box::
+* Gtk Frame::
+* Gtk Scrolled Window::
+* Scheme Widget::
+* Fix Layout::
+* Gdk Functions::
+* Debugging Facilities::
+@end menu
+
+@node GObject, Pixbuf Loader, API Reference, API Reference
+@section GObject
+
+An instance of @bref{<gobject>} represents a reference to a toolkit
+object, typically one created by Scheme. The instance is ``live''
+while Scheme holds the reference. @bref{gobject-unref!} kills it,
+releasing Scheme's reference. Once dead to Scheme, the toolkit may
+dispose and finalize the GObject.
+
+Callbacks can be "connected" to gobjects --- one callback per signal
+name. The procedures run without-interrupts (or at least
+without-preemption). Connecting a second callback disconnects the
+first. All connected callbacks are ``pinned'' by the
+@code{registered-callbacks} vector; they cannot be GCed until they are
+explicitly de-registered. The callback @emph{and} its closure are
+pinned. If the closure references the instance, the instance is
+pinned and the garbage collector cannot help free the corresponding
+toolkit resources. Thus a callback might want to avoid closing over
+its instance, use its first parameter to reference the instance, and
+have no other visible binding to the instance.
+
+@anchor{<gobject>}
+@deffn Class <gobject>
+The base class for all toolkit objects.
+@end deffn
+
+@deffn Procedure gobject-alien gobject
+The alien address of the toolkit object. This address may be null if
+the object has not yet been allocated, or if it is no longer alive.
+@end deffn
+
+@deffn Procedure gobject-live? gobject
+#t while @var{gobject} is alive, #f after it has been killed.
+@end deffn
+
+@anchor{gobject-unref!}
+@deffn Procedure gobject-unref! gobject
+Kills @var{gobject}. Disconnects all signal callbacks and releases
+Scheme's reference to the toolkit object. This procedure may be
+called multiple times; the reference will only be released once.
+@end deffn
+
+@anchor{g-signal-connect}
+@deffn Procedure g-signal-connect gobject alien-function callback
+Arrange for @var{callback} to be applied to @var{gobject} and other
+arguments whenever @var{gobject} emits the signal with the same name
+as @var{alien-function}. @var{alien-function} should be a callback
+trampoline, as in this example:
@smallexample
- ../microcode/scheme --library ../lib
- (load-option 'Gtk)
- (ge '(gtk))
- (load "hello")
- (hello)
+ (g-signal-connect window (C-callback "delete_event") delete-callback)
@end smallexample
-Here is the code.
+Note that @var{delete-callback} should reference @var{window} via
+parameter @emph{only} (per discussion above).
+@end deffn
-@verbatiminclude ../../src/gtk/hello.scm
+@deffn Procedure g-signal-disconnect gobject name
+@var{name} should be a string, e.g.:
+@smallexample
+ (g-signal-disconnect window "delete_event")
+@end smallexample
+@end deffn
+The @bref{gobject-get-property} and @bref{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}.
-@node Gtk-Event-Viewer, Scm-Layout, Hello World, Top
-@chapter Gtk-Event-Viewer
+@anchor{gobject-get-property}
+@deffn Procedure gobject-get-property gobject property
+The (default) value of @var{gobject}'s @var{property}. @var{Property}
+may be a string or symbol. If there is no such property, an error is
+signaled.
+@end deffn
+
+@anchor{gobject-set-properties}
+@deffn Procedure gobject-set-properties gobject . property-list
+@var{Property-list} should be an even-length list of alternating names
+(symbols or strings) and values.
+@end deffn
+
+@anchor{gquark-from-string}
+@deffn Procedure gquark-from-string string
+The GQuark (integer) associated with @var{string}.
+@end deffn
+
+@deffn Procedure gquark-to-string gquark
+The string associated with @var{gquark} (an integer). If @var{gquark}
+has not been interned by @bref{gquark-from-string}, an error is
+signaled.
+@end deffn
+
+@node Pixbuf Loader, Pango Layout, GObject, API Reference
+@section Pixbuf Loader
+
+A pixbuf loader encapsulates the loading of a pixbuf. The
+@bref{load-pixbuf-from-port} procedure can feed data directly from a
+Scheme input port into a pixbuf loader, and the loaders various hooks
+will notify the user when the pixbuf size is determined, when the
+pixbuf is allocated, when areas of the pixbuf have been updated, and
+when the pixbuf is complete.
+
+@deffn Class <pixbuf-loader>
+A direct subclass of gobject representing a reference to a GdkPixbufLoader.
+@end deffn
+
+@anchor{<pixbuf>}
+@deffn Class <pixbuf>
+A direct subclass of gobject representing a reference to a GdkPixbuf.
+@end deffn
+
+@deffn Procedure make-pixbuf-loader
+A new pixbuf-loader instance.
+@end deffn
+
+@anchor{load-pixbuf-from-port}
+@deffn Procedure load-pixbuf-from-port loader input-port
+Initializes @var{loader} and starts a new thread loading from
+@var{input-port}.
+@end deffn
+
+@deffn Procedure load-pixbuf-from-file loader filename
+Initializes @var{loader} and starts a new thread loading from
+@var{filename}.
+@end deffn
+
+@deffn Procedure pixbuf-loader-size-hook loader
+#f or the procedure that will be applied to the pixbuf size (two
+integers, width and height).
+@end deffn
+
+@deffn Procedure set-pixbuf-loader-size-hook! loader receiver
+Arrange for @var{receiver} to be applied to @var{loader}'s pixbuf's
+size (two integers, width and height) as soon as it can be determined.
+If the size has already been determined, @var{receiver} is applied
+immediately.
+@end deffn
+
+@deffn Procedure pixbuf-loader-pixbuf-hook loader
+#f or the procedure that will be applied to the pixbuf as soon as it
+is allocated.
+@end deffn
+
+@deffn Procedure set-pixbuf-loader-pixbuf-hook! loader receiver
+Arrange for @var{receiver} to be applied to @var{loader}'s pixbuf (an
+instance of @bref{<pixbuf>}) as soon as it is allocated. If the
+pixbuf has already been created, @var{receiver} is applied
+immediately.
+@end deffn
+
+@deffn Procedure pixbuf-loader-update-hook loader
+#f or the procedure that will be applied to areas of the pixbuf
+recently updated.
+@end deffn
+
+@deffn Procedure set-pixbuf-loader-update-hook! loader receiver
+Arrange for @var{receiver} to be applied to areas of the pixbuf as
+they are updated. @var{Receiver} will be applied to four integers ---
+the x and y coordinates of the upper-left corner, and width and height
+of the updated area. If the pixbuf is complete before @var{receiver}
+is set, it will never be called.
+@end deffn
+
+@deffn Procedure pixbuf-loader-close-hook loader
+#f or the thunk that will be invoked when loading is complete.
+@end deffn
+
+@deffn Procedure set-pixbuf-loader-close-hook! loader thunk
+Arrange for @var{thunk} to be invoked when loading is complete. If
+loading is complete before @var{thunk} is set, it will be invoked
+immediately.
+@end deffn
+
+@deffn Procedure pixbuf-loader-pixbuf loader
+#f or the pixbuf that is loading (or was loaded).
+@end deffn
+
+@deffn Procedure pixbuf-loader-error-message loader
+#f or a string describing any error encountered during the loading.
+@end deffn
+
+@node Pango Layout, Gtk Object, Pixbuf Loader, API Reference
+@section Pango Layout
+
+A simple wrapper for PangoLayout objects that ensures the toolkit
+object is de-referenced when the instance is garbage collected.
+
+@deffn Class <pango-layout>
+A direct subclass of gobject representing a reference to a PangoLayout.
+@end deffn
+
+@deffn Procedure pango-layout-get-context layout
+The layout's context, a PangoContext alien.
+@end deffn
+
+@anchor{pango-layout-context-changed}
+@deffn Procedure pango-layout-context-changed layout
+Re-lays-out @var{layout} according to the (new) state of its context.
+@end deffn
+
+@deffn Procedure pango-layout-get-font-description layout
+@var{Layout}'s font description, a PangoFontDescription alien, or a
+null alien if the font description from @var{layout}'s context is in
+use. The description is owned by the layout and must not be modified
+nor freed.
+@end deffn
+
+@deffn Procedure pango-layout-set-font-description layout font
+Sets @var{layout}'s default font to @var{font}, a PangoFontDescription
+alien.
+@end deffn
+
+@deffn Procedure pango-layout-set-text layout string
+Sets @var{layout}'s text to @var{string}. The new text will be laid
+out, possibly changing @var{layout}'s dimensions.
+@end deffn
+
+@deffn Procedure pango-layout-get-pixel-extents layout receiver
+Applies @var{receiver} to @var{layout}'s width and height.
+@end deffn
+
+@deffn Procedure pango-layout-index-to-pos layout index receiver
+Applies @var{receiver} to the x and y coordinates (relative to the
+upper-left corner of @var{layout}) and the width and height of the
+character at @var{index}.
+@end deffn
+
+@anchor{pango-font-description-from-string}
+@deffn Procedure pango-font-description-from-string string
+A new PangoFontDescription alien. If it is garbage collected, the
+toolkit object will be freed with @bref{pango-font-description-free}.
+@end deffn
+
+@deffn Procedure pango-font-description-to-string font
+A string that would parse as @var{font}, a PangoFontDescription alien.
+@end deffn
+
+@anchor{pango-font-description-free}
+@deffn Procedure pango-font-description-free font
+Frees @var{font}, an alien PangoFontDescription.
+@end deffn
+
+@deffn Procedure pango-context-get-font-description context
+The PangoFontDescription alien owned by @var{context}, an alien
+PangoContext.
+@end deffn
+
+@deffn Procedure pango-context-set-font-description context font
+Sets @var{context}'s PangoFontDescription to a copy of @var{font}.
+@end deffn
+
+@deffn Procedure pango-context-get-metrics context font
+A new PangoFontMetrics alien to which Scheme holds a reference. If
+the alien is garbage collected, the reference will be released with
+@code{pango_font_metric_unref}.
+@end deffn
+
+@deffn Procedure pango-context-spacing context
+The space between lines in any up-to-date pango layout using
+@var{context}.
+@end deffn
+
+@deffn Procedure pango-font-metrics-get-ascent metrics
+The ascent of @var{metrics}, a PangoFontMetrics alien. This is the
+distance from the baseline to the highest point of the glyphs of the
+font. This is positive in practically all fonts.
+@end deffn
+
+@deffn Procedure pango-font-metrics-get-descent metrics
+The descent of @var{metrics}, a PangoFontMetrics alien. This is the
+distance from the baseline to the lowest point of the glyphs of the
+font. This is positive in practically all fonts.
+@end deffn
+
+@deffn Procedure pango-font-metrics-get-approximate-char-width metrics
+The approximate character width of @var{metrics}, a PangoFontMetrics
+alien. This is merely a representative value useful, for example, for
+determining the initial size for a window. The actual glyphs will be
+wider and narrower than this.
+@end deffn
+
+@anchor{pango-font-metrics-unref}
+@deffn Procedure pango-font-metrics-unref metrics
+Releases Scheme's reference to @var{metrics} with
+@code{pango_font_metric_unref}. All operations on @var{metrics} will
+thereafter signal an error.
+@end deffn
+
+@node Gtk Object, Gtk Adjustment, Pango Layout, API Reference
+@section Gtk Object
+
+A gtk-object is a gobject that can be "destroyed". Each instance is
+connected to the "destroy" signal of its GtkObject. The callback
+@bref{gobject-unref!}'s the instance, allowing the toolkit to finalize
+and dispose of the GtkObject.
+
+If a Gtk object is "dropped", never destroyed, eventually GCed, the
+usual gobject cleanup will effect a @bref{gobject-unref!} and
+(potentially) release the toolkit resources.
+
+@deffn Class <gtk-object>
+An abstract, direct subclass of gobject.
+@end deffn
+
+@deffn Procedure gtk-object? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-object object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-object-destroyed? object
+#f if @var{object} has not been destroyed.
+@end deffn
+
+@deffn Procedure gtk-object-destroy object
+Destroys @var{object}.
+@end deffn
+
+@node Gtk Adjustment, Gtk Widget, Gtk Object, API Reference
+@section Gtk Adjustment
+
+@deffn Class <gtk-adjustment>
+A direct subclass of gtk-object representing a reference to a GtkAdjustment.
+@end deffn
+
+@deffn Procedure gtk-adjustment? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-adjustment object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure make-gtk-adjustment
+A new gtk-adjustment instance.
+@end deffn
+
+@deffn Procedure set-gtk-adjustment! adjustment value lower upper page-size step-incr page-incr
+Set the members of a GtkAdjustment and emit the @code{changed} and/or
+@code{value_changed} signals.
+@table @code
+@item value
+A real magnitude.
+@item lower
+The minimum value.
+@item upper
+The maximum value.
+@item step_increment
+The increment to use to make minor changes to the value. In a
+GtkScrollbar this increment is used when the mouse is clicked on the
+arrows at the top and bottom.
+@item page_increment
+The increment to use to make major changes to the value. In a
+GtkScrollbar this increment is used when the mouse is clicked in the
+trough.
+@item page_size
+The page size. In a GtkScrollbar this is the size of the area which
+is currently visible.
+@end table
+@end deffn
+
+@node Gtk Widget, Gtk Container, Gtk Adjustment, API Reference
+@section Gtk Widget
+
+A Gtk object with a ``parent'' slot.
+
+@deffn Class <gtk-widget>
+An abstract, direct subclass of gtk-object.
+@end deffn
+
+@deffn Procedure gtk-widget? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-widget object operator
+Type guarantor.
+@end deffn
+
+@deffn {Generic Procedure} gtk-widget-parent widget
+The parent gtk-container, or #f.
+@end deffn
+
+@subsection Gtk Widget Callbacks
+
+@deffn Procedure set-gtk-widget-size-allocate-callback! widget callback
+Arrange for @var{callback} to be applied to @var{widget} and an alien
+GtkAllocation whenever the widget's size changes. Do @emph{not}
+capture @var{widget} in @var{callback}'s closure, else it cannot be
+GCed.
+@end deffn
+
+@deffn Procedure set-gtk-widget-realize-callback! widget callback
+Arrange for @var{callback} to be applied to @var{widget} when it is
+realized. Do @emph{not} capture @var{widget} in @var{callback}'s
+closure, else it cannot be GCed.
+@end deffn
+
+@deffn Procedure set-gtk-widget-unrealize-callback! widget callback
+Arrange for @var{callback} to be applied to @var{widget} when it is
+unrealized. Do @emph{not} capture @var{widget} in @var{callback}'s
+closure, else it cannot be GCed.
+@end deffn
+
+@deffn Procedure set-gtk-widget-event-callback! widget callback
+Arrange for @var{callback} to be applied to @var{widget} and an alien
+GdkEvent whenever the widget receives an event. Do @emph{not} capture
+@var{widget} in @var{callback}'s closure, else it cannot be GCed.
+@end deffn
+
+@subsection Gtk Widget Operators
+
+@deffn Procedure gtk-widget-realized? widget
+#t if @var{widget} has been realized.
+@end deffn
+
+@deffn Procedure gtk-widget-drawable? widget
+#t if @var{widget} can be drawn, i.e. it is mapped and visible.
+@end deffn
+
+@deffn Procedure gtk-widget-grab-focus widget
+Causes @var{widget} to have the keyboard focus for the GtkWindow it's
+inside. @var{Widget} must be a focusable widget, such as a GtkEntry;
+something like a GtkFrame will not work. The widget also needs to be
+realized and mapped. Grabbing the focus immediately after creating
+the widget will likely fail and cause critical warnings.
+@end deffn
+
+@deffn Procedure gtk-widget-has-focus? widget
+#t if @var{widget} has the keyboard.
+@end deffn
+
+@anchor{gtk-widget-is-composited?}
+@deffn Procedure gtk-widget-is-composited? widget
+#t if @var{widget} has an alpha channel.
+@end deffn
+
+@deffn Procedure gtk-widget-show widget
+Indicates @var{widget} is ready to be displayed. If you want to show
+all widgets in a container, it is easier to call
+@bref{gtk-widget-show-all} on the container. Note that the containers
+containing @var{widget} must also be ``shown'' else @var{widget}
+cannot be displayed. When a toplevel container is shown, it is
+immediately realized and mapped, as well as any descendents that are
+``showing''.
+@end deffn
+
+@anchor{gtk-widget-show-all}
+@deffn Procedure gtk-widget-show-all widget
+Recursively shows @var{widget} all of its children (if any).
+@end deffn
+
+@deffn Procedure gtk-widget-error-bell widget
+Notifies the user about an input-related error on @var{widget}. This
+may sound a short beep, flash a visual cue associated with
+@var{widget}'s toplevel window, or do nothing at all, per user
+preference and window manager support.
+@end deffn
+
+@deffn Procedure gtk-widget-queue-draw widget
+Schedules a complete re-draw of @var{widget}. (An expose event will be
+delivered when the toolkit is idle.)
+@end deffn
+
+@deffn Procedure gtk-widget-get-colormap widget
+An alien GdkColormap owned by the toolkit. It should not be freed.
+@end deffn
+
+@deffn Procedure gtk-widget-get-pango-context widget
+A PangoContext with the appropriate font map, font description, and
+base direction for @var{widget}. This context is owned by
+@var{widget} but it can be used until @var{widget}'s screen or
+toplevel changes. It will be updated to match changes to
+@var{widget}'s attributes. @var{Widget}'s @code{style-set} and
+@code{direction-changed} signals indicate when the context has
+changed. If you keep a PangoLayout using this default context, the
+signal callbacks should apply @bref{pango-layout-context-changed}.
+@end deffn
+
+@deffn Procedure gtk-widget-create-pango-layout widget #!optional text
+Creates a new pango-layout with the appropriate font map, font
+description, and base direction for drawing text for @var{widget}.
+The layout will be empty unless @var{text}, a string, is provided. If
+@var{widget}'s base direction or font changes, apply
+@bref{pango-layout-context-changed} to re-lay-out the text.
+@end deffn
+
+@anchor{gtk-widget-set-size-request}
+@deffn Procedure gtk-widget-set-size-request widget width height
+Notify the toolkit of @var{widget}'s natural size. @var{Width} and
+@var{height} should be positive. This is just a request.
+@var{Widget}'s size-allocate callback will be applied when its size is
+initialized or changed.
+@end deffn
+
+@subsection Gtk Widget Colors & Fonts
+
+@anchor{gtk-widget-parse-color}
+@deffn Procedure gtk-widget-parse-color widget spec
+The color named by @var{spec} --- a (new!) vector: @code{"#(red green
+blue)"}. The elements will be reals and can vary from 0.0 to 1.0
+(inclusive). @var{Spec} should be a string: a standard color name
+(e.g. @code{"magenta"}), a hex format number (e.g. @code{"#F0F"},
+@code{"#FF00FF"}, @code{"#FFF000FFF"}, and @code{"#FFFF0000FFFF"}), or
+one of @var{widget}'s symbolic color names. A ``standard'' color name
+is found in the venerable X11 @file{rgb.txt} file.
+@end deffn
+
+@anchor{gtk-widget-fg-color}
+@deffn Procedure gtk-widget-fg-color widget #!optional state
+The color used to draw @var{widget} when it is in @var{state} --- a
+(new!) vector: #(red green blue). The color components are reals and
+can vary from 0.0 to 1.0 inclusive. @var{State} may be one of the
+symbols @code{normal}, @code{active}, @code{prelight}, @code{selected}
+or @code{insensitive}, and defaults to @code{normal}.
+@end deffn
+
+@deffn Procedure gtk-widget-bg-color widget #!optional state
+@var{Widget}'s background color. Similar to
+@bref{gtk-widget-fg-color}.
+@end deffn
+
+@deffn Procedure gtk-widget-text-color widget #!optional state
+@var{Widget}'s text color --- the foreground color for drawing text.
+Similar to @bref{gtk-widget-fg-color}.
+@end deffn
+
+@deffn Procedure gtk-widget-base-color #!optional state
+@var{Widget}'s base color --- the background color for drawing text.
+Similar to @bref{gtk-widget-fg-color}.
+@end deffn
+
+@anchor{set-gtk-widget-fg-color!}
+@deffn Procedure set-gtk-widget-fg-color! widget color #!optional state
+Sets the foreground color used to draw @var{widget} when it is in
+@var{state}. @var{State} may be one of the symbols @code{normal},
+@code{active}, @code{prelight}, @code{selected} or @code{insensitive}.
+It defaults to @code{normal}. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color}. @emph{Note} that the
+effect of this procedure on widgets that have @emph{not} been realized
+is undefined at best.
+@end deffn
+
+@deffn Procedure set-gtk-widget-bg-color! widget color #!optional state
+Sets the background color of @var{widget}. See
+@bref{set-gtk-widget-fg-color!}.
+@end deffn
+
+@deffn Procedure set-gtk-widget-text-color! widget color #!optional state
+Sets the foreground color used when drawing text in @var{widget}. See
+@bref{set-gtk-widget-fg-color!}.
+@end deffn
+
+@deffn Procedure set-gtk-widget-base-color! widget color #!optional state
+Sets the background color used when drawing text in @var{widget}. See
+@bref{set-gtk-widget-fg-color!}.
+@end deffn
+
+@deffn Procedure gtk-widget-font widget
+A PangoFontDescription alien --- a toolkit object owned by
+@var{widget}'s style.
+@end deffn
+
+@deffn Procedure set-gtk-widget-font! widget font
+Set @var{widget}'s style to use @var{font}, a PangoFontDescription.
+@var{Widget} will ref @var{desc}.
+@end deffn
+
+@node Gtk Container, Gtk Window, Gtk Widget, API Reference
+@section Gtk Container
+
+A Gtk widget with a list of ``children''. The list records only the
+children that were created and added via this interface. Other
+toolkit code may add, remove or re-order children and this list will
+not be updated. This should probably be fixed with @code{add} and
+@code{remove} signal callbacks.
+
+@deffn Class <gtk-container>
+An abstract, direct subclass of gtk-widget.
+@end deffn
+
+@deffn Procedure gtk-container? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-container object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-container-children container
+A fresh list of @var{container}'s known children --- those created and
+added via this interface.
+@end deffn
+
+@deffn Procedure gtk-bin-child container
+The first known child in a container, e.g. the only child of a GtkBin
+created via this interface.
+@end deffn
+
+@deffn Procedure gtk-container-add container child
+Adds @var{child} to @var{container}. @var{Child} should not already
+be in a container. Typically used for GtkBins, where positioning the
+child in the container is trivial. When applied to a more complex
+container, the results may be unexpected. Consider a more specialized
+procedure like @bref{gtk-box-pack-start}.
+@end deffn
+
+@deffn Procedure gtk-container-remove container child
+Removes @var{child} from @var{container}. If @var{child} is not in
+@var{container}, an error is signaled. If you intend to destroy
+@var{child}, you do not need to remove it.
+@end deffn
+
+@deffn Procedure gtk-container-set-border-width container width
+Sets the border width of @var{container} to @var{width}. The border
+width of a container is the amount of space to leave around the
+outside of the container. The only exception to this is Gtk window;
+because toplevel windows can't leave space outside, they leave the
+space inside.
+@end deffn
+
+@node Gtk Window, Gtk Label, Gtk Container, API Reference
+@section Gtk Window
+
+These objects are not GCed, but held strongly by the
+@code{toplevel-windows} list in the @code{(gtk gtk-object)} package.
+The toolkit object is a GtkBin, and should have no more than one
+child, though this is not enforced, on the Scheme side, yet.
+
+@deffn Class <gtk-window>
+A direct subclass of gtk-container representing a reference to a GtkWindow.
+@end deffn
+
+@deffn Procedure gtk-window? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-window object operator
+Type guarantor.
+@end deffn
+
+@anchor{gtk-window-new}
+@deffn Procedure gtk-window-new type
+A new gtk-window instance. @var{Type} should be the symbol
+@code{toplevel}. It can also be @code{popup}, but the window will not
+be managed by the window manager, like a tooltip or popup menu window.
+@end deffn
+
+@deffn Procedure gtk-window-type window
+The symbol @code{toplevel}, unless @var{window} is a popup. See
+@bref{gtk-window-new}.
+@end deffn
+
+@anchor{gtk-window-set-geometry-hints}
+@deffn Procedure gtk-window-set-geometry-hints window widget . hints
+Sets @var{window}'s geometry hints. @var{Widget} can be #f or any
+widget that is ``showing'' in @var{window} (not just @var{window}'s
+immediate child). When specified, the geometry hints are applied to
+@var{widget}'s size, sizing @var{window} to account for decorations,
+scrollbars, etc. @var{Hints} should be an alist. Values associated
+with names (symbols) in the following table will specify certain
+resizing constraints.
+@table @code
+@item min-width min-height
+The minimum fixnum dimensions of @var{widget} or @var{window}. -1
+specifies their natural size. Both width @emph{and} height should be
+specified.
+@item max-width max-height
+The maximum dimensions of @var{widget} or @var{window}.
+@item base-width base-height width-increment height-increment
+Allow dimensions that are N increments greater than a base value, for
+non-negative integers N. Both width @emph{and} height, for base and
+increment, should be specified --- four fixnums.
+@item min-aspect max-aspect
+The minimum and maximum aspect ratios (reals).
+@item gravity
+Keep the specified reference point of each child a constant distance
+from the corresponding reference point of the window when it is
+resized. The value of this property should be one of these symbols:
+@code{north}, @code{northeast}, @code{east}, @code{southeast},
+@code{south}, @code{southwest}, @code{west}, @code{northwest}, or
+@code{center}.
+@end table
+@end deffn
+
+@deffn Procedure gtk-window-set-title window string
+Sets the title of @var{window} to @var{string}. The title of a window
+is displayed in its title bar. It should help a user distinguish this
+window from other windows they may have open. A good title might
+include the application name and current document.
+@end deffn
+
+@deffn Procedure gtk-window-set-opacity window opacity
+Request a partially transparent @var{window}. @var{Opacity} can vary
+from 0.0 (fully transparent) to 1.0 (fully opaque). On X11 the
+request has no effect without a compositing manager. See
+@bref{gtk-widget-is-composited?}. Note that setting a window's
+opacity after the window has been shown causes it to flicker once on
+Windows.
+@end deffn
+
+@anchor{gtk-window-set-default-size}
+@deffn Procedure gtk-window-set-default-size window width height
+Sets @var{window}'s default size to @var{width} x @var{height}. If
+either dimension is -1, the default for that dimension is unset. If a
+dimension is 0, it is treated like 1, which means ``as small as
+possible'' (which is effectively ``unset''?). With a default size
+set, @var{window} may still request a larger size. The final size
+will be clamped according to @var{window}'s geometry hints. If
+@var{window} has already been shown, this procedure has no effect; it
+will not resize @var{window}.
+@end deffn
+
+@deffn Procedure gtk-window-get-default-size window receiver
+Applies @var{receiver} to @var{window}'s default width and height.
+@end deffn
+
+@deffn Procedure gtk-window-parse-geometry window string
+Returns #f if not on X or @var{string} is not a standard X geometry
+string. Otherwise returns #t and sets @var{window}'s user-requested
+size and position. An X geometry string is something like
+@code{"-0+0"}, meaning ``upper right hand corner''. The X manpage
+contains the full details. Note that for this procedure to work
+correctly (so that @var{window} is created at its final size and
+position --- no moving, resizing, etc.) the window should have any
+geometry hints already set, and a "final" size already determined,
+i.e. by previously setting any default size(?), and ``showing'' the
+toplevel widget. See @bref{gtk-window-set-geometry-hints}.
+@end deffn
+
+@deffn Procedure gtk-window-resize window width height
+Resizes @var{window} as if the user had done so, obeying geometry
+constraints. @var{width} and @var{height} should be positive fixnums.
+When applied before @var{window} is shown for the first time, this
+procedure overrides @var{window}'s default size. See
+@bref{gtk-window-set-default-size}.
+
+These come from geometry hints, and a default constraint that windows
+not be sized smaller than their natural size. To force @var{window}'s
+``natural'' size, apply @bref{gtk-widget-set-size-request}.
+@end deffn
+
+@deffn Procedure gtk-window-present window
+Presents @var{window} to the user. This may mean raising the window
+in the stacking order, deiconifying it, moving it to the current
+desktop, and/or giving it the keyboard focus, possibly dependent on
+the user's platform, window manager, and preferences. If window is
+hidden, it is shown.
+@end deffn
+
+@deffn Procedure set-gtk-window-delete-event-callback! window callback
+Connect @var{callback} to @var{window}'s @code{delete_event} signal.
+The signal will apply @var{callback} to @var{window}. Do @emph{not}
+capture @var{window} in @var{callback}'s closure, else it cannot be
+GCed.
+@end deffn
+
+@node Gtk Label, Gtk Button, Gtk Window, API Reference
+@section Gtk Label
+
+@deffn Class <gtk-label>
+A direct subclass of gtk-container representing a reference to a GtkLabel.
+@end deffn
+
+@deffn Procedure gtk-label? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-label object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-label-new text
+A new gtk-label instance. @var{Text}, a string, will be displayed in
+the new label.
+@end deffn
+
+@deffn Procedure gtk-label-get-text label
+The text of @var{label}.
+@end deffn
+
+@deffn Procedure gtk-label-set-text label string
+Sets @var{label}'s text to @var{string}.
+@end deffn
+
+@deffn Procedure gtk-label-set-width-chars label n-chars
+Sets @var{label}'s natural size to @var{n-chars}.
+@end deffn
+
+@node Gtk Button, Gtk Check Button, Gtk Label, API Reference
+@section Gtk Button
+
+@deffn Class <gtk-button>
+A direct subclass of gtk-container representing a reference to a GtkButton.
+@end deffn
+
+@deffn Procedure gtk-button? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-button object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-button-new
+A new gtk-button instance.
+@end deffn
+
+@deffn Procedure set-gtk-button-clicked-callback! button callback
+Connect @var{callback} to @var{button}'s "clicked" signal. The signal
+will apply @var{callback} to @var{button}. Do @emph{not} capture
+@var{button} in @var{callback}'s closure, else it cannot be GCed.
+@end deffn
+
+@node Gtk Check Button, Gtk Box, Gtk Button, API Reference
+@section Gtk Check Button
+
+@deffn Class <gtk-check-button>
+A direct subclass of gtk-container representing a reference to a GtkCheckButton.
+@end deffn
+
+@deffn Procedure gtk-check-button? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-check-button object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-check-button-new
+A new gtk check button.
+@end deffn
+
+@deffn Procedure gtk-check-button-get-active button
+#t if @var{button} is ``on'', #f if it is ``off''.
+@end deffn
+
+@deffn Procedure gtk-check-button-set-active button active?
+If @var{active?}, turns @var{button} ``on'', else ``off''.
+@end deffn
+
+@deffn Procedure set-gtk-check-button-toggled-callback! button callback
+Connect @var{callback} to @var{button}'s "toggled" signal. The signal
+will apply @var{callback} to @var{button}. Do @emph{not} capture
+@var{button} in @var{callback}'s closure, else it cannot be GCed.
+@end deffn
+
+@node Gtk Box, Gtk Frame, Gtk Check Button, API Reference
+@section Gtk Box
+
+Gtk boxes can be vboxes or hboxes arranging their children vertically
+or horizontally, respectively.
+
+@anchor{gtk-box-pack-start}
+@deffn Procedure gtk-box-pack-start box child expand? fill? padding
+Adds @var{child} to @var{box}, packed with reference to the start of
+@var{box}, which can be a gtk-vbox or gtk-hbox. If @var{expand?}, the
+new child is positioned within a share of any extra space. If
+@var{fill?} (and @var{expand?}), the child is allocated the share of
+extra space. @var{Padding} is the space around the child,
+e.g. between it and its neighbors @emph{and} the edge of the box.
+@end deffn
+
+@deffn Procedure gtk-box-pack-end box child expand? fill? padding
+Just like @bref{gtk-box-pack-start}, except @var{child} is packed with
+reference to the end of @var{box}.
+@end deffn
+
+@deffn Class <gtk-vbox>
+A direct subclass of gtk-container representing a reference to a GtkVBox.
+@end deffn
+
+@deffn Procedure gtk-vbox? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-vbox object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-vbox-new homogeneous? spacing
+A new gtk-vbox. If @var{homogeneous?} is not #f, all children are
+given equal space allocations. @var{Spacing} is the distance between
+children.
+@end deffn
+
+@deffn Class <gtk-hbox>
+A direct subclass of gtk-container representing a reference to a GtkHBox.
+@end deffn
+
+@deffn Procedure gtk-hbox? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-hbox object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-hbox-new homogeneous? spacing
+A new gtk-hbox. If @var{homogeneous?} is not #f, all children are
+given equal space allocations. @var{Spacing} is the distance between
+children.
+@end deffn
+
+@node Gtk Frame, Gtk Scrolled Window, Gtk Box, API Reference
+@section Gtk Frame
+
+A bin with a decorative frame and optional label.
+
+@deffn Class <gtk-frame>
+A direct subclass of gtk-container representing a reference to a GtkFrame.
+@end deffn
+
+@deffn Procedure gtk-frame? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-frame object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-frame-new label
+A new gtk frame. @var{Label} should be a string. A null string punts
+the label.
+@end deffn
+
+@deffn Procedure gtk-frame-set-shadow-type frame type
+@var{Type} should be one of the symbols @code{none}, @code{in},
+@code{out}, @code{etched-in}, or @code{etched-out}.
+@end deffn
+
+@node Gtk Scrolled Window, Scheme Widget, Gtk Frame, API Reference
+@section Gtk Scrolled Window
+
+@deffn Class <gtk-scrolled-window>
+A direct subclass of gtk-container representing a reference to a GtkScrolledWindow.
+@end deffn
+
+@deffn Procedure gtk-scrolled-window? object
+Type predicate.
+@end deffn
+
+@deffn Procedure guarantee-gtk-scrolled-window object operator
+Type guarantor.
+@end deffn
+
+@deffn Procedure gtk-scrolled-window-new
+A new gtk scrolled window.
+@end deffn
+
+@deffn Procedure gtk-scrolled-window-set-policy window horizontal vertical
+@var{Horizontal} and @var{vertical} should be one of the symbols
+@code{always}, @code{auto} or @code{never}.
+@end deffn
+
+@deffn Procedure gtk-scrolled-window-set-placement window placement
+@var{Placement} should be one of the symbols @code{top-left},
+@code{bottom-left}, @code{top-right} or @code{bottom-right}.
+@end deffn
+
+@node Scheme Widget, Fix Layout, Gtk Scrolled Window, API Reference
+@section Scheme Widget
+
+A Scheme widget is a GtkWidget implemented by Scheme. Scheme creates
+a ScmWidget toolkit object and connects to its various gsignals, like
+@code{size_allocate} and @code{realize}. Its representative in
+Scheme, a scm-widget instance, arranges to clean these up if it is
+garbage collected, like any other gobject instance. Scheme widgets
+have a @code{set_scroll_adjustments} signal, like GtkLayout, allowing
+them to be placed in Gtk scrolled windows.
+
+@deffn Class <scm-widget>
+A direct subclass of gtk-widget representing a reference to a ScmWidget.
+@end deffn
+
+@deffn Procedure set-scm-widget-set-scroll-adjustments-callback! widget callback
+Arranges for @var{callback} to be applied to @var{widget} and the
+horizontal and vertical GtkAdjustments (aliens). These need to be
+informed of any change to the widget's scroll position. The aliens
+will be NULL when the widget's scrollbars are removed.
+@end deffn
+
+@node Fix Layout, Gdk Functions, Scheme Widget, API Reference
+@section Fix Layout
+
+The Gtk system provides a fixnum-centric canvas abstraction based on
+the ancient X Window draw requests: XDrawLine, XDrawRectangle,
+XDrawArc, etc. A fix-layout is a Scheme widget that uses these
+requests to paint (and repaint) a view of a canvas on its GdkWindow.
+The canvas is a logical device space; all positions and dimensions are
+in fixnum pixels. Thus flonums are rarely needed, and actually
+avoided. For a flonum-oriented canvas (with scale, rotate, splines,
+etc.), a cairo-layout seems inevitable.
+
+Just a few types of fix-ink been implemented: line-ink,
+rectangle-ink, arc-ink, simple-text-ink, image-ink and
+box-ink. The last three are rendered by more modern toolkit
+functions, from libraries like Pango and GdkPixbuf.
+
+Each fix-ink has a position on the canvas and a position in the
+drawing's display list. The display list determines the order in
+which the inks are (re)drawn. An ink can be drawn in all views or
+conditionally, such that it only appears in specific widgets.
+Multiple fix-layout widgets can display different views of the same
+fix-drawing.
-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}.
+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.
-To see this widget, execute the following command lines in the
-@file{src/gtk} directory of your build tree.
+@deffn Class <fix-layout>
+A direct subclass of scm-widget representing a reference to a ScmWidget.
+@end deffn
+
+@deffn Procedure fix-layout? object
+Type predicate.
+@end deffn
+
+@deffn Procedure make-fix-layout width height
+A new fix-layout with natural size @var{width} x @var{height}.
+@end deffn
+
+@deffn {Generic Procedure} fix-layout-drawing layout
+The fix-drawing displayed in @var{layout}, or #f.
+@end deffn
+
+@anchor{set-fix-layout-drawing!}
+@deffn Procedure set-fix-layout-drawing! layout drawing x y
+@var{Drawing} must be a fix-drawing. @var{X} and @var{y} are the
+integer coordinates of the upper-left corner of the view. They are
+required so that the drawing, and the position from which to view it,
+are all set in one fell swoop. If @var{layout} is already viewing
+@var{drawing}, but at a different position, "move" to that position
+--- snap, not scroll. Note that a drawing may only be viewed by
+multiple layouts that are on compatible screens.
+@end deffn
+
+@deffn Procedure set-fix-layout-size! layout width height
+Sets @var{layout} to the given @var{width} and @var{height}. If
+either dimension is -1, that dimension is unset, allowing @var{layout}
+to choose a "natural" size --- large enough to lay out the entire
+text. If a dimension is 0, it is treated like 1, which means ``as
+small as possible'', e.g. one line or one column.
+@end deffn
+
+@deffn Procedure fix-layout-scroll-step layout
+A pair: the horizontal and vertical scroll increments. It is shared
+with @var{layout}; do not modify it.
+@end deffn
+
+@deffn Procedure set-fix-layout-scroll-step! layout width height
+Sets the horizontal and vertical ``step-increments'' to be used by
+@var{layout}'s scrollbars.
+@end deffn
+
+@deffn Procedure fix-layout-scroll-to! layout x y
+@var{X} and @var{y} are the integer coordinates of the upper-left
+corner of @var{layout}'s view of the drawing. If @var{layout} is
+already displaying the view at that position, this procedure does
+nothing. Else it scrolls @var{layout} to the new position.
+@end deffn
+
+@deffn {Generic Procedure} fix-layout-new-geometry-callback layout
+This procedure is called when @var{layout} is resized.
+@end deffn
+
+@deffn {Generic Procedure} fix-layout-realize-callback layout
+This procedure is called when @var{layout} is being realized.
+@end deffn
+
+@deffn Procedure set-fix-layout-map-handler! layout handler
+Arranges to apply @var{handler} to @var{layout} when it is mapped.
+@end deffn
+
+@deffn Procedure set-fix-layout-unmap-handler! layout handler
+Arranges to apply @var{handler} to @var{layout} when it is unmapped.
+@end deffn
+
+@deffn Procedure set-fix-layout-focus-change-handler! layout handler
+Arranges to apply @var{handler} to @var{layout} and a boolean value
+when it receives a focus change event. The boolean is #t if
+@var{layout} is now in focus.
+@end deffn
+
+@deffn Procedure set-fix-layout-visibility-notify-handler! layout handler
+Arranges to apply @var{handler} to @var{layout} and a symbol: one of
+@code{visible}, @code{partially-obscured} or @code{obscured}.
+@end deffn
+
+@deffn Procedure set-fix-layout-key-press-handler! layout handler
+Arranges to apply @var{handler} every time @var{layout} gets a key
+press event. @var{Handler} is applied to @var{layout}, a key name,
+and a bitmap of char-bits. See @bref{gdk-keyval->name} and
+@bref{gdk-key-state->char-bits} for the range of the last two
+arguments.
+@end deffn
+
+@anchor{set-fix-layout-motion-handler!}
+@deffn Procedure set-fix-layout-motion-handler! layout handler
+Arranges to apply @var{handler} every time the mouse moves.
+@var{Handler} is applied to @var{layout}, a list of modifiers, and the
+x and y coordinates of the pointer in the layout's window (not in the
+drawing's coordinates). The modifiers include zero or more of the
+symbols
+@code{shift},
+@code{lock},
+@code{control},
+@code{mod1},
+@code{mod2},
+@code{mod3},
+@code{mod4},
+@code{mod5},
+@code{button1},
+@code{button2},
+@code{button3},
+@code{button4},
+@code{button5},
+@code{super},
+@code{hyper},
+@code{meta} and
+@code{release}.
+@end deffn
+
+@deffn Procedure set-fix-layout-button-handler! layout type handler
+Arranges to apply @var{handler} whenever @var{layout} receives a
+button event of the specified @var{type} --- one of the symbols
+@code{press}, @code{release}, @code{double-press} or
+@code{triple-press}. @var{Handler} is applied to @var{layout},
+@var{type}, the button number (a fixnum), the modifiers, and the
+coordinates of the pointer. See
+@bref{set-fix-layout-motion-handler!}.
+@end deffn
+
+@subsection Fix Drawing
+
+Fixnum-centric canvas, to which you can affix fix-ink spots.
+
+@deffn Class <fix-drawing>
+A direct subclass of instance.
+@end deffn
+
+@deffn Procedure make-fix-drawing
+A new fix-drawing.
+@end deffn
+
+@deffn Procedure fix-drawing-widgets drawing
+A list of fix-layout widgets displaying views of @var{drawing}. This
+is shared with @var{drawing}; do not modify it.
+@end deffn
+
+@deffn Procedure set-fix-drawing-size! drawing width height
+This is just the scrollable area, used mostly by scrollbars to scale
+their thumbs(?).
+@end deffn
+
+@deffn Procedure fix-drawing-pick-list drawing widget x y
+A list of fix-inks in @var{drawing}, displayed in @var{widget}, whose
+bounding boxes include the point (@var{x}, @var{y}).
+@end deffn
+
+@deffn Procedure fix-drawing-add-ink! drawing ink #!optional where
+Adds @var{ink} to the top of the display list for @var{drawing}. If
+@var{where} is specified, it should be the symbol @var{top} (or #f),
+the symbol @var{bottom}, or an ink already in the display list. When
+@var{where} is an ink, @var{ink} is spliced in just under (before) it.
+@end deffn
+
+@subsection Fix Ink
+
+Abstract class for all inks that can be found in fix-drawings and
+rendered on fix-layouts.
+
+@deffn Class <fix-ink>
+A direct subclass of instance.
+@end deffn
+
+@deffn Procedure fix-ink? object
+Type predicate.
+@end deffn
+
+@deffn {Generic Procedure} fix-ink-drawing ink
+@var{Ink}'s fix-drawing, or #f.
+@end deffn
+
+@deffn Procedure fix-ink-widgets ink
+The widgets in which @var{ink} should be drawn, #t if it is drawn in
+all views.
+@end deffn
+
+@deffn Procedure set-fix-ink-widgets! ink widgets
+Draw @var{ink} only in the @var{widgets}. If @var{widgets} is #t,
+@var{ink} will appear in all views of the drawing.
+@end deffn
+
+@deffn {Generic Procedure} fix-ink-move! ink dx dy
+Moves @var{ink} by the specified x and y offsets.
+@end deffn
+
+@deffn Procedure fix-ink-remove! ink
+Removes @var{ink} from its drawing.
+@end deffn
+
+@subsection Draw Ink
+
+This type of fix-ink is rendered with a @code{gdk_draw_} toolkit
+function.
+
+@deffn Class <draw-ink>
+A direct subclass of fix-ink.
+@end deffn
+
+@subsection Line Ink
+
+A draw-ink rendered with @code{gdk_draw_line}.
+
+@deffn Class <line-ink>
+A direct subclass of draw-ink.
+@end deffn
+
+@deffn Procedure line-ink? object
+Type predicate.
+@end deffn
+
+@deffn Procedure make-line-ink
+A new line-ink.
+@end deffn
+
+@deffn Procedure set-line-ink! line x1 y1 x2 y2
+Set @var{line} to start at (@var{x1},@var{y1}) and end at
+(@var{x2},@var{y2}).
+@end deffn
+
+@deffn Procedure line-ink-width line
+The width of @var{line}. @code{()} if not set.
+@end deffn
+
+@deffn Procedure set-line-ink-width! line width
+@var{Width} should be a small positive integer (fixnum). @var{Line}
+will be redrawn unless it is already drawn at the specified width.
+@end deffn
+
+@deffn Procedure line-ink-color line
+@code{()} if @var{line}'s color is not set, else the color last
+provided to @bref{set-line-ink-color!}.
+@end deffn
+
+@anchor{set-line-ink-color!}
+@deffn Procedure set-line-ink-color! line color
+Sets @var{line}'s foreground color. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{line} might appear.
+@end deffn
+
+@deffn Procedure line-ink-dash-color line
+@code{()} if @var{line}'s dash color is not set, else the color last
+provided to @bref{set-line-ink-dash-color!}.
+@end deffn
+
+@anchor{set-line-ink-dash-color!}
+@deffn Procedure set-line-ink-dash-color! line color
+Sets @var{line}'s dash color. @var{Color} can be any string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{line} might appear. This color will appear between the
+foreground colored dashes along the line. @var{Color} may also be #t
+if the space between dashes should not be drawn, or #f if @var{line}
+should be solid.
+@end deffn
+
+@subsection Rectangle Ink
+
+A draw-ink rendered with @code{gdk_draw_rectangle}.
+
+@deffn Class <rectangle-ink>
+A direct subclass of draw-ink.
+@end deffn
+
+@deffn Procedure rectangle-ink? object
+Type predicate.
+@end deffn
+
+@deffn Procedure make-rectangle-ink
+A new rectangle-ink.
+@end deffn
+
+@deffn Procedure set-rectangle-ink! rectangle x y width height
+Sets the size and position of @var{rectangle}.
+@end deffn
+
+@deffn Procedure rectangle-ink-color rectangle
+@code{()} if @var{rectangle}'s line color is not set, else the color
+last provided to @bref{set-rectangle-ink-color!}.
+@end deffn
+
+@anchor{set-rectangle-ink-color!}
+@deffn Procedure set-rectangle-ink-color! rectangle color
+Sets @var{rectangle}'s line color. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{rectangle} might appear. This is not the fill color.
+@end deffn
+
+@deffn Procedure rectangle-ink-width rectangle
+@code{()} if @var{rectangle}'s line width is not set, else the
+width last provided to @bref{set-rectangle-ink-width!}.
+@end deffn
+
+@anchor{set-rectangle-ink-width!}
+@deffn Procedure set-rectangle-ink-width! rectangle width
+Sets the width of the line used to draw @var{rectangle}'s outline.
+@end deffn
+
+@deffn Procedure rectangle-ink-fill-color rectangle
+@code{()} if @var{rectangle}'s fill color is not set, else the
+color last provided to @bref{set-rectangle-ink-fill-color!}.
+@end deffn
+
+@anchor{set-rectangle-ink-fill-color!}
+@deffn Procedure set-rectangle-ink-fill-color! rectangle color
+Sets @var{rectangle}'s fill color. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{rectangle} might appear. If @var{color} is #f, @var{rectangle}
+is outlined, not filled.
+@end deffn
+
+@subsection Arc Ink
+
+A draw-ink rendered with @code{gdk_draw_arc}. Its width and height
+are the dimensions of the bounding box for the entire ellipse, though
+only a portion may be drawn. The portion drawn starts with a
+start-angle and ends after a certain amount of sweep-angle.
+
+@deffn Class <arc-ink>
+A direct subclass of draw-ink.
+@end deffn
+
+@deffn Procedure arc-ink? object
+Type predicate.
+@end deffn
+
+@deffn Procedure make-arc-ink
+A new arc-ink.
+@end deffn
+
+@deffn Procedure set-arc-ink! arc x y width height
+Sets the position and size of @var{arc}'s entire ellipse.
+@end deffn
+
+@deffn Procedure arc-ink-start-angle arc
+@var{Arc}'s start-angle.
+@end deffn
+
+@deffn Procedure set-arc-ink-start-angle! arc degrees
+Sets @var{arc}'s start-angle.
+@end deffn
+
+@deffn Procedure arc-ink-sweep-angle arc
+@var{Arc}'s sweep-angle.
+@end deffn
+
+@deffn Procedure set-arc-ink-sweep-angle! arc degrees
+Sets @var{arc}'s sweep-angle.
+@end deffn
+
+@deffn Procedure arc-ink-color arc
+@code{()} if @var{arc}'s line color is not set, else the color last
+provided to @bref{set-arc-ink-color!}.
+@end deffn
+
+@anchor{set-arc-ink-color!}
+@deffn Procedure set-arc-ink-color! arc color
+Sets @var{arc}'s line color. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{rectangle} might appear. This is not the fill color.
+@end deffn
+
+@deffn Procedure arc-ink-width arc
+@code{()} if @var{arc}'s line width not set, else the width last
+provided to @bref{set-arc-ink-width!}.
+@end deffn
+
+@anchor{set-arc-ink-width!}
+@deffn Procedure set-arc-ink-width! arc width
+Sets the width of the line used to draw @var{arc}.
+@end deffn
+
+@deffn Procedure arc-ink-fill-color arc
+@code{()} if @var{arc}'s fill color is not set, else the color last
+provided to @bref{set-arc-ink-fill-color!}.
+@end deffn
+
+@anchor{set-arc-ink-fill-color!}
+@deffn Procedure set-arc-ink-fill-color! arc color
+Sets @var{arc}'s fill color. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{arc} might appear. If @var{color} is #f, @var{arc} is not
+filled.
+@end deffn
+
+@subsection Text Ink
+
+A draw-ink rendered with @code{gdk_draw_layout} applied to a
+PangoLayout from an abstract ``pango-layout'' slot.
+
+@deffn Class <text-ink>
+An abstract, direct subclass of draw-ink.
+@end deffn
+
+@deffn Procedure text-ink? object
+Type predicate.
+@end deffn
+
+@deffn Procedure set-text-ink-position! text x y
+Sets the position of the upper left corner of @var{text}, a text-ink.
+@end deffn
+
+@deffn Procedure text-ink-xy-to-index text x y
+If (@var{x}, @var{y}) is in @var{text}'s extent, return the index of
+the character at that point, else #f.
+@end deffn
+
+@deffn Procedure with-text-ink-grapheme-rect text index receiver
+Applies @var{receiver} to the position and size (four fixnums) of the
+@var{index}th character in @var{text}'s text. If @var{text} has no
+text, this procedure just returns #f; it does not apply
+@var{receiver}. It normally returns @var{receiver}'s return value.
+@end deffn
+
+@deffn Procedure text-ink-color text
+@code{()} if @var{text}'s color is not set, else the color last
+provided to @bref{set-text-ink-color!}.
+@end deffn
+
+@anchor{set-text-ink-color!}
+@deffn Procedure set-text-ink-color! text color
+Sets @var{text}'s default color. @var{Color} should be a string
+acceptable to @bref{gtk-widget-parse-color} for every widget in which
+@var{text} might appear.
+@end deffn
+
+@subsection Simple Text Ink
+
+A text-ink whose abstract pango-layout slot is implemented by an
+actual instance slot.
+
+@deffn Class <simple-text-ink>
+A direct subclass of text-ink.
+@end deffn
+
+@deffn Procedure simple-text-ink? object
+Type predicate.
+@end deffn
+
+@deffn Procedure make-simple-text-ink
+A new simple-text-ink.
+@end deffn
+
+@deffn Procedure simple-text-ink-text ink
+@var{Ink}'s text --- a string.
+@end deffn
+
+@deffn Procedure set-simple-text-ink-text! ink widget string
+Sets @var{ink}'s text to @var{string}, using @var{widget}'s font and
+direction. It is assumed @var{widget} is compatible with all widgets
+displaying @var{ink}. See @bref{set-fix-layout-drawing!}.
+@end deffn
+
+@deffn Procedure simple-text-ink-font text
+#f or a PangoFontDescription alien.
+@end deffn
+
+@deffn Procedure set-simple-text-ink-font! text font
+Sets @var{text}'s pango layout's font to @var{font}. @var{Font}
+should be a PangoFontDescription, or a string acceptable to
+@bref{pango-font-description-from-string} (e.g. @code{"courier 12"}).
+@end deffn
+
+@subsection Image Ink
+
+A draw-ink rendered by @code{gdk_draw_pixbuf}. It uses a
+pixbuf-loader so that it can render the pixbuf as it loads.
+
+@deffn Class <image-ink>
+A direct subclass of fix-ink.
+@end deffn
+
+@deffn Procedure make-image-ink-from-file filename
+A new image-ink whose pixbuf-loader is loading from @var{filename}.
+@end deffn
+
+@deffn Procedure set-image-ink! image x y
+Set the position of @var{image} to (@var{x}, @var{y}).
+@end deffn
+
+@subsection Box Ink
+
+A fix-ink rendered by @code{gtk_paint_box}.
+
+@deffn Class <box-ink>
+A direct subclass of fix-ink.
+@end deffn
+
+@deffn Procedure box-ink? object
+Type predicate.
+@end deffn
+
+@deffn Procedure make-box-ink
+A new box-ink.
+@end deffn
+
+@deffn Procedure set-box-ink! box x y width height
+Resizes @var{box} to @var{width} and @var{height}, and moves it
+to (@var{x}, @var{y}). If @var{box} is already at the specified
+position and size, this procedure does nothing.
+@end deffn
+
+@deffn Procedure set-box-ink-position! box x y
+Moves @var{box} to place its upper-left corner at point (@var{x},
+@var{y}). If @var{box} is already at the specified position, this
+procedure does nothing.
+@end deffn
+
+@deffn Procedure box-ink-shadow box
+The type of shadow with which @var{box} will be drawn --- one of the
+symbols @code{none}, @code{in}, @code{out}, @code{etched-in}, or
+@code{etched-out}.
+@end deffn
+
+@deffn Procedure set-box-ink-shadow! box type
+Sets @var{box}'s shadow to @var{type}, which should be one of the
+symbols @code{none}, @code{in}, @code{out}, @code{etched-in}, or
+@code{etched-out}.
+@end deffn
+
+@node Gdk Functions, Debugging Facilities, Fix Layout, API Reference
+@section Gdk Functions
+
+@deffn Procedure gdk-window-process-updates window children-too?
+Force expose events to be delivered immediately and synchronously to
+@var{window}. This is occasionally useful, e.g. to produce nicer
+scrolling behavior. @var{Children-too?} should be #f to avoid
+sending expose events to child windows.
+@end deffn
+
+@anchor{gdk-key-state->char-bits}
+@deffn Procedure gdk-key-state->char-bits modifier-state
+A bitmap of char-bits (char-bit:control, char-bit:meta,
+char-bit:super, and char-bit:hyper) corresponding to the bits set in
+@var{modifier-state}, a GdkModifierType bitmap from a key or button
+event.
+@end deffn
+
+@anchor{gdk-keyval->name}
+@deffn Procedure gdk-keyval->name keyval
+The key name (character or symbol) associated with the Gdk
+@var{keyval}.
+@end deffn
+
+@node Debugging Facilities, , Gdk Functions, API Reference
+@section Debugging Facilities
+
+@deffn Procedure kill-gtk-thread
+A convenient procedure to call in an emergency.
+@end deffn
+
+@deffn Procedure gtk-time-slice-window?
+#t if the time slice window is open, else #f.
+@end deffn
+
+@deffn Procedure gtk-time-slice-window! open?
+If @var{open?} is #f, the time slice window is closed, else it is opened.
+@end deffn
+
+@deffn Procedure gtk-select-trace?
+#t if Scheme's GSource is being traced, else #f.
+@end deffn
+
+@deffn Procedure gtk-select-trace! trace?
+If @var{trace?} is #t, turns on tracing of Scheme's GSource.
+@end deffn
+
+@node Installation, Implementation Notes, API Reference, Top
+@chapter Installation
+
+If you have a recent version of MIT-Scheme (with C/Unix FFI)
+installed, you can build the snapshot with
@smallexample
- ../microcode/scheme --library ../lib
- (load-option 'GTK)
- (gtk-event-viewer)
+ ./configure; make
@end smallexample
-The code can be found in @file{gtk-ev.scm}.
+If your MIT-Scheme does not include the FFI, you will need to install
+a version that does, like this:
+
+@smallexample
+./configure --without-gtk
+make
+make install
+@end smallexample
+Depending on configuration options and file-system permissions, you
+may need super-user privileges to do the installation step.
-@node Scm-Layout, GNU Free Documentation License, Gtk-Event-Viewer, Top
-@chapter Scm-Layout
+To verify your install, check that your @code{mit-scheme} command
+invokes a Scheme with the FFI. Execute the following command line.
-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.
+@smallexample
+ echo "(load-option 'FFI)" | mit-scheme --batch-mode
+@end smallexample
-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.
+If that command completes without complaint, you are ready to
-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.
+@smallexample
+ make clean; ./configure; make
+@end smallexample
-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>}.
+If this process falters, please feel free to contact the author.
-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. To see these widgets in action, execute the following
-command lines in the @file{src/gtk} directory of your build tree.
+@node Implementation Notes, GNU Free Documentation License, Installation, Top
+@chapter Implementation Notes
+
+This chapter is for the hapless debugger, or potential widget
+developer. It provides an overview of the mechanisms behind the
+scenes, like gtk-thread.
+
+The procedures implementing the API are thin wrappers, 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
- ../microcode/scheme --library ../lib
- (load-option 'Gtk)
- (scm-layout-demo)
+ (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 can be found in @file{demo.scm}.
+The @code{gtk-label-get-text} wrapper procedure hides these details.
+
+@smallexample
+ (gtk-label-get-text label)
+@result{} "!dlrow ,olleH"
+@end smallexample
+
+In the example call to @code{gtk-label-get-text} above, a Scheme
+object represents the GtkLabel. It is a gtk-label instance, whose
+class is a specialization of the abstract gtk-object class.
+@unnumberedsec Gtk Thread
-@node GNU Free Documentation License, , Scm-Layout, Top
+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.
+
+@unnumberedsec Toolkit Resource Usage
+
+Each gobject instance is tracked by the weak alist @code{gc-cleanups},
+so that the toolkit object can be @code{g_object_unref}'ed when the
+instance is GCed.
+
+The initialize-instance method for subclasses of gobject should chain
+up early, adding the instance's alien to gc-cleanups @emph{before}
+calling out to the toolkit. This ensures that an allocated toolkit
+object will not be dropped; its alien address is on the list of GC
+cleanups before it is even allocated. @emph{After} the callout, the
+method should also @code{g_object_ref_sink} any floating refs it
+receives.
+
+The following scenarios are typical of Gtk resource management.
+
+Temporary alien: The (alien) address of a PangoFontDescription
+is read from a PangoLayout member. The layout ``owns'' the
+font description. Scheme does not. The address should only be used
+while without-toolkit (or without-interrupts), else the
+toolkit may "dispose" of it while Scheme is using it.
+
+Schemely: A toolkit object is created and reflected in Scheme by a
+gobject instance. Scheme owns the toolkit object, holds a reference,
+and should eventually @code{g_object_unref} it. The instance may be
+shared among any number of Scheme widgets or other data structures
+(e.g a file->pixbuf cache) and @emph{never} explicitly ``killed''.
+When there are no more Scheme objects sharing the toolkit object, it
+will be GCed and its GC cleanup procedure will ``kill''
+(@code{g_object_unref}) the toolkit object. This may release toolkit
+resources or not, depending on references elsewhere in the toolkit
+data structures. In any case, the instance was GCed so the toolkit
+object is dead to Scheme.
+
+Signals: The @bref{g-signal-connect} procedure takes pains not to hold
+a strong reference to a gobject instance. These instances can be GCed
+even while signal handlers are connected. The registered callbacks
+hold only a weak reference to the instance. It is assumed a callback
+will not be invoked after an instance is GCed, else an error should be
+signaled.
+
+TODO: A world save hook might warn of gobject instances still on the
+gc-cleanups list. A world restore hook could kill them.
+
+@node GNU Free Documentation License, , Implementation Notes, Top
@appendix GNU Free Documentation License
@center Version 1.2, November 2002
# **** END BOILERPLATE ****
-LIARC_BOOT_BUNDLES = compiler cref sf star-parser
-LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml $(FFIS)
+LIARC_BOOT_BUNDLES = compiler cref sf star-parser ffi
+LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin imail sos ssp xml $(FFIS)
FFIS = @FFIS@
SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc
* "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" contains miscellaneous files for building the program.
+* "gtk" provides a Schemely interface to GNOME. It features a Scheme
+ canvas widget and limited SWAT emulation.
+
* "rcs" is a parser for RCS files. It also contains a program for
generating merged log files, in RCS or ChangeLog format, for
directory trees under RCS or CVS control.
maybe_link lib/include ../microcode
maybe_link lib/optiondb.scm ../etc/optiondb.scm
maybe_link lib/runtime ../runtime
+maybe_link lib/sos ../sos
maybe_link lib/mit-scheme.h ../microcode/pruxffi.h
maybe_link lib/ffi ../ffi
maybe_link lib/gtk ../gtk
: ${enable_debugging='no'}
AC_ARG_WITH([gtk],
- AS_HELP_STRING([--with-gtk],
- [Support the GNOME Toolkits if available [[yes]]]))
-: ${with_gtk='yes'}
+ [AS_HELP_STRING([--with-gtk],
+ [Support the GNOME Toolkits [[auto]]])],
+ [],
+ [with_gtk=auto])
AC_CANONICAL_HOST
AC_MSG_RESULT([yes])
fi
-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])
- with_gtk=no
- elif ! "${MIT_SCHEME_EXE}" --eval "(load-option'FFI)" \
- --batch-mode </dev/null >/dev/null 2>&1; then
- AC_MSG_RESULT([no, no FFI])
- with_gtk=no
- else
- if pkg-config --exists gtk+-2.0; then
- AC_MSG_RESULT([yes])
- FFIS=gtk
- else
- AC_MSG_RESULT([no, ! pkg-config --exists gtk+2.0])
- fi
- fi
-fi
-
AC_SUBST([ALL_TARGET])
AC_SUBST([FFIS])
AC_SUBST([INSTALL_COM])
m4_include(microcode/achost.ac)
+if test "${with_gtk}" = "yes"; then :;
+elif test "${with_gtk}" = "no"; then :;
+else echo "Warning: with_gtk is not yes|no: ${with_gtk}"; fi
+
AC_SUBST([CCLD])
AC_SUBST([DEFS])
AC_SUBST([CFLAGS])
xdoc/Makefile
xml/Makefile
])
-if test "${with_gtk}" = yes; then
+if test "${with_gtk}" = "yes"; then
AC_CONFIG_FILES([gtk/Makefile])
+ FFIS="${FFIS} gtk"
fi
AC_OUTPUT
(cd lib; rm -f ${BN}; ${LN_S} ../${BN} .)
done
BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml"
- if test x"${with_gtk}" = xyes; then BUNDLES="$BUNDLES gtk"; fi
+ if test "${with_gtk}" = yes; then BUNDLES="$BUNDLES gtk"; fi
for BUNDLE in $BUNDLES; do
SO=${BUNDLE}.so
(cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .)
(initializations '())
(finalizations '())
(exports '())
- (imports '()))
+ (imports '())
+ (depends-on '()))
(define-structure (pmodel (conc-name pmodel/))
(root-package #f read-only #t)
(packages #f read-only #t)
(extra-packages #f read-only #t)
(loads #f read-only #t)
+ (declarations #f read-only #t)
(pathname #f read-only #t))
(define-structure (package
(children '())
(bindings (make-rb-tree eq? symbol<?) read-only #t)
(references (make-rb-tree eq? symbol<?) read-only #t)
- (links '()))
+ (links '())
+ (depends-on '()))
(define-integrable (package/n-files package)
(length (package/files package)))
\f
(define (read-package-model filename os-type)
(let ((model-pathname (merge-pathnames filename)))
- (receive (packages extensions loads globals)
+ (receive (packages extensions loads globals declares)
(sort-descriptions (read-and-parse-model model-pathname os-type))
(descriptions->pmodel
packages
(warn "Can't find package-description file:" pathname)
#f)))))
globals)
+ declares
model-pathname))))
\f
(define (sort-descriptions descriptions)
(letrec
((loop
- (lambda (descriptions packages extensions loads globals)
+ (lambda (descriptions packages extensions loads globals declares)
(if (pair? descriptions)
(let ((description (car descriptions))
(descriptions (cdr descriptions)))
(if (interesting-package-to-load? (cdr description))
(cons (cdr description) loads)
loads)
- globals))
+ globals
+ declares))
((EXTEND-PACKAGE)
(loop descriptions
packages
(if (interesting-package-to-load? (cdr description))
(cons (cdr description) loads)
loads)
- globals))
+ globals
+ declares))
((GLOBAL-DEFINITIONS)
(loop descriptions
packages
extensions
loads
- (append! (reverse (cdr description)) globals)))
+ (append! (reverse (cdr description)) globals)
+ declares))
+ ((DECLARE)
+ (loop descriptions
+ packages
+ extensions
+ loads
+ globals
+ (append! (reverse (cdr description)) declares)))
((NESTED-DESCRIPTIONS)
- (receive (packages extensions loads globals)
+ (receive (packages extensions loads globals declares)
(loop (cdr description)
packages
extensions
loads
- globals)
- (loop descriptions packages extensions loads globals)))
+ globals
+ declares)
+ (loop descriptions packages extensions loads
+ globals declares)))
(else
(error "Unknown description keyword:" (car description)))))
- (values packages extensions loads globals)))))
- (receive (packages extensions loads globals)
- (loop descriptions '() '() '() '())
+ (values packages extensions loads globals declares)))))
+ (receive (packages extensions loads globals declares)
+ (loop descriptions '() '() '() '() '())
(values (reverse! packages)
(reverse! extensions)
(reverse! loads)
- (reverse! globals)))))
+ (reverse! globals)
+ (reverse! declares)))))
(define (interesting-package-to-load? description)
(or (pair? (package-description/file-cases description))
(merge-pathnames filename pathname)
os-type))
filenames))))
+ ((DECLARE) expression)
(else
(lose)))))
\f
package
(append! (package-description/finalizations package)
(list finalization))))))
+ ((DEPENDS-ON)
+ (if (not (check-list (cdr option) string?))
+ (error "illegal dependencies" option))
+ (set-package-description/depends-on!
+ package
+ (append! (package-description/depends-on package)
+ (map parse-filename (cdr option)))))
(else
(error "Unrecognized option keyword:" (car option)))))
options))
\f
;;;; Packages
-(define (descriptions->pmodel descriptions extensions loads globals pathname)
+(define (descriptions->pmodel descriptions extensions loads
+ globals declares pathname)
(let ((packages
(map (lambda (description)
(make-package (package-description/name description) 'UNKNOWN))
#f)
package))
loads)
+ declares
pathname)))))
\f
(define (process-globals-info file namestring get-package)
(append-map! (lambda (file-case)
(append-map cdr (cdr file-case)))
file-cases))))
+ (let ((dependencies (package-description/depends-on description)))
+ (set-package/depends-on!
+ package
+ (append! (package/depends-on package) (list-copy dependencies))))
(for-each (lambda (export)
(let ((destination (get-package (car export) #t)))
(for-each (lambda (names)
(with-working-directory-pathname "sos"
(lambda ()
(load "load")))
- (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp" "ffi")))
+ (for-each compile-dir '("xml" "win32" "edwin" "imail" "ssp")))
+
+(define (compile-ffi dir)
+ (if (eq? microcode-id/compiled-code-type 'C)
+ (c-compile-dir dir)
+ (compile-dir dir)))
(define (compile-boot-dirs compile-dir)
(compile-cref compile-dir)
- (for-each compile-dir '("runtime" "cref" "sf" "compiler" "star-parser")))
+ (for-each compile-dir
+ '("runtime" "cref" "sf" "compiler" "star-parser" "ffi")))
(define (compile-cref compile-dir)
(compile-dir "cref")
FILES=
DIRS=
for FN in "${@}"; do
- if [ ! -L "${FN}" ]; then
- if [ -f "${FN}" ]; then
- FILES="${FILES} ${FN}"
- elif [ -d "${FN}" ]; then
- DIRS="${DIRS} ${FN}"
- fi
+ if [ -L "${FN}" ]; then
+ FILES="${FILES} ${FN}"
+ elif [ -f "${FN}" ]; then
+ FILES="${FILES} ${FN}"
+ elif [ -d "${FN}" ]; then
+ DIRS="${DIRS} ${FN}"
fi
done
if [ "${FILES}" ]; then
gtk-shim.c
gtk-shim.so
scmwidget.c
+swat-pole-zero.scm
../etc/Clean.sh "${1}"
. ../etc/functions.sh
-maybe_rm gtk-shim.c gtk-const* gtk-types*
+maybe_rm gtk-shim.c gtk-const* gtk-types* swat-pole-zero*
maybe_rm ../lib/conses.png
maybe_rm ../lib/gtk-* ../lib/prgtkio.so
# And, just because the maintainer- and c-clean targets nail this one anyway:
(include "gparamspecs")
(include "gsignal")
-;(include "gdkcairo")
+(include "gdkcairo")
(include "gdkcolor")
(include "gdkcursor")
;(include "gdkdisplay")
;(include "gdkselection")
;(include "gdkspawn")
(include "gdktypes")
-;(include "gdkvisual")
+(include "gdkvisual")
(include "gdkwindow")
(extern gboolean gdk_rectangle_intersect
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-2.0/gdk/gdkcairo.h |#
+
+(include "gdkcolor")
+;(include "gdkpixbuf")
+(include "pangocairo")
+
+(extern (* cairo_t) gdk_cairo_create
+ (drawable (* GdkDrawable)))
+#;(extern void gdk_cairo_reset_clip
+ (cr (* cairo_t))
+ (drawable (* GdkDrawable)))
+
+#;(extern void gdk_cairo_set_source_color
+ (cr (* cairo_t))
+ (color (const (* GdkColor))))
+#;(extern void gdk_cairo_set_source_pixbuf
+ (cr (* cairo_t))
+ (pixbuf (const (* GdkPixbuf)))
+ (pixbuf_x double)
+ (pixbuf_y double))
+#;(extern void gdk_cairo_set_source_pixmap
+ (cr (* cairo_t))
+ (pixmap (* GdkPixmap))
+ (pixmap_x double)
+ (pixmap_y double))
+
+#;(extern void gdk_cairo_rectangle
+ (cr (* cairo_t))
+ (rectangle (const (* GdkRectangle))))
+#;(extern void gdk_cairo_region
+ (cr (* cairo_t))
+ (region (const (* GdkRegion))))
\ No newline at end of file
gtk-2.0/gdk/gdkdrawable.h |#
-;(include "gdktypes")
-;(include "gdkgc")
-;(include "gdkrgb")
-;(include "gdk-pixbuf")
-;(include "cairo")
+(include "gdktypes")
+(include "gdkgc")
+(include "gdkrgb")
+(include "gdk-pixbuf")
+(include "cairo")
(typedef GdkDrawableClass (struct _GdkDrawableClass))
(typedef GdkTrapezoid (struct _GdkTrapezoid))
(x12 double)
(x22 double))
-(extern void gdk_draw_rectangle
+(extern void gdk_draw_line ;gtk-2.20.1
+ (drawable (* GdkDrawable))
+ (gc (* GdkGC))
+ (x1 gint) (y1 gint)
+ (x2 gint) (y2 gint))
+
+(extern void gdk_draw_rectangle ;gtk-2.20.1
(drawable (* GdkDrawable))
(gc (* GdkGC))
(filled gboolean)
(width gint)
(height gint))
+(extern void gdk_draw_arc ;gtk-2.20.1
+ (drawable (* GdkDrawable))
+ (gc (* GdkGC))
+ (filled gboolean)
+ (x gint)
+ (y gint)
+ (width gint)
+ (height gint)
+ (angle1 gint)
+ (angle2 gint))
+
+(extern void gdk_draw_layout
+ (drawable (* GdkDrawable))
+ (gc (* GdkGC))
+ (x gint) (y gint)
+ (layout (* PangoLayout)))
+
(extern void gdk_draw_pixbuf
(drawable (* GdkDrawable))
(gc (* GdkGC))
gtk-2.0/gdk/gdkgc.h |#
-;(include "gdkcolor")
-;(include "gdktypes")
+(include "gdkcolor")
+(include "gdktypes")
(typedef GdkGCValues (struct _GdkGCValues))
(typedef GdkGCClass (struct _GdkGCClass))
(struct _GdkGCClass
(parent_class GObjectClass)
(get_values (* (function void
- (gc (* GdkGC))
+ (gc (* GdkGC))
(values (* GdkGCValues)))))
(set_values (* (function void
- (GdkGC *gc)
- (GdkGCValues *values)
- (GdkGCValuesMask mask))))
+ (gc (* GdkGC))
+ (values (* GdkGCValues))
+ (mask GdkGCValuesMask))))
(set_dashes (* (function void
(gc (* GdkGC))
(dash_offset gint)
; (drawable (* GdkDrawable))
; (values (* GdkGCValues))
; (values_mask GdkGCValuesMask))
-;(extern void gdk_gc_get_values
-; (gc (* GdkGC))
-; (values (* GdkGCValues)))
+(extern void gdk_gc_get_values
+ (gc (* GdkGC))
+ (values (* GdkGCValues)))
;(extern void gdk_gc_set_values
; (gc (* GdkGC))
; (values (* GdkGCValues))
(enum
(GDK_RGB_DITHER_NONE)
(GDK_RGB_DITHER_NORMAL)
- (GDK_RGB_DITHER_MAX)))
\ No newline at end of file
+ (GDK_RGB_DITHER_MAX)))
+
+(extern void gdk_rgb_find_color ;gtk+-2.8.20
+ (colormap (* GdkColormap))
+ (color (* GdkColor)))
\ No newline at end of file
(typedef GdkColormap (struct _GdkColormap))
(typedef GdkCursor (struct _GdkCursor))
;(typedef GdkFont (struct _GdkFont))
-;(typedef GdkGC (struct _GdkGC))
+(typedef GdkGC (struct _GdkGC))
;(typedef GdkImage (struct _GdkImage))
;(typedef GdkRegion (struct _GdkRegion))
-;(typedef GdkVisual (struct _GdkVisual))
+(typedef GdkVisual (struct _GdkVisual))
(typedef GdkDrawable (struct _GdkDrawable))
(typedef GdkBitmap (struct _GdkDrawable))
;(typedef GdkDisplay (struct _GdkDisplay))
;(typedef GdkScreen (struct _GdkScreen))
+(typedef GdkByteOrder
+ (enum
+ (GDK_LSB_FIRST)
+ (GDK_MSB_FIRST)))
+
(typedef GdkModifierType
(enum
(GDK_SHIFT_MASK)
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-2.0/gdk/gdkvisual.h |#
+
+(include "gdktypes")
+
+(typedef GdkVisualType
+ (enum
+ (GDK_VISUAL_STATIC_GRAY)
+ (GDK_VISUAL_GRAYSCALE)
+ (GDK_VISUAL_STATIC_COLOR)
+ (GDK_VISUAL_PSEUDO_COLOR)
+ (GDK_VISUAL_TRUE_COLOR)
+ (GDK_VISUAL_DIRECT_COLOR)))
+
+(struct _GdkVisual
+ (parent_instance GObject)
+ (type GdkVisualType)
+ (depth gint)
+ (byte_order GdkByteOrder)
+ (colormap_size gint)
+ (bits_per_rgb gint)
+
+ (red_mask guint32)
+ (red_shift gint)
+ (red_prec gint)
+
+ (green_mask guint32)
+ (green_shift gint)
+ (green_prec gint)
+
+ (blue_mask guint32)
+ (blue_shift gint)
+ (blue_prec gint))
\ No newline at end of file
gtk-2.0/gdk/gdkwindow.h |#
-;(include "gdkdrawable")
-;(include "gdktypes")
-;(include "gdkevents")
+(include "gdkdrawable")
+(include "gdktypes")
+(include "gdkevents")
(typedef GdkGeometry (struct _GdkGeometry))
(typedef GdkWindowAttr (struct _GdkWindowAttr))
;(include "gtkfilechooserwidget")
;(include "gtkfontbutton")
;(include "gtkfontsel")
-;(include "gtkframe")
+(include "gtkframe")
;(include "gtkgamma")
-;(include "gtkgc")
+(include "gtkgc")
;(include "gtkhandlebox")
;(include "gtkhbbox")
-;(include "gtkhbox")
+(include "gtkhbox")
;(include "gtkhpaned")
;(include "gtkhruler")
;(include "gtkhscale")
;(include "gtkinvisible")
;(include "gtkitem")
;(include "gtkitemfactory")
-;(include "gtklabel")
+(include "gtklabel")
;(include "gtklayout")
;(include "gtklist")
;(include "gtklistitem")
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-2.0/gtk/gtkframe.h |#
+
+;(include "gtkbin")
+
+
+(extern (* GtkWidget)
+ gtk_frame_new
+ (label (* (const gchar))))
+
+(extern void
+ gtk_frame_set_shadow_type
+ (frame (* GtkFrame))
+ (type GtkShadowType))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+gtk+-2.20.1/gtk/gtkgc.h |#
+
+(extern (* GdkGC) gtk_gc_get
+ (depth gint)
+ (colormap (* GdkColormap))
+ (values (* GdkGCValues))
+ (values_mask GdkGCValuesMask))
+
+(extern void gtk_gc_release
+ (gc (* GdkGC)))
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-2.0/gtk/gtkhbox.h |#
+
+(extern (* GtkWidget)
+ gtk_hbox_new
+ (homogeneous gboolean)
+ (spacing gint))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-2.0/gtk/gtklabel.h |#
+
+;(include "gtkmisc")
+(include "gtkwindow")
+;(include "gtkmenu")
+
+(extern (* GtkWidget)
+ gtk_label_new
+ (str (* (const char))))
+
+(extern (* (const gchar))
+ gtk_label_get_text
+ (label (* GtkLabel)))
+
+(extern void gtk_label_set_text
+ (label (* GtkLabel))
+ (str (* (const char))))
+
+(extern void gtk_label_set_width_chars
+ (label (* GtkLabel))
+ (n_chars gint))
\ No newline at end of file
(struct _GtkObject
(parent_instance GObject)
+ ;; GtkWidgetFlags share these 32bits.
(flags guint32))
(struct _GtkObjectClass
(color_name (const (* gchar)))
(color (* GdkColor)))
-(extern void gtk_paint_hline
+#;(extern void gtk_paint_hline
(style (* GtkStyle))
(window (* GdkWindow))
(state_type GtkStateType)
(x2 gint)
(y gint))
-(extern void gtk_paint_vline
+#;(extern void gtk_paint_vline
(style (* GtkStyle))
(window (* GdkWindow))
(state_type GtkStateType)
gtk-2.0/gtk/gtkwidget.h |#
-;(include "gdk")
+(include "gdk")
;(include "gtkaccelgroup")
-;(include "gtkobject")
-;(include "gtkadjustment")
-;(include "gtkstyle")
+(include "gtkobject")
+(include "gtkadjustment")
+(include "gtkstyle")
;(include "gtksettings")
;(include "atkobject")
(extern void gtk_widget_destroy
(widget (* GtkWidget)))
+(extern void gtk_widget_show
+ (widget (* GtkWidget)))
+
(extern void gtk_widget_show_all
(widget (* GtkWidget)))
(width gint)
(height gint))
+(extern void gtk_widget_queue_resize
+ (widget (* GtkWidget)))
+
+(extern void gtk_widget_set_can_focus
+ (widget (* GtkWidget))
+ (can_focus gboolean))
+
(extern void gtk_widget_grab_focus
(widget (* GtkWidget)))
+(extern void gtk_widget_set_has_window
+ (widget (* GtkWidget))
+ (has_window gboolean))
+
+(extern void gtk_widget_set_realized
+ (widget (* GtkWidget))
+ (realized gboolean))
+
(extern (* GdkWindow) gtk_widget_get_parent_window
(widget (* GtkWidget)))
+(extern void gtk_widget_set_window
+ (widget (* GtkWidget))
+ (window (* GdkWindow)))
+
(extern void gtk_widget_error_bell
(widget (* GtkWidget)))
(extern (* GdkColormap) gtk_widget_get_colormap
(widget (* GtkWidget)))
-(extern (* GdkVisual) gtk_widget_get_visual
- (widget (* GtkWidget)))
+
+;;(extern (* GdkVisual) gtk_widget_get_visual
+;; (widget (* GtkWidget)))
+
+;;(extern void gtk_widget_set_colormap
+;; (widget (* GtkWidget))
+;; (colormap (* GdkColormap)))
(extern gint gtk_widget_get_events
(widget (* GtkWidget)))
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 (* PangoContext)
gtk_widget_get_pango_context (widget (* GtkWidget)))
(window (* GtkWindow))
(title (* (const gchar))))
+(extern void
+ gtk_window_set_opacity
+ (window (* GtkWindow))
+ (opacity gdouble))
+
+(extern gdouble
+ gtk_window_get_opacity
+ (window (* GtkWindow)))
+
(extern void
gtk_window_set_geometry_hints
(window (* GtkWindow))
(extern void pango_font_description_free (desc (* PangoFontDescription)))
+(extern (* PangoFontDescription)
+ pango_font_description_copy
+ (desc (* (const PangoFontDescription))))
+
(extern (* PangoFontDescription)
pango_font_description_from_string
(str (* (const char))))
(ink_rect (* PangoRectangle))
(logical_rect (* PangoRectangle)))
+(extern void pango_layout_context_changed
+ (layout (* PangoLayout)))
+
(extern void pango_layout_index_to_pos
(layout (* PangoLayout))
(index int)
TARGET_DIR = $(AUXDIR)/gtk
+MIT_SCHEME_EXE = @MIT_SCHEME_EXE@
+
generate: ../lib/gtk-shim.so ../lib/gtk-types.bin ../lib/gtk-const.bin \
../lib/conses.png
$(INSTALL_DATA) conses.png $@
build:
- echo '(load "gtk.sf")(load "gtk.cbf")' \
- | ../microcode/scheme --library ../lib --compiler --batch-mode
+ if [ ! -e swat-pole-zero.scm ]; then \
+ ln -sf ../swat/scheme/other/pole-zero.scm swat-pole-zero.scm; fi
+ cd ../; echo '(load "etc/compile.scm")(compile-ffi "gtk")' \
+ | microcode/scheme --library lib --batch-mode
+
+liarc-build:
+ $(MAKE) compile-liarc-bundle gtk
install:
rm -rf $(DESTDIR)$(TARGET_DIR)
gtk-shim.c gtk-const.c gtk-types.bin: gtk.cdecl Includes/*.cdecl
(echo "(load-option 'FFI)"; \
echo '(C-generate "gtk" "#include \"gtk-shim.h\"")') \
- | mit-scheme --batch-mode
+ | $(MIT_SCHEME_EXE) --batch-mode
gtk-const.bin: gtk-const.scm
- echo '(sf "gtk-const")' | mit-scheme --compiler --batch-mode
+ echo '(sf "gtk-const")' | $(MIT_SCHEME_EXE) --batch-mode
gtk-const.scm: gtk-const
./gtk-const
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 2007, 2008, 2009, 2010 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)
-
-(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 (demo-layout-new 200 200))
- (layout2 (demo-layout-new 200 200)))
- (gtk-window-set-title window "scm-layout-demo")
- (gtk-window-set-default-size window 200 400)
- (set-gtk-window-delete-event-callback!
- window (lambda () (outf-console "; Closed "window".\n") 0))
- (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)
-
- (let ((drawing (demo-drawing layout1)))
-
- (set-scm-layout-drawing! layout1 drawing)
- (set-scm-layout-scroll-pos! layout1 175 150)
-
- (set-scm-layout-drawing! layout2 drawing)
- (set-scm-layout-scroll-pos! layout2 175 150)
-
- (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"))))
- (gtk-widget-grab-focus layout1)
- (outf-console "; Created "layout1" and "layout2"\n"))
- unspecific)
-
-(define (demo-layout-new width height)
- (let ((layout (scm-layout-new width height)))
- (set-scm-layout-motion-handler! layout demo-motion-handler)
- (set-scm-layout-button-release-handler! layout demo-button-release-handler)
- (set-scm-layout-key-press-handler! layout demo-key-press-handler)
- layout))
-
-(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-motion-handler layout window-x window-y)
- (trace2 ";(demo-motion-handler "layout" "window-x" "window-y")\n")
- (let* ((drawing (scm-layout-drawing layout))
- (scroll (scm-layout-on-screen-area layout))
- (x (int:+ window-x (rect-x scroll)))
- (y (int:+ window-y (rect-y scroll))))
- (trace2 "; Pointer moved to ("x","y") in "layout".\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 layout (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 layout x y)))
- 1 ;;Handled.
- )
-
-(define (demo-button-release-handler layout window-x window-y)
- (trace2 ";(demo-button-release-handler "layout" "window-x" "window-y")\n")
- (let* ((drawing (scm-layout-drawing layout))
- (scroll (scm-layout-on-screen-area layout))
- (x (int:+ window-x (rect-x scroll)))
- (y (int:+ window-y (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 layout x y)))
- 1 ;;Handled.
- )
-
-(define (demo-key-press-handler layout keyval char-bits)
- (trace2 ";(demo-key-press-handler "layout" "keyval" "char-bits")\n")
- (if (and (char? keyval) (char=? keyval #\D))
- (bkpt 'Test)
- 0 ;;NOT handled.
- ))
-
-(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
'#(
("gtk" (gtk))
("gobject" (gtk gobject))
+ ("pango" (gtk pango))
("gtk-object" (gtk gtk-object))
("scm-widget" (gtk widget))
- ("scm-layout" (gtk layout))
+ ("fix-layout" (gtk fix-layout))
+ ("keys" (gtk keys))
("thread" (gtk thread))
("main" (gtk main))
- ("pango" (gtk pango))
("gtk-ev" (gtk event-viewer))
- ("demo" (gtk demo))))
\ No newline at end of file
+ ("fix-demo" (gtk fix-layout demo))
+ ("swat" (gtk swat))
+ ("swat-pole-zero" (gtk swat))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010 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 fix-layout widgets.
+;;; package: (gtk demo)
+
+(define (make-fix-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 (make-demo-layout 200 200))
+ (layout2 (make-demo-layout 200 200)))
+ (gtk-window-set-opacity window 0.90)
+ (gtk-window-set-title window "fix-layout-demo")
+ (gtk-window-set-default-size window 200 400)
+ (set-gtk-window-delete-event-callback!
+ window (lambda (w) (trace "; Closed "w".\n") 0))
+ (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)
+
+ (let ((drawing (make-demo-drawing layout1)))
+ (let ((cursor1 (make-box-ink))
+ (cursor2 (make-box-ink)))
+ (set-box-ink-shadow! cursor1 'out)
+ (fix-drawing-add-ink! drawing cursor1 'bottom)
+ (fix-drawing-add-ink! drawing cursor2 'bottom)
+ (set-demo-drawing-cursor-inks!
+ drawing (list (list cursor1 layout1) (list cursor2 layout2))))
+ (let ((thread (start-blinking drawing)))
+ (trace "; Cursor blinking courtesy of "thread".\n"))
+ (let ((thread (start-spinning drawing)))
+ (trace "; Ring spinning courtesy of "thread".\n"))
+ (set-fix-layout-drawing! layout1 drawing 175 150)
+ (set-fix-layout-drawing! layout2 drawing 175 150))
+ (gtk-widget-grab-focus layout1)
+ (trace "; Created "layout1" and "layout2"\n"))
+ unspecific)
+
+(define-class (<demo-layout> (constructor () (width height)))
+ (<fix-layout>))
+
+(define-method initialize-instance ((layout <demo-layout>) width height)
+ (call-next-method layout width height)
+ (set-fix-layout-motion-handler! layout demo-motion-handler)
+ (set-fix-layout-button-handler! layout 'release demo-button-release-handler)
+ (set-fix-layout-key-press-handler! layout demo-key-press-handler)
+ layout)
+
+(define-method fix-layout-realize-callback ((widget <demo-layout>))
+ (call-next-method widget)
+ (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget)))
+
+(define (make-demo-drawing widget)
+ (let ((drawing (%make-demo-drawing)))
+ (trace ";make-demo-drawing: "drawing"\n")
+ (set-fix-drawing-size! drawing 500 500)
+ (let ((line1 (make-line-ink))
+ (line2 (make-line-ink))
+ (line3 (make-line-ink))
+ (arc (make-arc-ink))
+ (text (make-simple-text-ink))
+ (box (make-box-ink))
+ (image (make-image-ink-from-file
+ (merge-pathnames "conses.png"
+ (system-library-directory-pathname "")))))
+ (set-line-ink! line1 240 250 300 250)
+ (fix-drawing-add-ink! drawing line1)
+ (set-line-ink! line2 250 240 250 300)
+ (fix-drawing-add-ink! drawing line2)
+ (set-line-ink! line3 235 250 300 185)
+ (set-line-ink-width! line3 3)
+ (set-line-ink-color! line3 "blue")
+ (set-line-ink-dash-color! line3 "green")
+ (fix-drawing-add-ink! drawing line3)
+ (set-text-ink-position! text 250 250)
+ (set-simple-text-ink-text! text widget "Hello, World!")
+ (fix-drawing-add-ink! drawing text)
+ (set-box-ink! box 220 220 20 20)
+ (set-box-ink-shadow! box 'etched-in)
+ (fix-drawing-add-ink! drawing box)
+ (set-image-ink! image 270 200)
+ (fix-drawing-add-ink! drawing image)
+ (set-arc-ink! arc 240 190 30 30)
+ (set-arc-ink-width! arc 5)
+ (set-arc-ink-color! arc "gold")
+ (fix-drawing-add-ink! drawing arc)
+ drawing)))
+
+(define-class (<demo-drawing> (constructor %make-demo-drawing () no-init))
+ (<fix-drawing>)
+ ;; An alist of cursors and their widgets, for the blinking thread
+ ;; and mouse motion handler.
+ (cursor-inks define standard initial-value '()))
+
+(define (demo-motion-handler layout modifiers window-x window-y)
+ (trace2 ";motion-handler "layout" "modifiers" "window-x" "window-y"\n")
+ (let* ((drawing (fix-layout-drawing layout))
+ (view (fix-layout-view layout))
+ (x (+ window-x (fix-rect-x view)))
+ (y (+ window-y (fix-rect-y view))))
+ (trace2 "; Pointer moved to ("x","y") in "layout".\n")
+ (for-each
+ (lambda (ink)
+ (if (not (text-ink? ink))
+ (trace "; Picked: "ink"\n")
+ (let ((index (text-ink-xy-to-index ink x y))
+ (text-extent (fix-ink-extent ink)))
+ (trace "; Picked: "index" in "(simple-text-ink-text ink)"\n")
+ (with-text-ink-grapheme-rect
+ ink index
+ (lambda (xG yG widthG heightG)
+ (for-each
+ (lambda (cursor.widgets)
+ (if (memq layout (cdr cursor.widgets))
+ (begin
+ (set-box-ink!
+ (car cursor.widgets)
+ (+ xG (fix-rect-x text-extent))
+ (+ yG (fix-rect-y text-extent))
+ widthG heightG)
+ ;; Keep the cursor on while tracking the mouse.
+ (set-fix-ink-widgets!
+ (car cursor.widgets)
+ (cdr cursor.widgets)))))
+ (demo-drawing-cursor-inks drawing)))))))
+ (fix-drawing-pick-list drawing layout x y)))
+ #t)
+
+(define (demo-button-release-handler layout type button modifiers window-x window-y)
+ (trace2 ";button-release-handler "layout" "type" "button" "modifiers" "window-x" "window-y"\n")
+ (let* ((drawing (fix-layout-drawing layout))
+ (view (fix-layout-view layout))
+ (x (+ window-x (fix-rect-x view)))
+ (y (+ window-y (fix-rect-y view))))
+ (outf-console "; Pointer release at ("x","y").\n")
+ (for-each
+ (lambda (ink)
+ (if (not (text-ink? ink))
+ (trace "; Picked: "ink"\n")
+ (let ((index (text-ink-xy-to-index ink x y)))
+ (trace "; Picked: "ink" (char "index")\n"))))
+ (fix-drawing-pick-list drawing layout x y)))
+ #t)
+
+(define (demo-key-press-handler layout keyval char-bits)
+ (trace "; Key press on "layout"\n")
+ (outf-console "; Keyval: "keyval" "char-bits"\n")
+ (if (and (char? keyval) (char=? keyval #\D))
+ (bkpt 'Test))
+ ;;NOT handled.
+ #f)
+
+(define (start-spinning drawing)
+ (create-thread
+ #f
+ (lambda ()
+ (trace ";spinning start\n")
+ (let* ((frames 10)
+ (x 270) (y 190) (height 30) (width 30)
+ (pi (* (atan 1 1) 4))
+ (half-widths (make-vector frames))
+ (arc (find arc-ink? (fix-drawing-display-list drawing))))
+ (define-integrable (half-width angle)
+ (fix:1+ (truncate->exact (/ (* width (abs (cos angle))) 2))))
+ (do ((frame 0 (fix:1+ frame)))
+ ((= frame frames))
+ (vector-set! half-widths frame (half-width (* pi (/ frame frames)))))
+ (let loop ((frame 0))
+ (sleep-current-thread 100)
+ (let ((half-width (vector-ref half-widths frame)))
+ (let ((x (fix:- x half-width))
+ (width (fix:* 2 half-width)))
+ (trace2 ";spinning to "width"\n")
+ (set-arc-ink! arc x y width height)))
+ (let ((widgets (fix-drawing-widgets drawing)))
+ (if (and (not (null? widgets))
+ (for-all? widgets gtk-object-destroyed?))
+ (trace ";spinning ended\n")
+ (loop (modulo (fix:1+ frame) frames)))))))))
+
+(define (start-blinking drawing)
+ (create-thread
+ #f
+ (lambda ()
+ (trace ";blinking start\n")
+ (let loop ()
+ ;; Off!
+ (for-each (lambda (cursor.widgets)
+ (set-fix-ink-widgets! (car cursor.widgets) '()))
+ (demo-drawing-cursor-inks drawing))
+ (trace2 ";blinked off\n")
+ (sleep-current-thread 500)
+ ;; On!
+ (for-each (lambda (cursor.widgets)
+ (set-fix-ink-widgets! (car cursor.widgets)
+ (cdr cursor.widgets)))
+ (demo-drawing-cursor-inks drawing))
+ (trace2 ";blinked on\n")
+ (sleep-current-thread 500)
+ (if (there-exists?
+ (demo-drawing-cursor-inks drawing)
+ (lambda (cursor.widgets)
+ (there-exists? (cdr cursor.widgets)
+ (lambda (w) (not (gtk-object-destroyed? w))))))
+ (loop)
+ (trace ";blinking ended\n"))))))
+\f
+
+(define trace? #f)
+(define trace2? #f)
+
+;; (trace...) syntax can avoid evaluating expensive expressions among
+;; the argument forms when the corresponding trace? flag is off.
+(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-*-
+
+Copyright (C) 2007, 2008, 2009, 2010 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.
+
+|#
+
+;;;; <fix-layout>: A fixnum-centric canvas.
+;;; package: (gtk fix-layout)
+
+(c-include "gtk")
+
+(define-class (<fix-layout> (constructor () (width height)))
+ (<scm-widget>)
+
+ ;; Our window and colormap -- GdkWindow and GdkColormap aliens
+ ;; respectively. Until realized, these are NULL pointers.
+ (window define accessor
+ initializer (lambda () (make-alien '|GdkWindow|)))
+ (colormap define accessor
+ initializer (lambda () (make-alien '|GdkColormap|)))
+
+ ;; Our allocated colors -- an alist of color specs x malloced
+ ;; GdkColor structs with .pixels courtesy of gdk_rgb_find_color.
+ (colors define standard initial-value '())
+
+ ;; Our window geometry (allocation) -- a rectangular extent in
+ ;; fixnum device coordinates (e.g. size in pixels, offset within
+ ;; parent window [ancestor widget]).
+ (geometry define accessor initializer (lambda () (make-fix-rect)))
+
+ ;; Scrollbar widgets.
+ (vadjustment define standard initial-value #f)
+ (hadjustment define standard initial-value #f)
+ (scroll-step define accessor initializer (lambda () (cons 10 20)))
+
+ ;; Scrollable extent (drawing size), in logical device coords.
+ (scrollable-extent define accessor
+ initializer (lambda () (make-fix-rect 0 0 100 100)))
+
+ ;; Scroll offset (and window size) in logical device coordinates.
+ ;; (The size should match the window geometry.)
+ (view define accessor initializer (lambda () (make-fix-rect 0 0)))
+
+ (drawing define standard
+ modifier %set-fix-layout-drawing!
+ initial-value #f)
+
+ (event-handlers define accessor initializer
+ (lambda () (make-vector (C-enum "GDK_DAMAGE") #f))))
+
+(define-guarantee fix-layout "a <fix-layout>")
+
+(define-integrable (allocate-color! layout spec)
+ (let* ((colors (fix-layout-colors layout))
+ (entry (assoc spec colors)))
+ (if entry
+ (cdr entry)
+ (let ((gdkcolor (parse-gdkcolor spec layout)))
+ (if (not gdkcolor)
+ (begin
+ (warn "Invalid color spec:" spec layout)
+ #f)
+ (let ((colormap (fix-layout-colormap layout)))
+ (C-call "gdk_rgb_find_color" colormap gdkcolor)
+ (set-fix-layout-colors! layout
+ (cons (cons spec gdkcolor) colors))
+ gdkcolor))))))
+
+(define-method gtk-widget-get-colormap ((widget <fix-layout>))
+ (fix-layout-colormap widget))
+
+(define-method set-gtk-widget-bg-color! ((widget <fix-layout>) color
+ #!optional state)
+ ;; Set the window background (too).
+ (call-next-method widget color state)
+ (if (not (or (default-object? state) (eq? state 'normal)))
+ (warn "Fix-layout states are not (yet) supported:" widget color state))
+ (if (not (fix-layout-realized? widget))
+ (warn "Fix-layout not realized:" widget color state)
+ (let ((alien (make-alien '|GdkColor|)))
+ (C-> (gobject-alien widget) "GtkWidget style" alien)
+ (C-> alien "GtkStyle bg" alien)
+ (C-array-loc! alien "GdkColor" (C-enum "GTK_STATE_NORMAL"))
+ ;; The GdkColor was allocated by the GtkStyle.
+ (C-call "gdk_window_set_background" (fix-layout-window widget) alien))))
+
+(define-method initialize-instance ((widget <fix-layout>) width height)
+
+ (define-integrable (->requisition-fixnum obj)
+ (if (and (fixnum? obj) (fix:> obj -2))
+ obj
+ (error:wrong-type-argument obj "a positive fixnum, 0 or -1"
+ (list 'initialize-instance <fix-layout>))))
+
+ (trace ";((initialize-instance <fix-layout>) "widget" "width" "height")...\n")
+ (call-next-method widget)
+ (let ((alien (gobject-alien widget)))
+ (let ((geometry (fix-layout-geometry widget))
+ (w (->requisition-fixnum width))
+ (h (->requisition-fixnum height)))
+ (C->= alien "GtkWidget requisition width" w)
+ (C->= alien "GtkWidget requisition height" h)
+ (set-fix-rect-size! geometry w h))
+
+ (C-call "gtk_widget_set_has_window" alien 1)
+ (C-call "gtk_widget_set_can_focus" alien 1))
+ (set-gtk-object-destroy-callback! widget)
+ (set-gtk-widget-realize-callback! widget fix-layout-realize-callback)
+ (set-gtk-widget-size-allocate-callback! widget allocation-callback)
+ (set-gtk-widget-event-callback! widget event-callback)
+ (set-scm-widget-set-scroll-adjustments-callback! widget adjustments-callback)
+ widget)
+
+(define (fix-layout-realized? widget)
+ (not (alien-null? (fix-layout-window widget))))
+
+(define (set-fix-layout-size! widget width height)
+ (guarantee-fix-layout widget 'set-fix-layout-size!)
+ (guarantee-non-negative-fixnum width 'set-fix-layout-size!)
+ (guarantee-non-negative-fixnum height 'set-fix-layout-size!)
+ (let ((alien (gobject-alien widget)))
+ (C-call "gtk_widget_set_size_request" alien width height)))
+
+(define (set-fix-layout-scroll-size! widget width height)
+ ;; Tells WIDGET to adjust its scrollable extent. Notifies any
+ ;; scrollbars.
+ (guarantee-fix-layout widget 'set-fix-layout-scroll-size!)
+ (guarantee-non-negative-fixnum width 'set-fix-layout-scroll-size!)
+ (guarantee-non-negative-fixnum height 'set-fix-layout-scroll-size!)
+ (let ((extent (fix-layout-scrollable-extent widget)))
+ (if (not (and (fix:= width (fix-rect-width extent))
+ (fix:= height (fix-rect-height extent))))
+ (begin
+ (set-fix-rect-size! extent width height)
+ (if (fix-layout-realized? widget)
+ (adjust-adjustments widget))))))
+
+(define (fix-layout-scroll-to! widget x y)
+ (guarantee-fix-layout widget 'fix-layout-scroll-to!)
+ (guarantee-fixnum x 'fix-layout-scroll-to!)
+ (guarantee-fixnum y 'fix-layout-scroll-to!)
+ (scroll widget x y))
+
+(define (fix-layout-scroll-nw! widget extent)
+ ;; Scroll just enough to view the entire EXTENT (a fix-rect
+ ;; structure). If the view is too small to include the entire
+ ;; extent, the layout is scrolled so that its NW corner matches the
+ ;; NW corner of the extent.
+ (let ((view (fix-layout-view widget)))
+ (cond ((not (fix-rect-nominal? extent))
+ (error "Undefined extent:" extent))
+ ((not (fix-rect-nominal? view))
+ (error "Undefined extent:" view))
+ ((fix-rect-contains? view extent)
+ unspecific)
+ (else
+ (with-fix-rect-bounds
+ view
+ (lambda (min-x-view max-x-view min-y-view max-y-view)
+ (with-fix-rect-bounds
+ extent
+ (lambda (min-x-extent max-x-extent min-y-extent max-y-extent)
+ (let ((delta-y (cond ((fix:< min-y-extent min-y-view)
+ ;; extent is too low (N), go low
+ (fix:- min-y-extent min-y-view))
+ ((fix:< max-y-view max-y-extent)
+ ;; extent is too high (S), go high
+ (fix:- max-y-extent max-y-view))
+ (else 0)))
+ (delta-x (cond ((fix:< min-x-extent min-x-view)
+ ;; extent is too low (W), go low
+ (fix:- min-x-extent min-x-view))
+ ((fix:< max-x-view max-x-extent)
+ ;; extent is too high (E), go high
+ (fix:- max-x-extent max-x-view))
+ (else 0))))
+ (fix-layout-scroll-to!
+ widget
+ (fix:+ min-x-view delta-x)
+ (fix:+ min-y-view delta-y)))))))))))
+
+(define (scroll widget new-x new-y)
+ ;; Scroll if more than 25% will remain in the window, else jump.
+ (if (fix-layout-realized? widget)
+ (let ((view (fix-layout-view widget)))
+ (let ((old-x (fix-rect-x view))
+ (old-y (fix-rect-y view)))
+ (let ((dx (fix:- new-x old-x))
+ (dy (fix:- new-y old-y)))
+ (if (not (and (fix:zero? dx) (fix:zero? dy)))
+ (let ((width (fix-rect-width view))
+ (height (fix-rect-height view))
+ (gdkwindow (fix-layout-window widget)))
+ (let ((remaining-width (fix:- width (fix:abs dy)))
+ (remaining-height (fix:- height (fix:abs dx))))
+ (if (or (fix:negative? remaining-width)
+ (fix:negative? remaining-height)
+ (< 0.25 (/ (fix:* remaining-width remaining-height)
+ (fix:* width height))))
+ (C-call "gdk_window_scroll"
+ gdkwindow (fix:negate dx) (fix:negate dy))
+ (C-call "gtk_widget_queue_draw"
+ (gobject-alien widget)))
+ (set-fix-rect-position! view new-x new-y)
+ (adjust-adjustments widget))
+ (C-call "gdk_window_process_updates" gdkwindow 0))))))))
+
+(define (set-fix-layout-scroll-step! widget width height)
+ (guarantee-fix-layout widget 'set-fix-layout-scroll-step!)
+ (guarantee-positive-fixnum width 'set-fix-layout-scroll-step!)
+ (guarantee-positive-fixnum height 'set-fix-layout-scroll-step!)
+ (let ((width.height (fix-layout-scroll-step widget)))
+ (set-car! width.height width)
+ (set-cdr! width.height height))
+ (if (fix-layout-realized? widget)
+ (adjust-adjustments widget)))
+
+(define (set-fix-layout-drawing! widget drawing x y)
+ ;; Need to add widget to drawing and drawing to widget. Either way,
+ ;; asynchronous exposures may be handled inconsistently. Rather
+ ;; than lock up the machine with without-interrupts, rely on the
+ ;; all-encompassing update queued at the end, AFTER the pair of
+ ;; links is in place.
+ ;;
+ ;; Setting the drawing first to cut off its flow of damage areas
+ ;; first. Expose handlers should have few chances to serve exposes
+ ;; from the old drawing before the widget sees the new one.
+ (guarantee-fix-layout widget 'set-fix-layout-drawing!)
+ (guarantee-fix-drawing drawing 'set-fix-layout-drawing!)
+ (guarantee-fixnum x 'set-fix-layout-drawing!)
+ (guarantee-fixnum y 'set-fix-layout-drawing!)
+ (let* ((old (fix-layout-drawing widget))
+ (view (fix-layout-view widget)))
+ (if (and (eq? drawing old) (fix-rect-at-point? view x y))
+ unspecific
+ (let ((extent (fix-drawing-extent drawing))
+ (scrollable (fix-layout-scrollable-extent widget)))
+ (set-fix-rect-position! view x y)
+ (set-fix-rect-size! scrollable
+ (fix-rect-width extent) (fix-rect-height extent))
+ (if old (fix-drawing-remove-widget! old widget))
+ (if drawing (fix-drawing-add-widget! drawing widget))
+ (%set-fix-layout-drawing! widget drawing)
+ (if (fix-layout-realized? widget)
+ (begin
+ (adjust-adjustments widget)
+ (C-call "gtk_widget_queue_draw" (gobject-alien widget))))))))
+\f
+;;; Callbacks.
+
+(define (allocation-callback widget GtkAllocation)
+ (trace2 ";allocation "widget" "GtkAllocation"\n")
+ (let ((alien (gobject-alien widget))
+ (x (C-> GtkAllocation "GtkAllocation x"))
+ (y (C-> GtkAllocation "GtkAllocation y"))
+ (width (C-> GtkAllocation "GtkAllocation width"))
+ (height (C-> GtkAllocation "GtkAllocation height"))
+ (rect (fix-layout-geometry widget)))
+ (trace "; Allocation: "width"x"height" to "widget"\n")
+ (set-fix-rect! rect x y width height)
+ (set-fix-rect-size! (fix-layout-view widget) width height)
+ ;; For the random toolkit GtkWidget method too.
+ (C->= alien "GtkWidget allocation x" x)
+ (C->= alien "GtkWidget allocation y" y)
+ (C->= alien "GtkWidget allocation width" width)
+ (C->= alien "GtkWidget allocation height" height)
+ (if (fix-layout-realized? widget)
+ (begin
+ (C-call "gdk_window_move_resize" (fix-layout-window widget)
+ x y width height)
+ (adjust-adjustments widget)))
+ (fix-layout-new-geometry-callback widget)))
+
+(define-generic fix-layout-new-geometry-callback (widget))
+
+(define-method fix-layout-new-geometry-callback ((widget <fix-layout>))
+ (declare (ignore widget))
+ unspecific)
+
+(define-generic fix-layout-realize-callback (layout))
+
+(define-method fix-layout-realize-callback ((widget <fix-layout>))
+ (trace ";fix-layout-realize-<fix-layout> "widget"\n")
+ (let ((geometry (fix-layout-geometry widget))
+ (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|))
+ (main-GdkWindow (fix-layout-window widget))
+ (parent-GdkWindow (make-alien '|GdkWindow|))
+ ;;(GdkVisual (make-alien '|GdkVisual|))
+ (GdkColormap (fix-layout-colormap widget))
+ (GtkWidget (gobject-alien widget)))
+
+ ;; Create widget window.
+ ;;(C-call "gtk_widget_get_visual" GdkVisual GtkWidget)
+ ;;(C-call "gdk_rgb_get_visual" GdkVisual)
+ ;;(error-if-null GdkVisual "Could not get GdkVisual:" widget)
+ (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget)
+ (error-if-null GdkColormap "Could not get GdkColormap:" widget)
+ (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD"))
+ (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT"))
+ (let ((x (fix-rect-x geometry))
+ (y (fix-rect-y geometry))
+ (width (fix-rect-width geometry))
+ (height (fix-rect-height geometry)))
+ (if x (C->= attr "GdkWindowAttr x" x))
+ (if y (C->= attr "GdkWindowAttr y" y))
+ (C->= attr "GdkWindowAttr width" width)
+ (C->= attr "GdkWindowAttr height" height)
+ ;;(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)
+ (error-if-null parent-GdkWindow "Could not get parent:" widget)
+
+ (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr
+ (bit-or (if x (C-enum "GDK_WA_X") 0)
+ (if y (C-enum "GDK_WA_Y") 0)
+ ;;(C-enum "GDK_WA_VISUAL")
+ (C-enum "GDK_WA_COLORMAP")))
+ (error-if-null main-GdkWindow "Could not create main window:" widget)
+ (C-call "gtk_widget_set_window" GtkWidget main-GdkWindow)
+ (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
+ (set-fix-rect! (fix-layout-geometry widget) #f #f width height)
+ (set-fix-rect! (fix-layout-view widget) 0 0 width height)
+ (trace "; window: "main-GdkWindow"\n"))
+
+ (let ((GtkStyle (C-> GtkWidget "GtkWidget style")))
+ (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow)
+ (C->= GtkWidget "GtkWidget style" GtkStyle))
+
+ (adjust-adjustments widget)
+ unspecific))
+
+(define (adjustments-callback widget hGtkAdjustment vGtkAdjustment)
+ (trace2 ";set-scroll-adjustments "widget" "hGtkAdjustment" "vGtkAdjustment"\n")
+ (trace "; Adjustments:"
+ " 0x"(alien/address-string hGtkAdjustment)
+ " 0x"(alien/address-string vGtkAdjustment)"\n")
+ (connect-adjustment (fix-layout-hadjustment widget) hGtkAdjustment
+ widget set-fix-layout-hadjustment!)
+ (connect-adjustment (fix-layout-vadjustment widget) vGtkAdjustment
+ widget set-fix-layout-vadjustment!)
+ (if (fix-layout-realized? widget)
+ (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-alien (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)
+ (set-gtk-object-destroy-callback! new-adjustment)
+ (setter widget new-adjustment)
+ (g-signal-connect
+ new-adjustment (C-callback "value_changed")
+ (make-adjustment-value-changed-callback widget)))))))
+
+(define (make-adjustment-value-changed-callback widget)
+ (named-lambda (fix-layout-adjustment-value-changed-callback adjustment)
+ (trace2 ";adjustment-value-changed "widget" "adjustment"\n")
+
+ (let ((window-extent (fix-layout-view widget))
+ (vadjustment (fix-layout-vadjustment widget))
+ (hadjustment (fix-layout-hadjustment widget))
+ (value (floor->exact
+ (C-> (gobject-alien adjustment) "GtkAdjustment value"))))
+ (cond ((eq? adjustment vadjustment)
+ (trace2 "; Vadjustment to "value"\n")
+ (scroll widget (fix-rect-x window-extent) value))
+ ((eq? adjustment hadjustment)
+ (trace2 "; Hadjustment to "value"\n")
+ (scroll widget value (fix-rect-y window-extent)))
+ (else (warn "Unexpected adjustment:" adjustment))))))
+
+(define (adjust-adjustments widget)
+ ;; Called after the widget gets new adjustment(s) or its size or
+ ;; scrollable extent changes.
+
+ (let ((vadj (fix-layout-vadjustment widget)))
+ (if (and vadj (gobject-live? vadj))
+ (let* ((view (fix-layout-view widget))
+ (view-height (fix-rect-height view))
+ (extent (fix-layout-scrollable-extent widget))
+ (top (fix-rect-y extent))
+ (bottom (fix:+ top (fix:max (fix-rect-height extent) view-height)))
+ (value (fix-rect-y view))
+ (page-size view-height)
+ (step-incr (cdr (fix-layout-scroll-step widget)))
+ (page-incr (min page-size (- page-size step-incr))))
+ (set-gtk-adjustment! vadj value top bottom
+ page-size step-incr page-incr))))
+
+ (let ((hadj (fix-layout-hadjustment widget)))
+ (if (and hadj (gobject-live? hadj))
+ (let* ((view (fix-layout-view widget))
+ (view-width (fix-rect-width view))
+ (extent (fix-layout-scrollable-extent widget))
+ (left (fix-rect-x extent))
+ (right (fix:+ left (fix:max (fix-rect-width extent) view-width)))
+ (value (fix-rect-x view))
+ (page-size view-width)
+ (step-incr (car (fix-layout-scroll-step widget)))
+ (page-incr (min page-size (- page-size step-incr))))
+ (set-gtk-adjustment! hadj value left right
+ page-size step-incr page-incr)))))
+\f
+(define (event-callback layout GdkEvent)
+ (trace2 ";event "layout" "GdkEvent"\n")
+
+ (let ((type (C-> GdkEvent "GdkEvent any type")))
+ (if (int:= 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 (fix-layout-drawing layout))
+ (widget-window (fix-layout-window layout)))
+ (cond ((not (alien=? window widget-window))
+ (trace "; Expose a strange window "window
+ " (not "widget-window").\n"))
+ (drawing
+ (let* ((view (fix-layout-view layout))
+ (offx (fix-rect-x view))
+ (offy (fix-rect-y view)))
+ (trace2 "; Expose area "width"x"height" "x","y
+ " of "layout".\n")
+ (drawing-expose drawing layout window
+ (make-fix-rect
+ (fix:+ x offx) (fix:+ y offy)
+ width height)))))
+ 1 ;;TRUE -- "handled" -- done.
+ )
+ (let ((handler (vector-ref (fix-layout-event-handlers layout) type)))
+ (if handler
+ (if (handler layout GdkEvent) 1 0)
+ ;; Unhandled
+ 0)))))
+
+(define (set-fix-layout-map-handler! layout handler)
+ (guarantee-fix-layout layout 'set-fix-layout-map-handler!)
+ (guarantee-procedure-of-arity handler 1 'set-fix-layout-map-handler!)
+ (vector-set!
+ (fix-layout-event-handlers layout) (C-enum "GDK_MAP")
+ (named-lambda (fix-layout-map-handler layout GdkEvent)
+ (declare (ignore GdkEvent))
+ (handler layout))))
+
+(define (set-fix-layout-unmap-handler! layout handler)
+ (guarantee-fix-layout layout 'set-fix-layout-unmap-handler!)
+ (guarantee-procedure-of-arity handler 1 'set-fix-layout-unmap-handler!)
+ (vector-set!
+ (fix-layout-event-handlers layout) (C-enum "GDK_UNMAP")
+ (named-lambda (fix-layout-unmap-handler layout GdkEvent)
+ (declare (ignore GdkEvent))
+ (handler layout))))
+
+(define (set-fix-layout-focus-change-handler! layout handler)
+ (guarantee-fix-layout layout 'set-fix-layout-focus-change-handler!)
+ (guarantee-procedure-of-arity handler 2 'set-fix-layout-focus-change-handler!)
+ (vector-set!
+ (fix-layout-event-handlers layout) (C-enum "GDK_FOCUS_CHANGE")
+ (named-lambda (fix-layout-focus-change-handler layout GdkEvent)
+ (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in")))))
+ (handler layout in?)))))
+
+(define (set-fix-layout-visibility-notify-handler! layout handler)
+ (guarantee-fix-layout layout 'set-fix-layout-visibility-notify-handler!)
+ (guarantee-procedure-of-arity handler 2 'set-fix-layout-visibility-notify-handler!)
+ (vector-set!
+ (fix-layout-event-handlers layout) (C-enum "GDK_VISIBILITY_NOTIFY")
+ (named-lambda (fix-layout-visibility-notify-handler layout GdkEvent)
+ (let ((state (C-> GdkEvent "GdkEventVisibility state")))
+ (handler
+ layout
+ (cond
+ ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE)
+ ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED)
+ ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED)
+ (else (C-enum "GdkVisibilityState" state))))))))
+
+(define (set-fix-layout-key-press-handler! layout handler)
+ (guarantee-fix-layout layout 'set-fix-layout-key-press-handler!)
+ (guarantee-procedure-of-arity handler 3 'set-fix-layout-key-press-handler!)
+ (vector-set!
+ (fix-layout-event-handlers layout) (C-enum "GDK_KEY_PRESS")
+ (named-lambda (fix-layout-key-press-handler layout GdkEvent)
+ (let ((alien (C-> GdkEvent "GdkEvent key string"))
+ (length (C-> GdkEvent "GdkEvent key length"))
+ (state (C-> GdkEvent "GdkEvent key state"))
+ (keyval (C-> GdkEvent "GdkEvent key keyval")))
+ (let ((string (c-peek-cstring alien))
+ (char-bits (gdk-key-state->char-bits state)))
+ (if (zero? (string-length string))
+ (cond ((fix:= length 1)
+ (handler layout #\NUL char-bits))
+ ((fix:= length 0)
+ (handler layout (gdk-keyval->name keyval) char-bits))
+ (else (error "Unexpected length in GdkEventKey.")))
+ (let ((l (string-length string)))
+ (let loop ((i 0))
+ (if (fix:< i l)
+ (and (handler layout (string-ref string i) char-bits)
+ (loop (fix:1+ i)))
+ #t)))))))))
+
+(define (set-fix-layout-motion-handler! layout handler)
+ (guarantee-fix-layout layout 'set-fix-layout-motion-handler!)
+ (guarantee-procedure-of-arity handler 4 'set-fix-layout-motion-handler!)
+ (vector-set!
+ (fix-layout-event-handlers layout) (C-enum "GDK_MOTION_NOTIFY")
+ (named-lambda (fix-layout-motion-handler layout GdkEvent)
+ (let ((handled?
+ (handler layout
+ (->modifiers (C-> GdkEvent "GdkEventMotion state"))
+ (floor->exact (C-> GdkEvent "GdkEventMotion x"))
+ (floor->exact (C-> GdkEvent "GdkEventMotion y")))))
+ (C-call "gdk_window_get_pointer" #f
+ (C-> GdkEvent "GdkEventMotion window") 0 0 0)
+ handled?))))
+
+(define ->modifiers
+ (let ((names (make-vector 32 #f)))
+ (define-integrable (name mask symbol)
+ (vector-set! names (car (bit-mask-indices mask)) symbol))
+ (name (C-enum "GDK_SHIFT_MASK") 'shift)
+ (name (C-enum "GDK_LOCK_MASK") 'lock)
+ (name (C-enum "GDK_CONTROL_MASK") 'control)
+ (name (C-enum "GDK_MOD1_MASK") 'mod1)
+ (name (C-enum "GDK_MOD2_MASK") 'mod2)
+ (name (C-enum "GDK_MOD3_MASK") 'mod3)
+ (name (C-enum "GDK_MOD4_MASK") 'mod4)
+ (name (C-enum "GDK_MOD5_MASK") 'mod5)
+ (name (C-enum "GDK_BUTTON1_MASK") 'button1)
+ (name (C-enum "GDK_BUTTON2_MASK") 'button2)
+ (name (C-enum "GDK_BUTTON3_MASK") 'button3)
+ (name (C-enum "GDK_BUTTON4_MASK") 'button4)
+ (name (C-enum "GDK_BUTTON5_MASK") 'button5)
+ (name (C-enum "GDK_SUPER_MASK") 'super)
+ (name (C-enum "GDK_HYPER_MASK") 'hyper)
+ (name (C-enum "GDK_META_MASK") 'meta)
+ (name (C-enum "GDK_RELEASE_MASK") 'release)
+ (named-lambda (->modifiers num)
+ (map (lambda (i) (vector-ref names i)) (bit-mask-indices num)))))
+
+(define (set-fix-layout-button-handler! layout type handler)
+ (guarantee-fix-layout layout 'set-fix-layout-button-handler!)
+ (guarantee-procedure-of-arity handler 6 'set-fix-layout-button-handler!)
+ (let ((index (->button-event-type type 'set-fix-layout-button-handler!))
+ (handler (make-button-handler handler)))
+ (vector-set! (fix-layout-event-handlers layout) index handler)))
+
+(define (make-button-handler handler)
+ (named-lambda (fix-layout-button-handler layout GdkEvent)
+ (handler layout
+ (button-event-type->name (C-> GdkEvent "GdkEvent any type"))
+ (C-> GdkEvent "GdkEventButton button")
+ (->modifiers (C-> GdkEvent "GdkEventButton state"))
+ (floor->exact (C-> GdkEvent "GdkEventButton x"))
+ (floor->exact (C-> GdkEvent "GdkEventButton y")))))
+
+(define (->button-event-type type operator)
+ (guarantee-symbol type operator)
+ (case type
+ ((PRESS) (C-enum "GDK_BUTTON_PRESS"))
+ ((RELEASE) (C-enum "GDK_BUTTON_RELEASE"))
+ ((DOUBLE-PRESS) (C-enum "GDK_2BUTTON_PRESS"))
+ ((TRIPLE-PRESS) (C-enum "GDK_3BUTTON_PRESS"))
+ (else (error:wrong-type-argument
+ type "a button event type (press, release, double-press or triple-press)"
+ operator))))
+
+(define (button-event-type->name type)
+ (cond ((= type (C-enum "GDK_BUTTON_PRESS")) 'PRESS)
+ ((= type (C-enum "GDK_BUTTON_RELEASE")) 'RELEASE)
+ ((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS)
+ ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS)
+ (else 'BOGUS)))
+\f
+(define-class (<fix-drawing> (constructor () no-init))
+ ()
+ (extent define accessor initializer (lambda () (make-fix-rect 0 0 0 0)))
+ (widgets define standard initial-value '())
+ (display-list define standard initial-value '()))
+
+(define-guarantee fix-drawing "a <fix-drawing>")
+
+(define (drawing-damage ink #!optional rect)
+ ;; Invalidates any widget extents affected by RECT in INK. By
+ ;; default, RECT is INK's entire extent.
+ (let ((extent (if (default-object? rect)
+ (fix-ink-extent ink)
+ rect))
+ (drawing (fix-ink-drawing ink)))
+ (trace2 ";drawing-damage "ink" "(fix-rect-string extent)"\n")
+
+ (cond ((not drawing))
+ ((not (fix-rect-nominal? extent))
+ (error "Cannot damage ill-defined extent:" ink))
+ ((and (not (fix:zero? (fix-rect-width extent)))
+ (not (fix:zero? (fix-rect-height extent))))
+ (for-each
+ (lambda (widget)
+ (let ((intersect (let ((v (fix-layout-view widget)))
+ (and (fix-rect-nominal? v)
+ (window-intersection v extent)))))
+ (if (and intersect (not (gtk-object-destroyed? widget)))
+ (C-call "gtk_widget_queue_draw_area"
+ (gobject-alien widget)
+ (fix-rect-x intersect) (fix-rect-y intersect)
+ (fix-rect-width intersect) (fix-rect-height intersect)))))
+ (let ((widgets (fix-ink-widgets ink)))
+ (if (eq? #t widgets)
+ (fix-drawing-widgets drawing)
+ widgets)))))))
+
+(define (fix-drawing-pick-list drawing widget x y)
+ (keep-matching-items (fix-drawing-display-list drawing)
+ (lambda (ink)
+ (and (fix-ink-in-widget? ink widget)
+ (point-in-fix-rect? x y (fix-ink-extent ink))))))
+
+(define (drawing-expose drawing widget window area)
+ ;; AREA is in drawing coords.
+ (if (fix-rect-nominal? area)
+ (for-each
+ (lambda (ink)
+ (if (fix-ink-in? ink widget area)
+ (fix-ink-expose-callback ink widget window area)))
+ (fix-drawing-display-list drawing))))
+
+(define (fix-ink-in? ink widget area)
+ (declare (integrate-operator fix-ink-in?))
+ (and (fix-ink-in-widget? ink widget)
+ (let ((extent (fix-ink-extent ink)))
+ (and (fix-rect-nominal? extent)
+ (fix-rect-intersect? extent area)))))
+
+(define-integrable (fix-ink-in-widget? ink widget)
+ (let ((widgets (fix-ink-widgets ink)))
+ (or (eq? #t widgets)
+ (memq widget widgets))))
+
+(define-generic fix-ink-expose-callback (ink widget window expose-area)
+ ;; Due to the checks in drawing-expose, methods of this generic can
+ ;; assume expose-area and the ink's extent are intersecting, and INK
+ ;; is visible in the WIDGET. Methods may also assume the widget is
+ ;; realized and its window's (gc's) clipping is already set. The
+ ;; widget's scroll offset (view extent) is also set.
+ )
+
+(define (fix-drawing-add-widget! drawing widget)
+ (guarantee-fix-drawing drawing 'fix-drawing-add-widget!)
+ (guarantee-fix-layout widget 'fix-drawing-add-widget!)
+ (let ((widgets (fix-drawing-widgets drawing)))
+ (if (not (memq widget widgets))
+ (set-fix-drawing-widgets! drawing (cons widget widgets)))))
+
+(define (fix-drawing-remove-widget! drawing widget)
+ (guarantee-fix-drawing drawing 'fix-drawing-remove-widget!)
+ (guarantee-fix-layout widget 'fix-drawing-remove-widget!)
+ (set-fix-drawing-widgets! drawing (delq! widget
+ (fix-drawing-widgets drawing))))
+
+(define (fix-drawing-add-ink! drawing ink #!optional where)
+ (guarantee-fix-drawing drawing 'fix-drawing-add-ink!)
+ (guarantee-fix-ink ink 'fix-drawing-add-ink!)
+
+ (let ((where (and (not (default-object? where)) where)))
+ (if (fix-ink-drawing ink) (error "Already in a drawing:" ink))
+ (cond ((or (eq? #f where)
+ (eq? 'TOP where))
+ (set-fix-drawing-display-list!
+ drawing (append! (fix-drawing-display-list drawing) (list ink))))
+ ((eq? 'BOTTOM where)
+ (set-fix-drawing-display-list!
+ drawing (cons ink (fix-drawing-display-list drawing))))
+ ((fix-ink? where)
+ (let loop ((inks (fix-drawing-display-list drawing))
+ (prev #f))
+ (if (null? inks)
+ (error "Ink not found in drawing:" ink drawing)
+ (let ((i (car inks)))
+ (if (eq? where i)
+ (if (pair? prev)
+ (set-cdr! prev (cons ink inks))
+ (set-fix-drawing-display-list! drawing
+ (cons ink inks)))
+ (loop (cdr inks) inks))))))
+ (else (error:wrong-type-argument
+ where
+ (string-append "display list location"
+ ", one of: #F, TOP, BOTTOM, or an <ink>"
+ " already in the drawing's display list")
+ 'fix-drawing-add-ink!))))
+ (set-fix-ink-drawing! ink drawing)
+ (drawing-damage ink))
+
+(define (set-fix-drawing-size! drawing width height)
+ (guarantee-fix-drawing drawing 'set-fix-drawing-size!)
+ (guarantee-non-negative-fixnum width 'set-drawing-size!)
+ (guarantee-non-negative-fixnum height 'set-drawing-size!)
+ (set-fix-rect-size! (fix-drawing-extent drawing) width height)
+ (for-each
+ (lambda (widget) (set-fix-layout-scroll-size! widget width height))
+ (fix-drawing-widgets drawing)))
+
+(define (set-drawing-extent! drawing rectangle)
+ (let ((extent (fix-drawing-extent drawing)))
+ (set-fix-rect! extent
+ (fix-rect-x rectangle)
+ (fix-rect-y rectangle)
+ (fix-rect-width rectangle)
+ (fix-rect-height rectangle))))
+\f
+(define-class <fix-ink>
+ ()
+ (extent define standard initializer (lambda () (make-fix-rect 0 0 0 0)))
+ (drawing define standard initial-value #f)
+
+ ;; A list of widgets in which the ink should be drawn. #t if the
+ ;; ink should be visible in all views of the drawing.
+ (widgets define standard initial-value #t
+ modifier set-fix-ink-%widgets!))
+
+(define-guarantee fix-ink "a <fix-ink>")
+
+(define (set-fix-ink-%position! ink x y)
+ (let ((extent (fix-ink-extent ink)))
+ (without-interrupts
+ (lambda ()
+ (if (not (and (fix:= x (fix-rect-x extent))
+ (fix:= y (fix-rect-y extent))))
+ (begin
+ (drawing-damage ink)
+ (set-fix-rect-position! extent x y)
+ (drawing-damage ink)))))))
+
+(define (set-fix-ink-%size! ink width height)
+ (let ((extent (fix-ink-extent ink)))
+ (without-interrupts
+ (lambda ()
+ (if (not (and (fix:= width (fix-rect-width extent))
+ (fix:= height (fix-rect-height extent))))
+ (begin
+ (drawing-damage ink)
+ (set-fix-rect-size! extent width height)
+ (drawing-damage ink)))))))
+
+(define (set-fix-ink! ink x y width height)
+ (let ((extent (fix-ink-extent ink)))
+ (without-interrupts
+ (lambda ()
+ (if (not (and (fix:= x (fix-rect-x extent))
+ (fix:= y (fix-rect-y extent))
+ (fix:= width (fix-rect-width extent))
+ (fix:= height (fix-rect-height extent))))
+ (begin
+ (drawing-damage ink)
+ (set-fix-rect! extent x y width height)
+ (drawing-damage ink)))))))
+
+(define (set-fix-ink-widgets! ink widgets)
+ (without-interrupts
+ (lambda ()
+ (if (not (equal? widgets (fix-ink-widgets ink)))
+ (begin
+ (drawing-damage ink)
+ (set-fix-ink-%widgets! ink widgets)
+ (drawing-damage ink))))))
+
+(define (fix-ink-remove! ink)
+ (guarantee-fix-ink ink 'fix-ink-remove!)
+ (let ((drawing (fix-ink-drawing ink)))
+ (cond ((not drawing) unspecific)
+ ((not (memq ink (fix-drawing-display-list drawing)))
+ (warn "Could not remove ink:" ink drawing))
+ (else
+ (set-fix-drawing-display-list!
+ drawing (delq! ink (fix-drawing-display-list drawing)))
+ (drawing-damage ink)
+ (set-fix-ink-drawing! ink #f)))))
+
+;; For the convenience of SWAT's canvas item group, mostly.
+(define-generic fix-ink-move! (ink dx dy))
+\f
+;; This kind of ink draws (outlines and/or fills) a shape using a
+;; gdk_draw_* function with a GdkGC from gtk_gc_get (i.e. using the
+;; toolkit's GdkGC pool).
+
+(define-class <draw-ink>
+ (<fix-ink>)
+
+ ;; An alist of logical GraphicsContext member names (e.g. 'dash) X
+ ;; color or font specs, widths, booleans, etc. The spec's are
+ ;; converted to toolkit objects LATE, e.g. on expose, when the
+ ;; drawing is found in a realized widget. The conversion of this
+ ;; alist produces the GCValues struct that is passed to gtk_gc_get.
+ (options define standard initial-value '()))
+
+(define-guarantee draw-ink "a <draw-ink>")
+
+;;; For draw-ink expose handlers (without-interrupts in gtk-thread).
+
+(define (with-gc options widget receiver)
+ (trace2 ";(with-gc "options" "widget")")
+ (if (pair? options)
+ (let* ((alien.mask (malloc-gcvalues options))
+ (gc (gtk-gc-get widget alien.mask)))
+ (trace2 " => "alien.mask", "gc"\n")
+ (free (car alien.mask))
+ (receiver gc)
+ (gtk-gc-release gc))
+ (let ((gc (make-alien '|GdkGC|)))
+ (C-> (gobject-alien widget) "GtkWidget style" gc)
+ (C-> gc "GtkStyle fg_gc" gc)
+ (C-array-loc! gc "* GdkGC" (C-enum "GTK_STATE_NORMAL"))
+ (C-> gc "* GdkGC" gc)
+ (trace2 " => fg:"gc"\n")
+ (receiver gc))))
+
+(define (gtk-gc-get widget gcvalues.mask)
+ (let* ((alien (make-alien '|GdkGC|))
+ (copy (make-alien '|GdkGC|))
+ (colormap (gtk-widget-get-colormap widget))
+ (depth (C-> (C-> colormap "GdkColormap visual") "GdkVisual depth")))
+ (add-gc-cleanup alien (gtk-gc-cleanup-thunk copy))
+ (C-call "gtk_gc_get" copy depth colormap
+ (car gcvalues.mask) (cdr gcvalues.mask))
+ (copy-alien-address! alien copy)
+ alien))
+
+(define (gtk-gc-cleanup-thunk copy)
+ (named-lambda (gtk-gc-cleanup-handler)
+ (if (not (alien-null? copy))
+ (begin
+ (C-call "gtk_gc_release" copy)
+ (alien-null! copy)))))
+
+(define (gtk-gc-release gc)
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? gc))
+ (begin
+ (C-call "gtk_gc_release" gc)
+ (alien-null! gc)
+ (punt-gc-cleanup gc))))))
+
+(define (malloc-gcvalues options)
+ (let ((gcvalues (malloc (C-sizeof "GdkGCValues") '|GdkGCValues|)))
+ (let loop ((options options)
+ (mask 0))
+ (if (null? options)
+ (cons gcvalues mask)
+ (let ((name (caar options))
+ (value (cdar options)))
+ (case name
+
+ ((FOREGROUND)
+ (poke-color (C-> gcvalues "GdkGCValues foreground") value)
+ (loop (cdr options) (int:+ mask (C-enum "GDK_GC_FOREGROUND"))))
+
+ ((BACKGROUND)
+ (poke-color (C-> gcvalues "GdkGCValues background") value)
+ (loop (cdr options) (int:+ mask (C-enum "GDK_GC_BACKGROUND"))))
+
+ ((FONT)
+ ;; Handled during creation of the PangoLayout.
+ (loop (cdr options) mask))
+
+ #;((FUNCTION)
+ (C->= gcvalues "GdkGCValues function" value)
+ (loop (cdr options) (int:+ mask (C-enum "GDK_GC_FUNCTION"))))
+
+ #;((FILL)
+ ;; This is useless without a pixmap or bitmap setting.
+ (case value
+ ((SOLID)
+ (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_SOLID")))
+ ((TILED)
+ (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_TILED")))
+ ((STIPPLED)
+ (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_STIPPLED")))
+ ((OPAQUE-STIPPLED)
+ (C->= gcvalues "GdkGCValues fill" (C-enum "GDK_OPAQUE_STIPPLED")))
+ (else (error:datum-out-of-range value)))
+ (loop (cdr options) (int:+ mask (C-enum "GDK_GC_FILL"))))
+
+ ((LINE-WIDTH)
+ (C->= gcvalues "GdkGCValues line_width" value)
+ (loop (cdr options) (int:+ mask (C-enum "GDK_GC_LINE_WIDTH"))))
+
+ ((LINE-STYLE)
+ (C->= gcvalues "GdkGCValues line_style" value)
+ (loop (cdr options) (int:+ mask (C-enum "GDK_GC_LINE_STYLE"))))
+
+ (else (warn "Unsupported option name:" name value)
+ (loop (cdr options) mask))))))))
+
+(define-integrable (poke-color target source)
+ (C->= target "GdkColor red" (C-> source "GdkColor red"))
+ (C->= target "GdkColor green" (C-> source "GdkColor green"))
+ (C->= target "GdkColor blue" (C-> source "GdkColor blue"))
+ (C->= target "GdkColor pixel" (C-> source "GdkColor pixel")))
+
+(define-integrable (get-option ink name default)
+ (let ((entry (assq name (draw-ink-options ink))))
+ (if entry (cdr entry) default)))
+
+(define-integrable (set-option!? ink name value)
+ ;; If VALUE is null, the option is unset. If the option value is
+ ;; already VALUE, returns #f (else #t).
+ (let* ((options (draw-ink-options ink))
+ (entry (assq name options))
+ (old-value (if entry (cdr entry) '())))
+ (if (equal? value old-value)
+ #f
+ (begin
+ (if entry
+ (if (null? value)
+ (set-draw-ink-options! ink (delq! entry options))
+ (set-cdr! entry value))
+ (set-draw-ink-options! ink (cons (cons name value) options)))
+ #t))))
+\f
+(define-class (<line-ink> (constructor ()))
+ (<draw-ink>)
+ (vector define standard initializer (lambda () (make-fix-rect 0 0 0 0))))
+
+(define-guarantee line-ink "a <line-ink>")
+
+(define-method fix-ink-expose-callback ((ink <line-ink>) widget window area)
+ (declare (ignore area))
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+ (let ((view (fix-layout-view widget))
+ (vector (line-ink-vector ink)))
+ (with-fix-rect
+ vector
+ (lambda (x y dx dy)
+ (let ((x (fix:- x (fix-rect-x view)))
+ (y (fix:- y (fix-rect-y view))))
+ (with-line-gc
+ ink widget
+ (lambda (gc)
+ (C-call "gdk_draw_line" window gc
+ x y (fix:+ x dx) (fix:+ y dy)))))))))
+
+(define (with-line-gc ink widget receiver)
+ ;; For drawing lines (with different defaults than the outline gc).
+ (with-gc (line-options ink widget) widget receiver))
+
+(define (line-options ink widget)
+ (append-map!
+ (lambda (entry)
+ (case (car entry)
+ ((FOREGROUND) `((FOREGROUND . ,(allocate-color! widget (cdr entry)))))
+ ((LINE-WIDTH) `((LINE-WIDTH . ,(cdr entry))))
+ ((DASH) (cond ((eq? #t (cdr entry))
+ `((LINE-STYLE . ,(C-enum "GDK_LINE_ON_OFF_DASH"))))
+ ((eq? #f (cdr entry))
+ `((LINE-STYLE . ,(C-enum "GDK_LINE_SOLID"))))
+ (else
+ `((LINE-STYLE . ,(C-enum "GDK_LINE_DOUBLE_DASH"))
+ (BACKGROUND . ,(allocate-color! widget (cdr entry)))))))
+ (else '())))
+ (draw-ink-options ink)))
+
+(define-integrable (half-line-width ink)
+ (fix:max 1 (fix:1+ (quotient (get-option ink 'WIDTH 1) 2))))
+
+(define (recache-line-extent! ink)
+ (with-fix-rect
+ (line-ink-vector ink)
+ (lambda (x1 y1 dx dy)
+ (let ((x2 (fix:+ x1 dx))
+ (y2 (fix:+ y1 dy)))
+ (let ((min-x (fix:min x1 x2))
+ (min-y (fix:min y1 y2))
+ (max-x (fix:max x1 x2))
+ (max-y (fix:max y1 y2))
+ (lw/2 (half-line-width ink)))
+ (drawing-damage ink)
+ (set-fix-rect-bounds! (fix-ink-extent ink)
+ (fix:- min-x lw/2)
+ (fix:+ max-x lw/2)
+ (fix:- min-y lw/2)
+ (fix:+ max-y lw/2))
+ (drawing-damage ink))))))
+
+(define (set-line-ink! ink x1 y1 x2 y2)
+ (guarantee-fixnum x1 'set-line-ink!)
+ (guarantee-fixnum y1 'set-line-ink!)
+ (guarantee-fixnum x2 'set-line-ink!)
+ (guarantee-fixnum y2 'set-line-ink!)
+ (without-interrupts
+ (lambda ()
+ (let ((vector (line-ink-vector ink))
+ (dx (fix:- x2 x1))
+ (dy (fix:- y2 y1)))
+ (if (not (and (fix:= x1 (fix-rect-x vector))
+ (fix:= y1 (fix-rect-y vector))
+ (fix:= dx (fix-rect-width vector))
+ (fix:= dy (fix-rect-height vector))))
+ (begin
+ (set-fix-rect! vector x1 y1 dx dy)
+ (recache-line-extent! ink)))))))
+
+(define-method fix-ink-move! ((ink <line-ink>) dx dy)
+ (without-interrupts
+ (lambda ()
+ (let ((vector (line-ink-vector ink))
+ (extent (fix-ink-extent ink)))
+ (drawing-damage ink)
+ (fix-rect-move! vector dx dy)
+ (fix-rect-move! extent dx dy)
+ (drawing-damage ink)))))
+
+(define (line-ink-width ink)
+ (guarantee-line-ink ink 'line-ink-width)
+ (get-option ink 'LINE-WIDTH '()))
+
+(define (set-line-ink-width! ink width)
+ (guarantee-line-ink ink 'set-line-ink-width!)
+ (guarantee-positive-fixnum width 'set-line-ink-width!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'LINE-WIDTH width)
+ (recache-line-extent! ink)))))
+
+(define-integrable (guarantee-color-spec spec operator)
+ (cond ((string? spec) spec)
+ ((and (vector? spec) (vector-length spec 3)) spec)
+ (else (error:wrong-type-argument spec "a color" operator))))
+
+(define (line-ink-color ink)
+ (guarantee-line-ink ink 'line-ink-color)
+ (get-option ink 'FOREGROUND '()))
+
+(define (set-line-ink-color! ink color)
+ (guarantee-line-ink ink 'set-line-ink-color!)
+ (guarantee-color-spec color 'set-line-ink-color!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'FOREGROUND color)
+ (drawing-damage ink)))))
+
+(define (line-ink-dash-color ink)
+ (guarantee-line-ink ink 'line-ink-dash-color)
+ (get-option ink 'DASH '()))
+
+(define (set-line-ink-dash-color! ink color)
+ (guarantee-line-ink ink 'set-line-ink-dash-color!)
+ (if (not (or (eq? color #t) (eq? color #f)))
+ (guarantee-color-spec color 'set-line-ink-dash!))
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'DASH color)
+ (drawing-damage ink)))))
+\f
+(define-class (<rectangle-ink> (constructor ()))
+ (<draw-ink>)
+ (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0))))
+
+(define-guarantee rectangle-ink "a <rectangle-ink>")
+
+(define-method fix-ink-expose-callback ((ink <rectangle-ink>) widget window area)
+ (declare (ignore area))
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+ (let ((view (fix-layout-view widget))
+ (rect (rectangle-ink-rect ink)))
+ (with-fix-rect
+ rect
+ (lambda (x y width height)
+ (let ((x (fix:- x (fix-rect-x view)))
+ (y (fix:- y (fix-rect-y view))))
+ (with-fill-gc
+ ink widget
+ (lambda (gc)
+ (C-call "gdk_draw_rectangle" window gc 1 x y width height)))
+ (with-outline-gc
+ ink widget
+ (lambda (gc)
+ (C-call "gdk_draw_rectangle" window gc 0 x y width height))))))))
+
+(define (with-fill-gc ink widget receiver)
+ ;; For filling ovals, rectangles...
+ (let ((options (fill-options ink widget)))
+ (if (pair? options)
+ (with-gc options widget receiver))))
+
+(define (fill-options ink widget)
+ (append-map!
+ (lambda (entry)
+ (case (car entry)
+ ((FILL) `((FOREGROUND . ,(allocate-color! widget (cdr entry)))))
+ ;;((STIPPLE) `((STIPPLE . ,(bitmap-cache! entry))))
+ (else '())))
+ (draw-ink-options ink)))
+
+(define (with-outline-gc ink widget receiver)
+ ;; For outlining arcs, rectangles...
+ (let ((options (outline-options ink widget)))
+ (if (pair? options)
+ (with-gc options widget receiver))))
+
+(define (outline-options ink widget)
+ (append-map!
+ (lambda (entry)
+ (case (car entry)
+ ((OUTLINE) `((FOREGROUND . ,(allocate-color! widget (cdr entry)))))
+ ((WIDTH) `((LINE-WIDTH . ,(cdr entry))))
+ ;;((STYLE) `((LINE-STYLE . ,(cdr entry))))
+ ;;((OUTLINESTIPPLE) `((OUTLINESTIPPLE . ,(bitmap-cache! entry))))
+ (else '())))
+ (draw-ink-options ink)))
+
+(define (recache-rectangle-extent! ink)
+ (with-fix-rect-bounds
+ (rectangle-ink-rect ink)
+ (lambda (min-x max-x min-y max-y)
+ (let ((lw/2 (half-line-width ink)))
+ (drawing-damage ink)
+ (set-fix-rect-bounds! (fix-ink-extent ink)
+ (fix:- min-x lw/2)
+ (fix:+ max-x lw/2)
+ (fix:- min-y lw/2)
+ (fix:+ max-y lw/2))
+ (drawing-damage ink)))))
+
+(define (set-rectangle-ink! ink x y width height)
+ (guarantee-fixnum x 'set-rectangle-ink!)
+ (guarantee-fixnum y 'set-rectangle-ink!)
+ (guarantee-non-negative-fixnum width 'set-rectangle-ink!)
+ (guarantee-non-negative-fixnum height 'set-rectangle-ink!)
+ (without-interrupts
+ (lambda ()
+ (let ((rect (rectangle-ink-rect ink)))
+ (if (not (and (fix:= x (fix-rect-x rect))
+ (fix:= y (fix-rect-y rect))
+ (fix:= width (fix-rect-width rect))
+ (fix:= height (fix-rect-height rect))))
+ (begin
+ (set-fix-rect! rect x y width height)
+ (recache-rectangle-extent! ink)))))))
+
+(define-method fix-ink-move! ((ink <rectangle-ink>) dx dy)
+ (without-interrupts
+ (lambda ()
+ (let ((rect (rectangle-ink-rect ink))
+ (extent (fix-ink-extent ink)))
+ (drawing-damage ink)
+ (fix-rect-move! rect dx dy)
+ (fix-rect-move! extent dx dy)
+ (drawing-damage ink)))))
+
+(define (rectangle-ink-width ink)
+ (guarantee-rectangle-ink ink 'rectangle-ink-width)
+ (get-option ink 'LINE-WIDTH '()))
+
+(define (set-rectangle-ink-width! ink width)
+ (guarantee-rectangle-ink ink 'set-rectangle-ink-width!)
+ (guarantee-positive-fixnum width 'set-rectangle-ink-width!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'LINE-WIDTH width)
+ (recache-rectangle-extent! ink)))))
+
+(define (rectangle-ink-color ink)
+ (guarantee-rectangle-ink ink 'rectangle-ink-color)
+ (get-option ink 'OUTLINE '()))
+
+(define (set-rectangle-ink-color! ink color)
+ (guarantee-rectangle-ink ink 'set-rectangle-ink-color!)
+ (guarantee-color-spec color 'set-rectangle-ink-color!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'OUTLINE color)
+ (drawing-damage ink)))))
+
+(define (rectangle-ink-fill-color ink)
+ (guarantee-rectangle-ink ink 'rectangle-ink-fill-color)
+ (get-option ink 'FILL '()))
+
+(define (set-rectangle-ink-fill-color! ink color)
+ (guarantee-rectangle-ink ink 'set-rectangle-ink-fill-color!)
+ (guarantee-color-spec color 'set-rectangle-ink-fill-color!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'FILL color)
+ (drawing-damage ink)))))
+\f
+(define-class (<arc-ink> (constructor ()))
+ (<draw-ink>)
+ (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0)))
+ (%start-angle define standard initial-value 0)
+ (%sweep-angle define standard initial-value (fix:* 64 360)))
+
+(define-guarantee arc-ink "an <arc-ink>")
+
+(define-method fix-ink-expose-callback ((ink <arc-ink>) widget window area)
+ (declare (ignore area))
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+ (let ((view (fix-layout-view widget))
+ (rect (arc-ink-rect ink)))
+ (with-fix-rect
+ rect
+ (lambda (x y width height)
+ (let ((x (fix:- x (fix-rect-x view)))
+ (y (fix:- y (fix-rect-y view))))
+ (with-fill-gc
+ ink widget
+ (lambda (gc)
+ (C-call "gdk_draw_arc" window gc 1 x y width height
+ (arc-ink-%start-angle ink)
+ (arc-ink-%sweep-angle ink))))
+ (with-outline-gc
+ ink widget
+ (lambda (gc)
+ (C-call "gdk_draw_arc" window gc 0 x y width height
+ (arc-ink-%start-angle ink)
+ (arc-ink-%sweep-angle ink)))))))))
+
+(define (recache-arc-extent! ink)
+ (with-fix-rect-bounds
+ (arc-ink-rect ink)
+ (lambda (min-x max-x min-y max-y)
+ (let ((lw/2 (half-line-width ink)))
+ (drawing-damage ink)
+ (set-fix-rect-bounds! (fix-ink-extent ink)
+ (fix:- min-x lw/2)
+ (fix:+ max-x lw/2)
+ (fix:- min-y lw/2)
+ (fix:+ max-y lw/2))
+ (drawing-damage ink)))))
+
+(define (set-arc-ink! ink x y width height)
+ (guarantee-fixnum x 'set-arc-ink!)
+ (guarantee-fixnum y 'set-arc-ink!)
+ (guarantee-non-negative-fixnum width 'set-arc-ink!)
+ (guarantee-non-negative-fixnum height 'set-arc-ink!)
+ (without-interrupts
+ (lambda ()
+ (let ((rect (arc-ink-rect ink)))
+ (if (not (and (fix:= x (fix-rect-x rect))
+ (fix:= y (fix-rect-y rect))
+ (fix:= width (fix-rect-width rect))
+ (fix:= height (fix-rect-height rect))))
+ (begin
+ (set-fix-rect! rect x y width height)
+ (recache-arc-extent! ink)))))))
+
+(define-method fix-ink-move! ((ink <arc-ink>) dx dy)
+ (without-interrupts
+ (lambda ()
+ (let ((rect (arc-ink-rect ink))
+ (extent (fix-ink-extent ink)))
+ (drawing-damage ink)
+ (fix-rect-move! rect dx dy)
+ (fix-rect-move! extent dx dy)
+ (drawing-damage ink)))))
+
+(define (arc-ink-start-angle arc)
+ (/ (arc-ink-%start-angle arc) 64))
+
+(define (set-arc-ink-start-angle! arc degrees)
+ (let ((new (modulo (round (* 64 degrees)) (fix:* 64 360))))
+ (if (not (fix:= new (arc-ink-%start-angle arc)))
+ (begin
+ (set-arc-ink-%start-angle! arc new)
+ (drawing-damage arc)))))
+
+(define-integrable (arc-ink-sweep-angle arc)
+ (/ (arc-ink-%sweep-angle arc) 64))
+
+(define (set-arc-ink-sweep-angle! arc degrees)
+ (let ((new (fix:min (round (* 64 degrees)) (fix:* 64 360))))
+ (if (not (fix:= new (arc-ink-%sweep-angle arc)))
+ (begin
+ (set-arc-ink-%sweep-angle! arc new)
+ (drawing-damage arc)))))
+
+(define (arc-ink-width ink)
+ (guarantee-arc-ink ink 'arc-ink-width)
+ (get-option ink 'WIDTH '()))
+
+(define (set-arc-ink-width! ink width)
+ (guarantee-arc-ink ink 'set-arc-ink-width!)
+ (guarantee-positive-fixnum width 'set-arc-ink-width!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'WIDTH width)
+ (recache-arc-extent! ink)))))
+
+(define (arc-ink-color ink)
+ (guarantee-arc-ink ink 'arc-ink-color)
+ (get-option ink 'OUTLINE '()))
+
+(define (set-arc-ink-color! ink color)
+ (guarantee-arc-ink ink 'set-arc-ink-color!)
+ (guarantee-color-spec color 'set-arc-ink-color!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'OUTLINE color)
+ (drawing-damage ink)))))
+
+(define (arc-ink-fill-color ink)
+ (guarantee-arc-ink ink 'arc-ink-fill-color)
+ (get-option ink 'FILL '()))
+
+(define (set-arc-ink-fill-color! ink color)
+ (guarantee-arc-ink ink 'set-arc-ink-fill-color!)
+ (guarantee-color-spec color 'set-arc-ink-fill-color!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'FILL color)
+ (drawing-damage ink)))))
+\f
+(define-class (<text-ink> (constructor ()))
+ (<draw-ink>))
+
+(define-guarantee text-ink "a <text-ink>")
+
+;; The PangoLayout for gdk_draw_layout in the expose handler.
+(define-generic text-ink-pango-layout (ink))
+
+(define-method fix-ink-expose-callback ((ink <text-ink>) widget window area)
+ (declare (ignore area))
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+ (let ((view (fix-layout-view widget))
+ (rect (fix-ink-extent ink)))
+ (let ((x (fix:- (fix-rect-x rect) (fix-rect-x view)))
+ (y (fix:- (fix-rect-y rect) (fix-rect-y view)))
+ (layout (text-ink-pango-layout ink)))
+ (if layout
+ (with-text-gc
+ ink widget
+ (lambda (gc)
+ (C-call "gdk_draw_layout" window gc x y
+ (gobject-alien layout))))))))
+
+(define (with-text-gc ink widget receiver)
+ (with-gc (text-options ink widget) widget receiver))
+
+(define (text-options ink widget)
+ (append-map!
+ (lambda (entry)
+ (case (car entry)
+ ((FOREGROUND) `((FOREGROUND . ,(allocate-color! widget (cdr entry)))))
+ (else '())))
+ (draw-ink-options ink)))
+
+(define (set-text-ink-position! ink x y)
+ (guarantee-fixnum x 'set-text-ink-position!)
+ (guarantee-fixnum y 'set-text-ink-position!)
+ (without-interrupts
+ (lambda ()
+ (let ((rect (fix-ink-extent ink)))
+ (if (not (and (fix:= x (fix-rect-x rect))
+ (fix:= y (fix-rect-y rect))))
+ (begin
+ (drawing-damage ink)
+ (set-fix-rect-position! rect x y)
+ (drawing-damage ink)))))))
+
+(define-method fix-ink-move! ((ink <text-ink>) dx dy)
+ (without-interrupts
+ (lambda ()
+ (let ((extent (fix-ink-extent ink)))
+ (drawing-damage ink)
+ (fix-rect-move! extent dx dy)
+ (drawing-damage ink)))))
+
+(define (recache-text-extent! ink)
+ (let ((layout (text-ink-pango-layout ink))
+ (ink-extent (pango-rectangle))
+ (logical-extent (pango-rectangle)))
+ (trace ";recache-text-extent!")
+ (C-call "pango_layout_get_pixel_extents"
+ (gobject-alien layout) 0 logical-extent)
+ (drawing-damage ink)
+ ;; Can ink extend beyond the logical extent?
+ (set-fix-rect-size! (fix-ink-extent ink)
+ (C-> logical-extent "GdkRectangle width")
+ (C-> logical-extent "GdkRectangle height"))
+ (drawing-damage ink)
+ (free ink-extent)
+ (free logical-extent)))
+
+(define (text-ink-color ink)
+ (guarantee-text-ink ink 'text-ink-color)
+ (get-option ink 'FOREGROUND '()))
+
+(define (set-text-ink-color! ink color)
+ (guarantee-text-ink ink 'set-text-ink-color!)
+ (guarantee-color-spec color 'set-text-ink-color!)
+ (without-interrupts
+ (lambda ()
+ (if (set-option!? ink 'FOREGROUND color)
+ (drawing-damage ink)))))
+
+(define (text-ink-xy-to-index ink x y)
+ (let ((layout (text-ink-pango-layout ink)))
+ (if layout
+ (let ((extent (fix-ink-extent ink))
+ (index-alien (malloc (C-sizeof "int") 'int))
+ (layout-alien (gobject-alien layout)))
+ (let ((xL (fix:- x (fix-rect-x extent))) ; layout coords.
+ (yL (fix:- y (fix-rect-y extent))))
+ (if (fix:= 0 (C-call "pango_layout_xy_to_index" layout-alien
+ (pixels->pangos xL) (pixels->pangos yL)
+ index-alien 0))
+ (begin
+ (free index-alien)
+ #f)
+ (let ((index (C-> index-alien "int")))
+ (free index-alien)
+ index))))
+ #f)))
+
+(define (with-text-ink-grapheme-rect ink index receiver)
+ (let ((layout (text-ink-pango-layout ink)))
+ (if layout
+ (let ((rect (pango-rectangle))
+ (alien (gobject-alien layout)))
+ (C-call "pango_layout_index_to_pos" alien 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)))
+
+(define (->pango-font-description spec operator)
+ (cond ((and (alien? spec) (eq? '|PangoFontDescription| (alien/ctype spec)))
+ spec)
+ ((string? spec)
+ (or (hash-table/get cached-font-descriptions spec #f)
+ (let ((alien (pango-font-description-from-string spec)))
+ (if (not alien)
+ (error:wrong-type-argument spec "PangoFontDescription"
+ operator))
+ (hash-table/put! cached-font-descriptions spec alien)
+ alien)))
+ (else (error:wrong-type-argument spec "PangoFontDescription"
+ operator))))
+
+(define cached-font-descriptions (make-string-hash-table))
+
+(define (reset-font-descriptions!)
+ (hash-table/clear! cached-font-descriptions))
+
+(add-event-receiver! event:after-restore reset-font-descriptions!)
+\f
+(define-class (<simple-text-ink> (constructor ()))
+ (<text-ink>)
+
+ ;; A Scheme string. The content of the paragraph.
+ (text define standard initial-value #f modifier set-simple-text-ink-%text!)
+
+ ;; Corresponding PangoLayout.
+ (pango-layout define standard initial-value #f))
+
+(define-guarantee simple-text-ink "a <simple-text-ink>")
+
+(define-method text-ink-pango-layout ((ink <simple-text-ink>))
+ ;; Simply return the PangoLayout, which is only #f if no text has
+ ;; (ever) been set.
+ (simple-text-ink-pango-layout ink))
+
+(define (set-simple-text-ink-text! ink widget text)
+ ;; The TEXT string is shared.
+ (guarantee-simple-text-ink ink 'set-simple-text-ink-text!)
+ (guarantee-gtk-widget widget 'set-simple-text-ink-text!)
+ (guarantee-string text 'set-simple-text-ink-text!)
+ (without-interrupts
+ (lambda ()
+ (let ((old (simple-text-ink-text ink)))
+ (if (not (and old (string=? text old)))
+ (let ((layout (simple-text-ink-pango-layout ink)))
+ (if layout
+ (pango-layout-set-text layout text)
+ (let* ((desc (get-option ink 'FONT #f))
+ (layout
+ (if desc
+ (let ((layout
+ (gtk-widget-create-pango-layout widget "")))
+ (pango-layout-set-font-description layout desc)
+ (pango-layout-set-text layout text)
+ layout)
+ (gtk-widget-create-pango-layout widget text))))
+ (set-simple-text-ink-pango-layout! ink layout)))
+ (set-simple-text-ink-%text! ink text)
+ (recache-text-extent! ink)))))))
+
+(define (simple-text-ink-font ink)
+ (guarantee-simple-text-ink ink 'simple-text-ink-font)
+ (get-option ink 'FONT #f))
+
+(define (set-simple-text-ink-font! ink font)
+ (guarantee-simple-text-ink ink 'set-simple-text-ink-font!)
+ (let ((new (->pango-font-description font 'set-simple-text-ink-font!)))
+ (without-interrupts
+ (lambda ()
+ (let ((layout (simple-text-ink-pango-layout ink)))
+ (if (and (set-option!? ink 'FONT new) layout)
+ (begin
+ (pango-layout-set-font-description layout new)
+ (recache-text-extent! ink))))))))
+\f
+(define-class (<image-ink> (constructor ()))
+ (<fix-ink>)
+ ;; This slot is set to a <pixbuf> soon after loading has begun.
+ (pixbuf define standard initial-value #f)
+ ;; This slot is set to #f when the pixbuf has been successfully loaded.
+ (loader define standard initializer make-pixbuf-loader))
+
+(define-method initialize-instance ((ink <image-ink>))
+ (trace ";((initialize-instance <image-ink>) "ink")...\n")
+ (call-next-method ink)
+ (let ((loader (image-ink-loader ink)))
+ (set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink))
+ (set-pixbuf-loader-pixbuf-hook! loader (image-ink-pixbuf-prepared ink))
+ (set-pixbuf-loader-update-hook! loader (image-ink-pixbuf-updated ink))
+ (set-pixbuf-loader-close-hook! loader (image-ink-pixbuf-loaded ink))))
+
+(define (image-ink-size-prepared ink)
+ (named-lambda (image-ink-size-prepared-handler width height)
+ (trace ";image-ink-size-prepared-handler "ink" "width" "height"\n")
+ (set-fix-ink-%size! ink width height)))
+
+(define (image-ink-pixbuf-prepared ink)
+ (named-lambda (image-ink-pixbuf-prepared-handler pixbuf)
+ (trace ";image-ink-pixbuf-prepared-handler "ink" "pixbuf"\n")
+ (set-image-ink-pixbuf! ink pixbuf)))
+
+(define (image-ink-pixbuf-updated ink)
+ (named-lambda (image-ink-pixbuf-updated-handler x y width height)
+ (let ((rect (make-fix-rect x y width height)))
+ (trace ";image-ink-pixbuf-updated-handler "ink" "rect"\n")
+ (drawing-damage ink rect))))
+
+(define (image-ink-pixbuf-loaded ink)
+ (named-lambda (image-ink-pixbuf-loaded-handler loader)
+ (trace ";image-ink-pixbuf-loaded-handler "ink" ("(image-ink-pixbuf ink)")"
+ " "(pixbuf-loader-error-message loader)"\n")
+ (if (not (pixbuf-loader-error-message loader))
+ (begin
+ (set-image-ink-loader! ink #f)
+ (gobject-unref! loader))
+ (begin
+ ;; Hack the pixbuf with a "broken image" overlay?
+ ;;
+ ;; Leave the loader, with dead thread and closed
+ ;; input-port, for debugging purposes.
+ unspecific))))
+
+(define-method fix-ink-expose-callback ((ink <image-ink>) widget window area)
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+
+ (let ((pixbuf (let ((p (image-ink-pixbuf ink)))
+ (if p (gobject-alien p) #f))))
+ (if (and pixbuf (not (alien-null? pixbuf)))
+ (let ((extent (fix-ink-extent ink))
+ (view (fix-layout-view widget)))
+ (let ((i (fix-rect-intersection extent area))
+ (view-x (fix-rect-x view))
+ (view-y (fix-rect-y view)))
+ (with-gc '() widget
+ (lambda (gc)
+ (C-call "gdk_draw_pixbuf" window gc
+ pixbuf
+ ;; drawing->image
+ (fix:- (fix-rect-x i) (fix-rect-x extent)) ;src_x
+ (fix:- (fix-rect-y i) (fix-rect-y extent)) ;src_y
+ ;; drawing->window
+ (fix:- (fix-rect-x i) view-x) ;dest_x
+ (fix:- (fix-rect-y i) view-y) ;dest_y
+ (fix-rect-width i) (fix-rect-height i)
+ (C-enum "GDK_RGB_DITHER_NONE")
+ 0 0 ;x_dither, y_dither
+ ))))))))
+
+(define (make-image-ink-from-file filename)
+ (let ((ink (make-image-ink)))
+ (load-pixbuf-from-file (image-ink-loader ink) filename)
+ ink))
+
+(define (set-image-ink! ink x y)
+ (guarantee-fixnum x 'set-image-ink-position!)
+ (guarantee-fixnum y 'set-image-ink-position!)
+ (set-fix-ink-%position! ink x y))
+\f
+;;; Inks implemented by gtk_paint_*, using widget style/state.
+
+(define-class (<box-ink> (constructor ()))
+ (<fix-ink>)
+ ;; Just hoping that the effects of style xthickness, ythickness,
+ ;; etc. do not drop ink beyond the ink-extent.
+ (%shadow define standard initial-value (C-enum "GTK_SHADOW_NONE")))
+
+(define-method fix-ink-expose-callback ((ink <box-ink>) widget window area)
+ (declare (ignore area))
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+ (let ((alien (gobject-alien widget))
+ (view (fix-layout-view widget))
+ (extent (fix-ink-extent ink)))
+ (let ((style (C-> alien "GtkWidget style"))
+ (state (C-> alien "GtkWidget state")))
+ (C-call "gtk_paint_box"
+ style window state (C-enum "GTK_SHADOW_NONE")
+ 0 alien 0 ;area widget detail
+ (fix:- (fix-rect-x extent) (fix-rect-x view))
+ (fix:- (fix-rect-y extent) (fix-rect-y view))
+ (fix-rect-width extent)
+ (fix-rect-height extent)))))
+
+(define (set-box-ink! ink x y width height)
+ (guarantee-fixnum x 'set-box-ink!)
+ (guarantee-fixnum y 'set-box-ink!)
+ (guarantee-non-negative-fixnum width 'set-box-ink!)
+ (guarantee-non-negative-fixnum height 'set-box-ink!)
+ (set-fix-ink! ink x y width height))
+
+(define (set-box-ink-position! ink x y)
+ (guarantee-fixnum x 'set-box-ink!)
+ (guarantee-fixnum y 'set-box-ink!)
+ (set-fix-ink-%position! ink x y))
+
+(define (box-ink-shadow ink)
+ (let ((shadow (box-ink-%shadow ink)))
+ (cond
+ ((int:= shadow (C-enum "GTK_SHADOW_NONE")) 'NONE)
+ ((int:= shadow (C-enum "GTK_SHADOW_IN")) 'IN)
+ ((int:= shadow (C-enum "GTK_SHADOW_OUT")) 'OUT)
+ ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN)
+ ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_OUT")) 'ETCHED-OUT)
+ (else (error "Invalid box-ink %shadow:" shadow)))))
+
+(define (set-box-ink-shadow! ink 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 (error:bad-range-argument type 'set-box-ink-shadow!)))))
+ (if (not (fix:= new (box-ink-%shadow ink)))
+ (begin
+ (set-box-ink-%shadow! ink new)
+ ;; Depending on the shadow type, adjust the inked extent?!!!
+ (drawing-damage ink)))))
+
+;; Punting the rest of gtk_paint_* until style members like
+;; x/ythickness can be accounted for in the fix-ink-extent.
+
+#;(define-class (<hline-ink> (constructor ()))
+ (<fix-ink>))
+
+#;(define-method fix-ink-expose-callback ((ink <hline-ink>) widget window area)
+ (declare (ignore area))
+ (trace2 "; (Re)Drawing "ink" on "widget".\n")
+ (let ((alien (gobject-alien widget))
+ (view (fix-layout-view widget))
+ (extent (fix-ink-extent ink)))
+ (let ((style (C-> alien "GtkWidget style"))
+ (state (C-> alien "GtkWidget state"))
+ (x (fix:- (fix-rect-x extent) (fix-rect-x view)))
+ (y (fix:- (fix-rect-y extent) (fix-rect-y view))))
+ (C-call "gtk_paint_hline"
+ style window state
+ 0 alien 0 ;area widget detail
+ x (fix:+ x (fix-rect-width extent))
+ y))))
+\f
+;;;; Fixnum Rectangles
+
+(define-structure (fix-rect (constructor make-fix-rect (#!optional x y width height))
+ (copier)
+ (print-procedure
+ (standard-unparser-method 'FIX-RECT
+ (lambda (rect port)
+ (write-string " " port)
+ (write-string (fix-rect-string rect) port)))))
+ (x #f) (y #f) (width #f) (height #f))
+
+(define (fix-rect-string rect)
+ (define-integrable (S a) (write-to-string a))
+ (string-append (S (fix-rect-x rect))","(S (fix-rect-y rect))
+ " "(S (fix-rect-width rect))"x"(S (fix-rect-height rect))))
+
+(define-integrable-operator (make-fix-rect-from-bounds min-x min-y max-x max-y)
+ (make-fix-rect min-x min-y (fix:- max-x min-x) (fix:- max-y min-y)))
+
+(define-integrable-operator (set-fix-rect! rect x y width height)
+ (set-fix-rect-x! rect x)
+ (set-fix-rect-y! rect y)
+ (set-fix-rect-width! rect width)
+ (set-fix-rect-height! rect height))
+
+(define-integrable-operator (set-fix-rect-bounds! rect min-x max-x min-y max-y)
+ (set-fix-rect-x! rect min-x)
+ (set-fix-rect-y! rect min-y)
+ (set-fix-rect-width! rect (fix:- max-x min-x))
+ (set-fix-rect-height! rect (fix:- max-y min-y)))
+
+(define-integrable-operator (set-fix-rect-position! rect x y)
+ (set-fix-rect-x! rect x)
+ (set-fix-rect-y! rect y))
+
+(define-integrable-operator (fix-rect-move! rect dx dy)
+ (set-fix-rect-x! rect (fix:+ (fix-rect-x rect) dx))
+ (set-fix-rect-y! rect (fix:+ (fix-rect-y rect) dy)))
+
+(define-integrable-operator (set-fix-rect-size! rect width height)
+ (set-fix-rect-width! rect width)
+ (set-fix-rect-height! rect height))
+
+(define-integrable-operator (fix-rect-nominal? rect)
+ (and (fixnum? (fix-rect-x rect))
+ (fixnum? (fix-rect-y rect))
+ (fixnum? (fix-rect-width rect))
+ (fixnum? (fix-rect-height rect))))
+
+;;; The rest of these procedures assume a "nominal" rectangle.
+
+(define-integrable-operator (fix-rect-max-y rect)
+ (fix:+ (fix-rect-y rect) (fix-rect-height rect)))
+
+(define-integrable-operator (fix-rect-max-x rect)
+ (fix:+ (fix-rect-x rect) (fix-rect-width rect)))
+
+(define-integrable fix-rect-min-x fix-rect-x)
+(define-integrable fix-rect-min-y fix-rect-y)
+
+(define-integrable-operator (with-fix-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 (fix-rect-x rect))
+ (y (fix-rect-y rect))
+ (width (fix-rect-width rect))
+ (height (fix-rect-height rect)))
+ (receiver x (fix:+ x width) y (fix:+ y height))))
+
+(define-integrable-operator (with-fix-rect rect receiver)
+ (receiver (fix-rect-x rect) (fix-rect-y rect) (fix-rect-width rect) (fix-rect-height rect)))
+
+(define-integrable-operator (copy-fix-rect! target source)
+ (set-fix-rect-x! target (fix-rect-x source))
+ (set-fix-rect-y! target (fix-rect-y source))
+ (set-fix-rect-width! target (fix-rect-width source))
+ (set-fix-rect-height! target (fix-rect-height source)))
+
+(define-integrable-operator (point-in-fix-rect? x y rect)
+ (with-fix-rect-bounds rect
+ (lambda (min-x max-x min-y max-y)
+ (and (fix:<= min-x x) (fix:<= x max-x)
+ (fix:<= min-y y) (fix:<= y max-y)))))
+
+(define-integrable-operator (fix-rect-at-point? rect x y)
+ (and (fix:= x (fix-rect-x rect))
+ (fix:= y (fix-rect-y rect))))
+
+(define-integrable-operator (fix-rect-intersect? rect1 rect2)
+ ;; Useful when you do not need to cons a new rect.
+ (with-fix-rect-bounds rect1
+ (lambda (min-x1 max-x1 min-y1 max-y1)
+ (with-fix-rect-bounds rect2
+ (lambda (min-x2 max-x2 min-y2 max-y2)
+ (cond ((fix:< max-x1 min-x2) #f)
+ ((fix:< max-y1 min-y2) #f)
+ ((fix:< max-x2 min-x1) #f)
+ ((fix:< max-y2 min-y1) #f)
+ (else #t)))))))
+
+(define (fix-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.
+ (with-fix-rect-bounds rect1
+ (lambda (min-x1 max-x1 min-y1 max-y1)
+ (with-fix-rect-bounds rect2
+ (lambda (min-x2 max-x2 min-y2 max-y2)
+ (cond ((fix:< max-x1 min-x2) #f)
+ ((fix:< max-y1 min-y2) #f)
+ ((fix:< max-x2 min-x1) #f)
+ ((fix:< max-y2 min-y1) #f)
+ (else
+ (let ((min-x (fix:max min-x1 min-x2))
+ (min-y (fix:max min-y1 min-y2))
+ (max-x (fix:min max-x1 max-x2))
+ (max-y (fix:min max-y1 max-y2)))
+ (make-fix-rect min-x min-y
+ (fix:- max-x min-x)
+ (fix:- 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.
+ (with-fix-rect-bounds window
+ (lambda (window-x-start window-x-end window-y-start window-y-end)
+ (with-fix-rect-bounds item
+ (lambda (item-x-start item-x-end item-y-start item-y-end)
+ (cond ((fix:< window-x-end item-x-start) #f)
+ ((fix:< window-y-end item-y-start) #f)
+ ((fix:< item-x-end window-x-start) #f)
+ ((fix:< item-y-end window-y-start) #f)
+ (else
+ (let ((x (fix:max window-x-start item-x-start))
+ (y (fix:max window-y-start item-y-start))
+ (x-end (fix:min window-x-end item-x-end))
+ (y-end (fix:min window-y-end item-y-end)))
+ (make-fix-rect (fix:- x window-x-start)
+ (fix:- y window-y-start)
+ (fix:- x-end x)
+ (fix:- y-end y))))))))))
+
+(define (fix-rect-union! rect1 rect2)
+ (with-fix-rect-bounds rect1
+ (lambda (min-x1 max-x1 min-y1 max-y1)
+ (with-fix-rect-bounds rect2
+ (lambda (min-x2 max-x2 min-y2 max-y2)
+ (let ((x (fix:min min-x1 min-x2))
+ (y (fix:min min-y1 min-y2)))
+ (set-fix-rect! rect1
+ x y
+ (fix:- (fix:max max-x1 max-x2) x)
+ (fix:- (fix:max max-y1 max-y2) y))))))))
+
+(define (fix-rect-contains? rect1 rect2)
+ ;; True if RECT2 is wholly contained within RECT1.
+ (with-fix-rect-bounds rect1
+ (lambda (min-x1 max-x1 min-y1 max-y1)
+ (with-fix-rect-bounds rect2
+ (lambda (min-x2 max-x2 min-y2 max-y2)
+ (and (fix:<= min-x1 min-x2) (fix:<= max-x2 max-x1)
+ (fix:<= min-y1 min-y2) (fix:<= max-y2 max-y1)))))))
+
+(define (gdk-rectangle #!optional x y width height)
+ (if (not (default-object? x)) (guarantee-fixnum x 'gdk-rectangle))
+ (if (not (default-object? y)) (guarantee-fixnum y 'gdk-rectangle))
+ (if (not (default-object? width)) (guarantee-non-negative-fixnum width 'gdk-rectangle))
+ (if (not (default-object? height)) (guarantee-non-negative-fixnum height 'gdk-rectangle))
+ (let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|)))
+ (if (default-object? x) alien
+ (begin
+ (C->= alien "GdkRectangle x" x)
+ (if (default-object? y) alien
+ (begin
+ (C->= alien "GdkRectangle y" y)
+ (if (default-object? width) alien
+ (begin
+ (C->= alien "GdkRectangle width" width)
+ (if (default-object? height) alien
+ (begin
+ (C->= alien "GdkRectangle height" height)
+ alien))))))))))
+
+(define (gdk-rectangle-from-rect rect)
+ (gdk-rectangle (fix-rect-x rect) (fix-rect-y rect)
+ (fix-rect-width rect) (fix-rect-height rect)))
+
+
+(define trace? #f)
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
+
+(define trace2? #f)
+
+(define-syntax trace2
+ (syntax-rules ()
+ ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
;;;; 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.
+ ;; The address of the toolkit object. A null alien if the GObject
+ ;; has not been created (yet), or has been unrefed.
(alien define accessor
initializer (lambda () (make-alien '|GObject|)))
;; 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))))
+ initializer (lambda () (list 'GOBJECT-SIGNALS)))
+
+ ;; This instance's weak-pair on the gc-cleanups list. This is
+ ;; cached here mainly for g-signal-connect, which must create
+ ;; callbacks that only weakly reference this instance.
+ (weak-self define standard))
-(define-integrable (gobject-finalized? object)
- (alien-null? (gobject-alien object)))
+(define-guarantee gobject "a <gobject>")
+
+(define-integrable (gobject-live? object)
+ (not (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-cleanup-thunk (gobject-alien object)
- (gobject-signals object))))
-
-(define (gobject-cleanup-thunk alien signals)
- ;; Return a thunk closed over ALIEN and SIGNALS (but not the
- ;; gobject).
- (named-lambda (gobject::cleanup-thunk)
- (trace ";gobject::cleanup-thunk "alien"\n")
- (gobject-cleanup alien signals)
- (trace ";gobject::cleanup-thunk done with "alien"\n")))
+ (call-next-method object)
+ (set-gobject-weak-self!
+ object (add-gc-cleanup object (make-gobject-cleanup-thunk
+ (gobject-alien object)
+ (gobject-signals object)))))
+
+(define (make-gobject-cleanup-thunk alien signals)
+ ;; This separate procedure ensures that the gobject is not caught in
+ ;; the closure.
+ (named-lambda (gobject-cleanup-thunk)
+ (gobject-cleanup alien signals)))
+
+(define (gobject-unref! object)
+ (without-interrupts
+ (lambda ()
+ (gobject-cleanup (gobject-alien object) (gobject-signals object))
+ (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups)))))
(define (gobject-cleanup alien signals)
- ;; Run as a gc-cleanup, without-interrupts. Calls g_object_unref
- ;; (if necessary), and de-registers the Scheme signal handlers.
- (trace ";gobject::cleanup "alien"\n")
+ ;; Run as a gc-daemon, or with exclusive write access to ALIEN and
+ ;; SIGNALS (or without-interrupts).
+
+ (trace ";gobject-cleanup "alien"\n")
(if (not (alien-null? alien))
(begin
+ (for-each
+ (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle)))
+ (cdr signals))
(C-call "g_object_unref" alien)
(alien-null! alien)))
- (for-each (lambda (name.id.handle)
- (let* ((id.handle (cdr name.id.handle))
- (id (car id.handle)))
- (if id
- (begin
- (de-register-c-callback id)
- (set-car! id.handle #f)
- (set-cdr! id.handle #f)))))
- (cdr signals))
- (trace ";gobject::cleanup done with "alien"\n"))
-
-(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).
+ (trace ";gobject-cleanup done with "alien"\n"))
+
+(define (g-signal-connect gobject alien-function callback)
+ (guarantee-gobject gobject 'g-signal-connect)
+ (guarantee-alien-function alien-function 'g-signal-connect)
(without-interrupts
(lambda ()
- (gobject-cleanup (gobject-alien object) (gobject-signals object)))))
-
-(define (g-signal-connect object alien-function handler)
- ;; 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 handler)))
- (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.
+ (let* ((name (alien-function/name alien-function))
+ (sym (string->symbol name))
+ (alien (gobject-alien gobject))
+ (signals (gobject-signals gobject))
+ (sym.id.handle (or (assq sym (cdr signals))
+ (let ((entry (cons* sym #f #f)))
+ (set-cdr! signals (cons entry (cdr signals)))
+ entry))))
+ (disconnect!? alien (cdr sym.id.handle))
+ (connect! alien sym.id.handle
+ alien-function
+ (register-c-callback
+ (make-gobject-signal-callback
+ sym (gobject-weak-self gobject) callback)))))))
+
+(define (make-gobject-signal-callback name weak-pair callback)
+ (named-lambda (gobject-signal-callback instance . args)
+ (declare (ignore instance))
+ ;; Callbacks run without-interrupts.
+ (if (weak-pair/car? weak-pair)
+ (let ((gobject (weak-car weak-pair)))
+ (if-debugging
+ (if (not (alien=? (gobject-alien gobject) instance))
+ (warn "Signal instance / gobject mismatch:" instance gobject)))
+ (apply callback gobject args))
+ (error "Cannot signal a <gobject> that is already GC'ed:" name args))))
+
+(define (connect! alien sym.id.handle alien-function newid)
+ (let ((id.handle (cdr sym.id.handle)))
+ (set-car! id.handle newid)
+ (set-cdr! id.handle
+ (C-call "g_signal_connect_data" alien
+ (alien-function/name alien-function)
+ alien-function newid 0 0))))
+
+(define (g-signal-disconnect gobject name)
+ (guarantee-gobject gobject 'g-signal-disconnect)
+ (guarantee-symbol name 'g-signal-disconnect)
(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))))))
+ (let* ((alien (gobject-alien gobject))
+ (signals (gobject-signals gobject))
+ (name.id.handle (assq name (cdr signals))))
+ (if (not name.id.handle)
+ (warn "No signal to disconnect:" name gobject)
+ (if (not (disconnect!? alien (cdr name.id.handle)))
+ (warn "Signal already disconnected:" name gobject)))))))
+
+(define (disconnect!? alien id.handle)
+ (if (eq? (car id.handle) #f)
+ #f
+ (begin
+ (C-call "g_signal_handler_disconnect" alien (cdr id.handle))
+ (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.
-
-;;; These cleanups are run by the gtk-thread, for easy error handling.
-;;; They are rather complex to run at after-gc interrupt level (as
-;;; gc-daemons). They callout and thus may run callbacks that run
-;;; callouts...
-
(define gc-cleanups)
(define (initialize-gc-cleanups!)
(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)))))
+(define-integrable (add-gc-cleanup object cleanup-thunk)
+ (let ((weak-pair (weak-cons object cleanup-thunk)))
+ (without-interrupts
+ (lambda ()
+ (set! gc-cleanups (cons weak-pair gc-cleanups))))
+ weak-pair))
-(define (punt-gc-cleanup object)
+(define-integrable (punt-gc-cleanup object)
(without-interrupts
(lambda ()
(let ((entry (weak-assq object gc-cleanups)))
;;; Properties
(define (gobject-get-property gobject property)
+ (guarantee-gobject gobject 'gobject-get-property)
- (let ((object (check-gobject gobject))
- (name (check-prop-name property))
+ (let ((name (check-prop-name property))
(gvalue (malloc (C-sizeof "GValue") '|GValue|)))
(define (unimplemented type)
- (ferror "Property "name" (for "object") is "type" (unimplemented)."))
+ (error "Unimplemented property type:" type name gobject))
- (C-call "g_object_get_property" (gobject-alien object) name gvalue)
+ (C-call "g_object_get_property" (gobject-alien gobject) name gvalue)
(let* ((type (C-> gvalue "GValue g_type"))
(value
(cond
((int:= type (C-enum "G_TYPE_INVALID"))
- (ferror "Property "name" (for "object") is invalid."))
+ (error "Invalid property:" name gobject))
((int:= type (C-enum "G_TYPE_NONE"))
- (ferror "Property "name" (for "object") is void."))
+ (error "Void property:" name gobject))
((int:= type (C-enum "G_TYPE_INTERFACE"))
(unimplemented "an interface"))
((int:= type (C-enum "G_TYPE_CHAR"))
(C-call "g_value_get_object" alien gvalue)
alien))
(else
- (ferror "Unexpected GFundamentalType "
- (C-enum "enum GFundamentalType" type)
- " ("type").")))))
+ (error "Unexpected GFundamentalType:" 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))
+ (let* ((gobject-alien (gobject-alien gobject))
(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 (gobject-get-gclass gobject-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))
+ (error "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"."))
+ (error "No property:" name 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."))
+ (error "Property not writable:" name gclass-name))
(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."))
+ (error "Property not writable outside constructor:"
+ name gclass-name))
(C-call "G_PARAM_SPEC_VALUE_TYPE" gtype pspec)
(C-call "g_value_init" gvalue gtype)
;; g_value_set_* gvalue *
(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."))))
+ (error "Property value not an object:"
+ value name gclass-name))))
(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))
- "."))
+ (error "Property value incompatible:"
+ value name gclass-name))
(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)
+ (error "Property type unsupported:"
+ (or (C-enum "enum GFundamentalType" fundamental)
+ fundamental)
+ name gclass-name))))
+ (C-call "g_object_set_property" gobject-alien name gvalue)
(C-call "g_value_reset" gvalue)))
(loop (cddr plist)))))
(free gtype)
(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".")))))
+ (error "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".")
+ (error (string-append "Property value must " verb-phrase ":")
+ value property)
property verb-phrase type-predicate)))
(define (check-prop-char value name)
(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
(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)
(define (gquark-to-string gquark)
(or (hash-table/get gquark-to-string-cache gquark #f)
- (ferror "This GQuark ("gquark") has never been cached!")))
+ (error "Unknown GQuark:" gquark)))
(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
+;;; GdkPixbufLoaders
(define-class (<pixbuf-loader> (constructor ()))
(<gobject>)
(call-next-method loader)
(C-call "gdk_pixbuf_loader_new" (gobject-alien loader))
(g-signal-connect loader (C-callback "size_prepared")
- (pixbuf-loader-size-prepared loader))
+ pixbuf-loader-size-prepared)
(g-signal-connect loader (C-callback "area_prepared")
- (pixbuf-loader-area-prepared loader))
+ pixbuf-loader-area-prepared)
(g-signal-connect loader (C-callback "area_updated")
- (pixbuf-loader-area-updated loader)))
-
-(define (pixbuf-loader-size-prepared loader)
- (named-lambda (pixbuf-loader::size-prepared GdkPixbufLoader width height)
- GdkPixbufLoader ;;Ignored.
- (trace "; pixbuf-loader::size-prepared "loader" "width" "height"\n")
- (let ((size (pixbuf-loader-size loader)))
- (if size (ferror loader" already has a size: "(car size)"x"(cdr size)))
- (set-pixbuf-loader-size! loader (cons width height))
- (let ((receiver (pixbuf-loader-size-hook loader)))
- (if receiver (receiver width height))))))
+ pixbuf-loader-area-updated))
+
+(define (pixbuf-loader-size-prepared loader width height)
+ (trace "; pixbuf-loader-size-prepared "loader" "width" "height"\n")
+ (let ((size (pixbuf-loader-size loader)))
+ (if size (error "Pixbuf loader already has a size:" loader))
+ (set-pixbuf-loader-size! loader (cons width height))
+ (let ((receiver (pixbuf-loader-size-hook loader)))
+ (if receiver (receiver width height)))))
(define (pixbuf-loader-area-prepared loader)
- (named-lambda (pixbuf-loader::area-prepared GdkPixbufLoader)
- (trace "; pixbuf-loader::area-prepared "loader"\n")
- (let* ((pixbuf (let ((p (pixbuf-loader-pixbuf loader)))
+ (trace "; pixbuf-loader-area-prepared "loader"\n")
+ (let* ((alien (gobject-alien loader))
+ (pixbuf (let ((p (pixbuf-loader-pixbuf loader)))
(if p
- (ferror loader" already has a pixbuf: "p)
+ (error "Pixbuf loader already has a pixbuf:" loader)
(make-pixbuf))))
- (alien (gobject-alien pixbuf)))
- (C-call "gdk_pixbuf_loader_get_pixbuf" alien GdkPixbufLoader)
- (C-call "g_object_ref" #f alien)
+ (pixbuf-alien (gobject-alien pixbuf)))
+ (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf-alien alien)
+ (C-call "g_object_ref" #f pixbuf-alien)
(set-pixbuf-loader-pixbuf! loader pixbuf)
(let ((receiver (pixbuf-loader-pixbuf-hook loader)))
- (if receiver (receiver pixbuf))))))
+ (if receiver (receiver pixbuf)))))
-(define (pixbuf-loader-area-updated loader)
- (named-lambda (pixbuf-loader::area-updated GdkPixbufLoader x y width height)
- GdkPixbufLoader ;;Ignored.
- (let ((rect (make-rect x y width height)))
- (trace "; pixbuf-loader::area-updated "loader" "rect"\n")
- (let ((receiver (pixbuf-loader-update-hook loader)))
- (if receiver (receiver rect))))))
+(define (pixbuf-loader-area-updated loader x y width height)
+ (trace "; pixbuf-loader-area-updated "loader" "x","y" "width"x"height"\n")
+ (let ((receiver (pixbuf-loader-update-hook loader)))
+ (if receiver (receiver x y width height))))
-(define (start-pixbuf-loader loader input-port)
+(define (load-pixbuf-from-port loader input-port)
(without-interrupts
(lambda ()
(if (pixbuf-loader-port loader)
- (ferror loader" has already started."))
+ (error "Pixbuf loader has already started:" loader))
(set-pixbuf-loader-port! loader input-port)
(set-pixbuf-loader-thread! loader (create-pixbuf-loader-thread loader)))))
(note-error))))))))))
(define (load-pixbuf-from-file loader filename)
- (start-pixbuf-loader
+ (load-pixbuf-from-port
loader (open-binary-input-file (->namestring (->truename filename)))))
(define (set-pixbuf-loader-size-hook! loader receiver)
(%set-pixbuf-loader-close-hook! loader thunk)
(if (pixbuf-loader-closed? loader)
(thunk)))))
+\f
+(define (gdk-window-process-updates gdkwindow children-too?)
+ (guarantee-gdk-window gdkwindow 'gdk-window-process-updates)
+ (C-call "gdk_window_process_updates" gdkwindow (if children-too? 1 0)))
+
+(define-integrable (guarantee-gdk-window object operator)
+ (if (not (and (alien? object) (eq? '|GdkWindow| (alien/ctype object))))
+ (error:wrong-type-argument object "a GdkWindow address" operator)))
(define (initialize-package!)
(initialize-gc-cleanups!)
(define-syntax trace
(syntax-rules ()
- ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
+ ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
+
+(initialize-package!)
\ No newline at end of file
|#
;;;; An event viewer, a translation of Havoc Pennington's GtkEv example.
-;;; package: (gtk)
-
-(declare (usual-integrations))
-\f
+;;; package: (gtk event-viewer)
(c-include "gtk")
-(define (gtk-event-viewer)
+(define (make-gtk-event-viewer-demo)
(let ((window (gtk-window-new 'toplevel))
- (gtk-ev (gtk-event-viewer-new)))
+ (gtk-ev (make-gtk-event-viewer)))
(gtk-container-add window gtk-ev)
(gtk-window-set-title window "gtk-event-viewer")
(gtk-container-set-border-width window 10)
(gtk-widget-show-all window)
gtk-ev))
-(define-class (<gtk-event-viewer>
- (constructor make-gtk-event-viewer ()))
+(define-class (<gtk-event-viewer> (constructor ()))
(<scm-widget>)
;; GdkWindow alien, and the window geometry (allocation).
(window define standard
initializer (lambda () (make-alien '|GdkWindow|)))
(geometry define standard
- initializer make-rect)
+ initializer make-fix-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)
+ initializer make-fix-rect)
;; Geometry of the description area.
(description-box define standard
- initializer make-rect)
+ initializer make-fix-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)
+(define-method initialize-instance ((widget <gtk-event-viewer>))
+ (trace ";\t(initialize-instance <gtk-event-viewer>) "widget")...\n")
+ (call-next-method widget)
+ (let ((alien (gobject-alien widget)))
+ (C->= alien "GtkWidget requisition width" 450)
+ (C->= alien "GtkWidget requisition height" 300)
+ (C-call "gtk_widget_set_has_window" alien 1)
+ (C-call "gtk_widget_set_can_focus" alien 1))
+ (set-gtk-widget-size-allocate-callback! widget size-allocate-callback)
+ (set-gtk-widget-realize-callback! widget realize-callback)
+ (set-gtk-widget-unrealize-callback! widget unrealize-callback)
+ (set-gtk-widget-event-callback! widget event-callback))
+
+(define (realize-callback widget)
+ (trace2 ";realize "widget"\n")
+ (let ((alien (gobject-alien widget))
+ (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|))
+ (GdkCursor (make-alien '|GdkCursor|))
+ (GtkStyle (make-alien '(struct |_GtkStyle|))))
+
+ ;; Main widget window.
+ (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD"))
+ (let ((b (gtk-event-viewer-geometry widget)))
+ (C->= attr "GdkWindowAttr x" (fix-rect-x b))
+ (C->= attr "GdkWindowAttr y" (fix-rect-y b))
+ (C->= attr "GdkWindowAttr width" (fix-rect-width b))
+ (C->= attr "GdkWindowAttr height" (fix-rect-height b)))
+ (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT"))
+ (C->= attr "GdkWindowAttr event_mask"
+ (bit-or (C-call "gtk_widget_get_events" alien)
+ (C-enum "GDK_EXPOSURE_MASK")))
+
+ (C-call "gtk_widget_get_parent_window" parent-GdkWindow alien)
+ (error-if-null parent-GdkWindow "Could not get parent:" widget)
+
+ (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr
+ (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y")))
+ (error-if-null main-GdkWindow "Could not create main window:" widget)
+ (C->= alien "GtkWidget window" main-GdkWindow)
+ (C-call "gdk_window_set_user_data" main-GdkWindow alien)
+
+ ;; Event window
+ (C-call "gdk_cursor_new" GdkCursor (C-enum "GDK_CROSSHAIR"))
+ (error-if-null GdkCursor "Could not create cursor:" widget)
+ (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD"))
+ (let ((b (gtk-event-viewer-event-box widget)))
+ (C->= attr "GdkWindowAttr x" (fix-rect-x b))
+ (C->= attr "GdkWindowAttr y" (fix-rect-y b))
+ (C->= attr "GdkWindowAttr width" (fix-rect-width b))
+ (C->= attr "GdkWindowAttr height" (fix-rect-height b)))
+ (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT"))
+ (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_CURSOR")))
+ (error-if-null event-GdkWindow "Could not create event window:" widget)
+ (C-call "gdk_window_set_user_data" event-GdkWindow alien)
+ (C-call "gdk_window_show" event-GdkWindow)
+ (C-call "gdk_cursor_destroy" GdkCursor)
+
+ ;; Style
+ (C-call "gtk_style_attach" GtkStyle
+ (C-> alien "GtkWidget style") main-GdkWindow)
+ (C->= alien "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-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 (unrealize-callback widget)
+ (trace2 ";unrealize "widget"\n")
+ ;; Destroy our event 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 0)
+ (C-call "gdk_window_destroy" event-GdkWindow)
+ (alien-null! event-GdkWindow))))
+ ;; The main window will be destroyed by the toolkit.
+ unspecific)
+
+(define (size-allocate-callback widget GtkAllocation)
+ (trace2 ";size-allocate "widget" "GtkAllocation"\n")
+ (let ((alien (gobject-alien widget))
+ (x (C-> GtkAllocation "GtkAllocation x"))
+ (y (C-> GtkAllocation "GtkAllocation y"))
+ (width (C-> GtkAllocation "GtkAllocation width"))
+ (height (C-> GtkAllocation "GtkAllocation height"))
+ (spacing 10))
+ (set-fix-rect! (gtk-event-viewer-geometry widget) x y width height)
+ (C->= alien "GtkWidget allocation x" x)
+ (C->= alien "GtkWidget allocation y" y)
+ (C->= alien "GtkWidget allocation width" width)
+ (C->= alien "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-fix-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-fix-rect! (gtk-event-viewer-description-box widget)
+ desc-x desc-y desc-width desc-height))
+
+ (if (gtk-widget-realized? widget)
+ (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))))
+
+(define (event-callback widget GdkEvent)
+ (trace2 ";event-callback "widget" "GdkEvent"\n")
+ (let ((window (C-> GdkEvent "GdkEvent any window"))
+ (type (C-> GdkEvent "GdkEvent any type")))
+ (trace "; "(C-enum "GdkEventType" type)
+ " on window 0x"(alien/address-string window)".\n")
+
+ (if (not (and (alien=? window (gtk-event-viewer-window widget))
+ (= type (C-enum "GDK_EXPOSE"))))
+ (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") 0 0 0))
+ 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"))
(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))))
+ (else (error "gtk-event-viewer-expose: unexpected window:" window))))
1 ;;TRUE -- handled.
)
;; 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)
+ (-1+ (fix-rect-x rect))
+ (-1+ (fix-rect-y rect))
+ (+ 2 (fix-rect-width rect))
+ (+ 2 (fix-rect-height rect)))
+ (C-call "gdk_gc_set_clip_rectangle" black-gc 0)
;; Draw text in the description area, if applicable.
(if (not (= 0 (C-call "gdk_rectangle_intersect"
exposed-area descrip-gdkrect intersection)))
(let ((space 2)
- (desc-bottom (rect-max-y descrip-box))
+ (desc-bottom (fix-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))
+ (C-call "gtk_widget_create_pango_layout" layout alien 0)
+ (let loop ((y (fix-rect-y descrip-box))
(lines (gtk-event-viewer-buffer widget)))
(if (null? lines)
unspecific
(if (gtk-widget-has-focus? widget)
(C-call "gtk_paint_focus"
- style window state null-alien alien "gtk-event-viewer"
+ style window state 0 alien "gtk-event-viewer"
x y (-1+ width) (-1+ height)))
(free exposed-area)
unspecific))
(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 "pango_layout_get_pixel_extents" layout extent 0)
(C-call "gtk_paint_layout"
(C-> alien "GtkWidget style")
event-window
1 ;; Use the text gc, not the fg gc.
area alien "gtk-event-viewer"
;;center
- (quotient (- (rect-width (gtk-event-viewer-event-box widget))
+ (quotient (- (fix-rect-width (gtk-event-viewer-event-box widget))
(C-> extent "PangoRectangle width"))
2)
0
(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)))))
+ a (fix-rect-x r) (fix-rect-y r) (fix-rect-width r) (fix-rect-height r)))))
\f
(define (event-to-text GdkEvent)
(decorated-string-append
"" " | " ""
(append!
- (if (not (= 0 (bit-and state (C-enum "GDK_SHIFT_MASK"))))
+ (if (bit? state (C-enum "GDK_SHIFT_MASK"))
(list "Shift") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_LOCK_MASK"))))
+ (if (bit? state (C-enum "GDK_LOCK_MASK"))
(list "Lock") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_CONTROL_MASK"))))
+ (if (bit? state (C-enum "GDK_CONTROL_MASK"))
(list "Ctrl") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_MOD1_MASK"))))
+ (if (bit? state (C-enum "GDK_MOD1_MASK"))
(list "Mod1") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_MOD2_MASK"))))
+ (if (bit? state (C-enum "GDK_MOD2_MASK"))
(list "Mod2") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_MOD3_MASK"))))
+ (if (bit? state (C-enum "GDK_MOD3_MASK"))
(list "Mod3") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_MOD4_MASK"))))
+ (if (bit? state (C-enum "GDK_MOD4_MASK"))
(list "Mod4") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_MOD5_MASK"))))
+ (if (bit? state (C-enum "GDK_MOD5_MASK"))
(list "Mod5") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON1_MASK"))))
+ (if (bit? state (C-enum "GDK_BUTTON1_MASK"))
(list "Button1") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON2_MASK"))))
+ (if (bit? state (C-enum "GDK_BUTTON2_MASK"))
(list "Button2") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON3_MASK"))))
+ (if (bit? state (C-enum "GDK_BUTTON3_MASK"))
(list "Button3") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_BUTTON4_MASK"))))
+ (if (bit? state (C-enum "GDK_BUTTON4_MASK"))
(list "Button4") '())
- (if (not (= 0 (bit-and state (C-enum "GDK_RELEASE_MASK"))))
+ (if (bit? state (C-enum "GDK_RELEASE_MASK"))
(list "Release") '())))
"\n"))))
(if (or (not line) (string=? line "\n")) #f line)))
(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 trace2? #f)
+
(define-syntax trace2
(syntax-rules ()
((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010 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.
+
+|#
+
+;;;; Gtk System Packaging
+
+(global-definitions "../runtime/runtime")
+(global-definitions "../ffi/ffi")
+(global-definitions "../sos/sos")
+
+;;; This is largely a copy of gtk.pkg, with a few new declarations added.
+
+(declare (usual-integrations))
+
+(define-package (gtk)
+ (parent ())
+ (files "gtk"))
+
+(define-package (gtk gobject)
+ (parent (gtk))
+ (files "gobject")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ <gobject> gobject-alien
+ gobject-live? gobject-unref!
+ g-signal-connect g-signal-disconnect
+ add-gc-cleanup punt-gc-cleanup
+ gobject-get-property gobject-set-properties
+ gquark-from-string gquark-to-string
+ <pixbuf-loader> make-pixbuf-loader
+ load-pixbuf-from-port load-pixbuf-from-file
+ pixbuf-loader-size-hook set-pixbuf-loader-size-hook!
+ pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook!
+ pixbuf-loader-update-hook set-pixbuf-loader-update-hook!
+ pixbuf-loader-close-hook set-pixbuf-loader-close-hook!
+ pixbuf-loader-pixbuf pixbuf-loader-error-message
+ <pixbuf>
+ gdk-window-process-updates))
+
+(define-package (gtk pango)
+ (parent (gtk))
+ (files "pango")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ <pango-layout>
+ pango-layout-get-context
+ pango-layout-context-changed
+ pango-layout-get-font-description
+ pango-layout-set-font-description
+ pango-layout-set-text
+ pango-layout-get-pixel-extents
+ pango-layout-index-to-pos
+ pango-font-description-from-string
+ pango-font-description-to-string
+ pango-font-description-free
+ pango-context-get-font-description
+ pango-context-set-font-description
+ pango-context-get-metrics
+ pango-context-spacing
+ pango-font-metrics-get-ascent
+ pango-font-metrics-get-descent
+ pango-font-metrics-get-approximate-char-width
+ pango-font-metrics-unref))
+
+(define-package (gtk gtk-object)
+ (parent (gtk))
+ (files "gtk-object")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ <gtk-object> gtk-object? guarantee-gtk-object
+ gtk-object-destroyed? gtk-object-destroy
+ <gtk-adjustment> gtk-adjustment? guarantee-gtk-adjustment
+ make-gtk-adjustment set-gtk-adjustment!
+ <gtk-widget> gtk-widget? guarantee-gtk-widget
+ gtk-widget-parent
+ gtk-widget-realized?
+ gtk-widget-drawable? gtk-widget-has-focus?
+ gtk-widget-grab-focus
+ gtk-widget-show
+ gtk-widget-show-all
+ gtk-widget-error-bell
+ gtk-widget-queue-draw
+ gtk-widget-get-colormap
+ gtk-widget-get-pango-context
+ gtk-widget-create-pango-layout
+ gtk-widget-set-size-request
+ ;;gtk-widget-set-can-focus
+ set-gtk-widget-size-allocate-callback!
+ set-gtk-widget-realize-callback!
+ set-gtk-widget-unrealize-callback!
+ set-gtk-widget-event-callback!
+
+ gtk-widget-font set-gtk-widget-font!
+ gtk-widget-fg-color gtk-widget-bg-color
+ gtk-widget-text-color gtk-widget-base-color
+ set-gtk-widget-fg-color! set-gtk-widget-bg-color!
+ set-gtk-widget-text-color! set-gtk-widget-base-color!
+ gtk-widget-parse-color
+
+ <gtk-container> gtk-container? guarantee-gtk-container
+ gtk-container-children gtk-bin-child
+ gtk-container-add gtk-container-remove
+ gtk-container-set-border-width
+ ;;gtk-container-set-resize-mode
+ ;;gtk-container-check-resize
+
+ <gtk-window> gtk-window? guarantee-gtk-window
+ gtk-window-new gtk-window-set-title gtk-window-type
+ gtk-window-set-opacity
+ gtk-window-set-default-size gtk-window-get-default-size
+ gtk-window-parse-geometry
+ gtk-window-resize
+ gtk-window-present
+ set-gtk-window-delete-event-callback!
+ <gtk-label> gtk-label? guarantee-gtk-label
+ gtk-label-new
+ gtk-label-get-text gtk-label-set-text
+ gtk-label-set-width-chars
+ <gtk-button> gtk-button? guarantee-gtk-button
+ gtk-button-new
+ set-gtk-button-clicked-callback!
+ <gtk-check-button> gtk-check-button? guarantee-gtk-check-button
+ gtk-check-button-new
+ gtk-check-button-get-active gtk-check-button-set-active
+ set-gtk-check-button-toggled-callback!
+ <gtk-vbox> gtk-vbox? guarantee-gtk-vbox gtk-vbox-new
+ <gtk-hbox> gtk-hbox? guarantee-gtk-hbox gtk-hbox-new
+ gtk-box-pack-start gtk-box-pack-end
+ <gtk-frame> gtk-frame? guarantee-gtk-frame gtk-frame-new
+ gtk-frame-set-shadow-type
+ <gtk-scrolled-window> gtk-scrolled-window?
+ guarantee-gtk-scrolled-window gtk-scrolled-window-new
+ gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement)
+ (import (gtk pango) make-pango-layout guarantee-pango-font-description))
+
+(define-package (gtk widget)
+ (parent (gtk))
+ (files "scm-widget")
+ (depends-on "gtk-const.bin")
+ (import (gtk gtk-object)
+ set-gtk-object-destroy-callback!)
+ (export (gtk)
+ <scm-widget>
+ set-scm-widget-set-scroll-adjustments-callback!))
+
+(define-package (gtk fix-layout)
+ (parent (gtk))
+ (files "fix-layout")
+ (depends-on "gtk.ext" "pango.ext" "gtk-const.bin")
+ (import (gtk pango)
+ make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
+ (import (gtk gtk-object)
+ parse-gdkcolor set-gtk-object-destroy-callback!)
+ (export (gtk)
+
+ <fix-layout> fix-layout? make-fix-layout set-fix-layout-size!
+ fix-layout-drawing set-fix-layout-drawing!
+ fix-layout-scroll-step set-fix-layout-scroll-step!
+ fix-layout-view fix-layout-scroll-to! fix-layout-scroll-nw!
+ fix-layout-new-geometry-callback fix-layout-realize-callback
+ set-fix-layout-map-handler!
+ set-fix-layout-unmap-handler!
+ set-fix-layout-focus-change-handler!
+ set-fix-layout-visibility-notify-handler!
+ set-fix-layout-key-press-handler!
+ set-fix-layout-motion-handler!
+ set-fix-layout-button-handler!
+
+ <fix-drawing> make-fix-drawing fix-drawing-widgets
+ set-fix-drawing-size! fix-drawing-pick-list
+ fix-drawing-add-ink!
+
+ <fix-ink> fix-ink?
+ fix-ink-drawing
+ fix-ink-widgets set-fix-ink-widgets!
+ fix-ink-move! fix-ink-remove!
+ <draw-ink>
+
+ <line-ink> line-ink? make-line-ink set-line-ink!
+ line-ink-width set-line-ink-width!
+ line-ink-color set-line-ink-color!
+ line-ink-dash-color set-line-ink-dash-color!
+
+ <rectangle-ink> rectangle-ink? make-rectangle-ink set-rectangle-ink!
+ rectangle-ink-color set-rectangle-ink-color!
+ rectangle-ink-width set-rectangle-ink-width!
+ rectangle-ink-fill-color set-rectangle-ink-fill-color!
+
+ <arc-ink> arc-ink? make-arc-ink set-arc-ink!
+ arc-ink-start-angle set-arc-ink-start-angle!
+ arc-ink-sweep-angle set-arc-ink-sweep-angle!
+ arc-ink-color set-arc-ink-color!
+ arc-ink-width set-arc-ink-width!
+ arc-ink-fill-color set-arc-ink-fill-color!
+
+ <text-ink> text-ink?
+ set-text-ink-position!
+ text-ink-xy-to-index
+ with-text-ink-grapheme-rect
+ text-ink-color set-text-ink-color!
+
+ <simple-text-ink> simple-text-ink? make-simple-text-ink
+ simple-text-ink-text set-simple-text-ink-text!
+ simple-text-ink-font set-simple-text-ink-font!
+
+ <image-ink> make-image-ink-from-file set-image-ink!
+
+ <box-ink> box-ink? make-box-ink
+ set-box-ink! set-box-ink-position!
+ box-ink-shadow set-box-ink-shadow!
+
+ ;;<hline-ink> make-hline-ink set-hline-ink-size!
+ ;;<vline-ink> make-vline-ink set-vline-ink-size!
+ ))
+
+(define-package (gtk keys)
+ (parent (gtk))
+ (files "keys")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ gdk-key-state->char-bits
+ gdk-keyval->name))
+
+(define-package (gtk thread)
+ (parent (runtime thread))
+ (files "thread")
+ (depends-on "gtk.ext" "pango.ext")
+ (export (gtk)
+ kill-gtk-thread)
+ (import (gtk gobject)
+ run-gc-cleanups)
+ (import (runtime primitive-io)
+ select-registry-handle))
+
+(define-package (gtk main)
+ (parent (gtk))
+ (files "main")
+ (depends-on "gtk-const.bin")
+ (import (runtime load)
+ *unused-command-line*
+ hook/process-command-line
+ default/process-command-line)
+ (import (runtime)
+ ucode-primitive)
+ (import (gtk thread)
+ create-gtk-thread)
+ (export (gtk)
+ gtk-time-slice-window?
+ gtk-time-slice-window!
+ gtk-select-trace?
+ gtk-select-trace!))
+
+(define-package (gtk event-viewer)
+ (parent (gtk))
+ (files "gtk-ev")
+ (depends-on "gtk.ext" "pango.ext" "gtk-const.bin")
+ (import (gtk fix-layout)
+ gdk-rectangle gdk-rectangle-from-rect
+ make-fix-rect
+ fix-rect-x fix-rect-y fix-rect-width fix-rect-height
+ fix-rect-max-y set-fix-rect! fix-rect-union!)
+ (import (gtk pango)
+ pango-rectangle pangos->pixels)
+ (export ()
+ make-gtk-event-viewer-demo))
+
+(define-package (gtk fix-layout demo)
+ (parent (gtk fix-layout))
+ (files "fix-demo")
+ (depends-on "gtk.ext" "pango.ext")
+ (import (gtk fix-layout)
+ fix-layout-view)
+ (export ()
+ make-fix-layout-demo))
+
+(define-package (gtk swat)
+ (parent (gtk))
+ (files "swat")
+ (depends-on "gtk.ext" "pango.ext")
+ (import (gtk gtk-object)
+ gtk-object-destroy-callback)
+ (import (gtk fix-layout)
+ fix-layout-view fix-ink-extent fix-ink-expose-callback
+ fix-drawing-display-list set-fix-drawing-display-list!
+ set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in?
+ fix-rect-x fix-rect-y with-fix-rect
+ set-fix-rect-size! fix-rect-move! copy-fix-rect!
+ point-in-fix-rect? fix-rect-union!)
+ (export (swat)
+ add-child! remove-child! ask-widget
+ add-event-handler! set-callback!
+ after-delay on-death!
+ swat-open swat-close
+ make-active-variable set-active-variable!
+ make-hbox make-vbox box-children
+ make-button make-label
+ make-checkbutton checkbutton-variable-on?
+ make-canvas make-canvas-item-group
+ make-line-on-canvas make-rectangle-on-canvas
+ make-oval-on-canvas make-text-on-canvas))
+
+(define-package (swat)
+ (parent ()))
+
+#;(define-package (swat examples)
+ (parent (swat))
+ (files "swat-examples"))
+
+(define-package (swat pole-zero)
+ (parent (swat))
+ (files "swat-pole-zero")
+ (export ()
+ make-pole-zero))
+
+#;(define-package (swat plotter)
+ (parent (swat))
+ (files "swat-plotter")
+ (export ()
+ plotter
+ plot
+ set-plotter-params
+ reset-plotter-params
+ make-vals
+ change-color
+ change-pt-style
+ change-num-pts
+ clear-curve
+ plot-curve
+ delete-curve
+ add-show-vals
+ clear-show-vals
+ draw-show-vals
+ delete-show-vals
+ add-xticks
+ add-yticks
+ clear-ticks
+ draw-ticks
+ delete-ticks
+ clear-plotter
+ replot
+ reset-plotter))
\ No newline at end of file
;;;; GtkObjects/GtkWidgets/GtkContainers
;;; package: (gtk 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.
- (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).
- (named-lambda (gtk-object::cleanup-thunk)
- (trace ";gtk-object::cleanup-thunk "alien"\n")
- (gtk-object-cleanup alien signals)
- (trace ";gtk-object::cleanup-thunk done with "alien"\n")))
-
-(define (gtk-object-cleanup alien signals)
- ;; Run as a gc-cleanup, without-interrupts. Calls
- ;; gtk_object_destroy (if necessary), and de-registers the Scheme
- ;; signal handlers.
- (trace ";gtk-object::cleanup "alien"\n")
- (if (not (alien-null? alien))
+(define-guarantee gtk-object "a <gtk-object>")
+
+;;; This is unfortunate. We rely on the most specialized method to
+;;; call out, creating a specific type of GtkObject. We want the
+;;; <gobject> method to go first, as usual, to add a gc-cleanup, but
+;;; this method to go last, AFTER the most specific (most unusual!)
+;;; else it cannot connect its destroy-callback. To do both would
+;;; take... a computed effective method procedure? For now, rely on
+;;; the method that calls out to set-gtk-object-destroy-callback! as
+;;; well as g_object_ref_sink.
+
+#;(define-method initialize-instance ((object <gtk-object>))
+ (call-next-method object)
+ (g-signal-connect object (C-callback "destroy") gtk-object-destroy-callback))
+
+(define (set-gtk-object-destroy-callback! object)
+ (g-signal-connect object (C-callback "destroy") gtk-object-destroy-callback))
+
+;;; Methods of this generic procedure should drop references to other
+;;; gobject instances used by @var{object}. If these instances are
+;;; not shared, they can be explicitly g-object-unref!ed. Else they
+;;; should be dropped, e.g. replaced with #f, to be cleaned up by the
+;;; garbage collector.
+(define-generic gtk-object-destroy-callback (object))
+
+(define-method gtk-object-destroy-callback ((object <gtk-object>))
+ (if (not (gtk-object-destroyed? object))
(begin
- (C-call "gtk_object_destroy" alien)
- (alien-null! alien)))
- ;; De-register signals. Nulled alien will not be g_object_unrefed.
- (gobject-cleanup alien signals)
- (trace ";gtk-object::cleanup done with "alien"\n"))
-
-(define-generic gtk-object-destroy (object))
-
-(define-method gtk-object-destroy ((object <gtk-object>))
- ;; Calls gtk_object_destroy and sets the destroyed? flag.
- (without-interrupts
- (lambda ()
- (if (not (gtk-object-destroyed? object))
- (begin
- (set-gtk-object-destroyed?! object #t)
- (gtk-object-cleanup
- (gobject-alien object) (gobject-signals object)))))))
-
-(define-integrable (gtk-object-flags gtkobject)
- ;; Returns GTK_OBJECT(obj)->flags.
- (let ((alien (gobject-alien (check-gtk-object gtkobject))))
- (C-> alien "GtkObject flags")))
-
-(declare (integrate-operator check-gtk-object))
-(define (check-gtk-object object)
- (if (gtk-object? object) object
- (error:wrong-type-argument object "<gtk-object>" 'check-gtk-object)))
+ (set-gtk-object-destroyed?! object #t)
+ (gobject-unref! object))))
+
+(define (gtk-object-destroy object)
+ (guarantee-live-gtk-object object 'gtk-object-destroy)
+ (C-call "gtk_object_destroy" (gobject-alien object)))
+
+(define-integrable-operator (guarantee-live-gtk-object object operator)
+ (guarantee-gtk-object object operator)
+ (if (gtk-object-destroyed? object)
+ (error "Gtk-object destroyed:" object operator))
+ (if (not (gobject-live? object))
+ (error "Gtk-object dead:" object operator)))
+
+(define (gtk-object-flags object)
+ ;; Returns GTK_OBJECT(object)->flags.
+ (C-> (gobject-alien object) "GtkObject flags"))
\f
-
-;;;; GtkAdjustments
+;;; 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-guarantee gtk-adjustment "a <gtk-adjustment>")
+
+(define-integrable-operator (guarantee-live-gtk-adjustment object operator)
+ (guarantee-gtk-adjustment object operator)
+ (if (not (gobject-live? object))
+ (error "Gtk-adjustment dead:" object operator)))
(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"))))
+ (guarantee-live-gtk-adjustment adjustment 'set-gtk-adjustment!)
+ (guarantee-real lower 'set-gtk-adjustment!)
+ (guarantee-real upper 'set-gtk-adjustment!)
+ (guarantee-real page-size 'set-gtk-adjustment!)
+ (guarantee-real step-incr 'set-gtk-adjustment!)
+ (guarantee-real page-incr 'set-gtk-adjustment!)
+ (define-integrable f->e floor->exact)
+ (let ((alien (gobject-alien adjustment))
+ (new-lower (f->e lower))
+ (new-upper (f->e upper))
+ (new-value (f->e value))
+ (new-page-size (f->e page-size))
+ (new-step-incr (f->e step-incr))
+ (new-page-incr (f->e page-incr)))
+ (let ((old-lower (f->e (C-> alien "GtkAdjustment lower")))
+ (old-upper (f->e (C-> alien "GtkAdjustment upper")))
+ (old-value (f->e (C-> alien "GtkAdjustment value")))
+ (old-page-size (f->e (C-> alien "GtkAdjustment page_size")))
+ (old-step-incr (f->e (C-> alien "GtkAdjustment step_increment")))
+ (old-page-incr (f->e (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))
(define (peek-gtk-adjustment adjustment)
;; For debugging...
- (let ((alien (live-alien-adjustment adjustment)))
- (list
- (C-> alien "GtkAdjustment lower")
- (C-> alien "GtkAdjustment upper")
- (C-> alien "GtkAdjustment value")
- (C-> alien "GtkAdjustment page_size")
- (C-> alien "GtkAdjustment step_increment")
- (C-> alien "GtkAdjustment page_increment"))))
-
-(declare (integrate-operator check-real))
-(define (check-real object)
- (if (real? object) object
- (error:wrong-type-argument object "real number" 'check-real)))
+ (list
+ (C-> adjustment "GtkAdjustment lower")
+ (C-> adjustment "GtkAdjustment upper")
+ (C-> adjustment "GtkAdjustment value")
+ (C-> adjustment "GtkAdjustment page_size")
+ (C-> adjustment "GtkAdjustment step_increment")
+ (C-> adjustment "GtkAdjustment page_increment")))
\f
-
-;;;; GtkWidgets, GtkContainers
+;;; GtkWidgets
(define-class <gtk-widget> (<gtk-object>)
;; The parent <gtk-widget> or #f.
(parent define standard initial-value #f))
+(define-guarantee gtk-widget "a <gtk-widget>")
+
+(define-method gtk-object-destroy-callback ((widget <gtk-widget>))
+ (call-next-method widget)
+ (let ((parent (gtk-widget-parent widget)))
+ (if (and parent (not (gtk-object-destroyed? parent)))
+ (container-remove! parent widget))))
+
+(define (gtk-widget-realized? widget)
+ (guarantee-gtk-widget widget 'gtk-widget-realized?)
+ (let ((flags (gtk-object-flags widget)))
+ (bit? flags (C-enum "GTK_REALIZED"))))
+
(define (gtk-widget-has-focus? widget)
+ (guarantee-gtk-widget widget 'gtk-widget-has-focus?)
(let ((flags (gtk-object-flags widget)))
- (not (int:zero? (bit-and flags (C-enum "GTK_HAS_FOCUS"))))))
+ (bit? flags (C-enum "GTK_HAS_FOCUS"))))
(define (gtk-widget-drawable? widget)
+ (guarantee-gtk-widget widget 'gtk-widget-drawable?)
(let ((flags (gtk-object-flags widget)))
- (and (not (int:zero? (bit-and flags (C-enum "GTK_VISIBLE"))))
- (not (int:zero? (bit-and flags (C-enum "GTK_MAPPED")))))))
+ (and (bit? flags (C-enum "GTK_VISIBLE"))
+ (bit? flags (C-enum "GTK_MAPPED")))))
(define (gtk-widget-grab-focus widget)
- (C-call "gtk_widget_grab_focus" (check-gtk-widget-alien widget)))
+ (guarantee-gtk-widget widget 'gtk-widget-grab-focus)
+ (C-call "gtk_widget_grab_focus" (gobject-alien widget)))
+
+(define (gtk-widget-show widget)
+ (guarantee-gtk-widget widget 'gtk-widget-show)
+ (C-call "gtk_widget_show" (gobject-alien widget)))
(define (gtk-widget-show-all widget)
- (C-call "gtk_widget_show_all" (check-gtk-widget-alien widget)))
+ (guarantee-gtk-widget widget 'gtk-widget-show-all)
+ (C-call "gtk_widget_show_all" (gobject-alien widget)))
(define (gtk-widget-error-bell widget)
- (C-call "gtk_widget_error_bell" (check-gtk-widget-alien widget)))
+ (guarantee-gtk-widget widget 'gtk-widget-error-bell)
+ (C-call "gtk_widget_error_bell" (gobject-alien widget)))
(define (gtk-widget-queue-draw widget)
- (C-call "gtk_widget_queue_draw" (check-gtk-widget-alien widget)))
+ (guarantee-gtk-widget widget 'gtk-widget-queue-draw)
+ (C-call "gtk_widget_queue_draw" (gobject-alien widget)))
(define (gtk-widget-get-pango-context widget)
+ (guarantee-gtk-widget widget 'gtk-widget-get-pango-context)
(C-call "gtk_widget_get_pango_context"
(make-alien '|PangoContext|) (gobject-alien widget)))
(define (gtk-widget-create-pango-layout widget #!optional text)
- (let ((t (if (default-object? text) 0 (check-string text)))
- (w (check-gtk-widget widget)))
- (let ((l (make-pango-layout)))
- (C-call "gtk_widget_create_pango_layout"
- (gobject-alien l) (gobject-alien w) t)
- l)))
-
-(define (check-string object)
- (if (string? object) object
- (error:wrong-type-argument object "a string" 'check-string)))
+ (guarantee-gtk-widget widget 'gtk-widget-create-pango-layout)
+ (if (not (default-object? text))
+ (guarantee-string text 'gtk-widget-create-pango-layout))
+ (let ((layout (make-pango-layout)))
+ (C-call "gtk_widget_create_pango_layout"
+ (gobject-alien layout) (gobject-alien widget)
+ (if (default-object? text) 0 text))
+ (error-if-null layout "Could not create:" layout)
+ layout))
(define (gtk-widget-set-size-request widget width height)
(C-call "gtk_widget_set_size_request" (gobject-alien widget) width height))
-\f
-;;;; GtkWidget Font
+(define (set-gtk-widget-size-allocate-callback! widget callback)
+ (guarantee-gtk-widget widget 'set-gtk-widget-size-allocate-callback!)
+ (guarantee-procedure-of-arity callback 2 'set-gtk-widget-size-allocate-callback!)
+ (g-signal-connect widget (C-callback "size_allocate") callback))
+
+(define (set-gtk-widget-realize-callback! widget callback)
+ (guarantee-gtk-widget widget 'set-gtk-widget-realize-callback!)
+ (guarantee-procedure-of-arity callback 1 'set-gtk-widget-realize-callback!)
+ (g-signal-connect widget (C-callback "realize") callback))
+
+(define (set-gtk-widget-unrealize-callback! widget callback)
+ (guarantee-gtk-widget widget 'set-gtk-widget-unrealize-callback!)
+ (guarantee-procedure-of-arity callback 1 'set-gtk-widget-unrealize-callback!)
+ (g-signal-connect widget (C-callback "unrealize") callback))
+
+(define (set-gtk-widget-event-callback! widget callback)
+ (guarantee-gtk-widget widget 'set-gtk-widget-event-callback!)
+ (guarantee-procedure-of-arity callback 2 'set-gtk-widget-event-callback!)
+ (g-signal-connect widget (C-callback "event") callback))
+\f
+;;; GtkWidget Font
(define (gtk-widget-font widget)
- (let ((alien (check-gtk-widget-alien widget))
- (desc (make-alien '|PangoFontDescription|)))
- (C-> alien "GtkWidget style" desc)
+ (guarantee-gtk-widget-realized widget 'gtk-widget-font)
+ (let ((desc (make-alien '|PangoFontDescription|)))
+ (C-> (gobject-alien widget) "GtkWidget style" desc)
(C-> desc "GtkStyle font_desc" desc)
desc))
(define (set-gtk-widget-font! widget desc)
+ (guarantee-gtk-widget-realized widget 'set-gtk-widget-font!)
(let ((font (->PangoFontDescription desc)))
(modify-rcstyle widget (lambda (rcstyle)
(set-rcstyle-font! rcstyle font)))))
(C-call "gtk_widget_queue_draw" gtkwidget)))
(define (set-rcstyle-font! rcstyle pangofontdescription)
- (C->= rcstyle "struct _GtkRcStyle font_desc" pangofontdescription))
+ (let ((old (C-> rcstyle "GtkRcStyle font_desc"))
+ (new (C-call "pango_font_description_copy"
+ (make-alien 'PangoFontDescription)
+ pangofontdescription)))
+ (if (not (alien-null? old))
+ (C-call "pango_font_description_free" old))
+ (C->= rcstyle "GtkRcStyle font_desc" new)))
(define (->PangoFontDescription desc)
(cond ((and (alien? desc) (eq? '|PangoFontDescription| (alien/ctype desc)))
(else (error:wrong-type-argument desc "PangoFontDescription"
'->PangoFontDescription))))
\f
+;;; GtkWidget Colors
+
+(define-generic gtk-widget-get-colormap (widget))
-;;;; GtkWidget Colors
-
-(define (gtk-widget-fg-color widget)
- ;; Returns WIDGET's foreground color as a new vector: #(red green blue).
- (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style")))
- (peek-rgb (C-> gtkstyle "GtkStyle fg"))))
-
-(define (peek-rgb colors)
- (let ((color (C-array-loc colors "GdkColor" (C-enum "GTK_STATE_NORMAL"))))
- (vector (/ (C-> color "GdkColor red") 65535)
- (/ (C-> color "GdkColor green") 65535)
- (/ (C-> color "GdkColor blue") 65535))))
-
-(define (gtk-widget-bg-color widget)
- ;; Returns WIDGET's background color as a new vector: #(red green blue).
- (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style")))
- (peek-rgb (C-> gtkstyle "GtkStyle bg"))))
-
-(define (gtk-widget-text-color widget)
- ;; Returns WIDGET's text color as a new vector: #(red green blue).
- (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style")))
- (peek-rgb (C-> gtkstyle "GtkStyle text"))))
-
-(define (gtk-widget-base-color widget)
- ;; Returns WIDGET's base color as a new vector: #(red green blue).
- (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style")))
- (peek-rgb (C-> gtkstyle "GtkStyle base"))))
-
-(define (set-gtk-widget-fg-color! widget color)
- ;; Sets WIDGET's foreground color. Queues a complete redraw.
- (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-fg-color!)))
+(define-method gtk-widget-get-colormap ((widget <gtk-widget>))
+ (C-call "gtk_widget_get_colormap"
+ (make-alien '|GdkColormap|)
+ (gobject-alien widget)))
+
+(define (gtk-widget-parse-color widget spec)
+ (guarantee-gtk-widget widget 'gtk-widget-parse-color)
+ (guarantee-string spec 'gtk-widget-parse-color)
+ (let ((gdkcolor (parse-gdkcolor spec widget)))
+ (if gdkcolor
+ (let ((rgb (peek-gdkcolor gdkcolor)))
+ (free gdkcolor)
+ rgb)
+ #f)))
+
+(define-integrable-operator (peek-gdkcolor gdkcolor)
+ (vector (/ (C-> gdkcolor "GdkColor red") 65535)
+ (/ (C-> gdkcolor "GdkColor green") 65535)
+ (/ (C-> gdkcolor "GdkColor blue") 65535)))
+
+(define (parse-gdkcolor spec widget)
+ ;; Return a malloced GdkColor with its RGB components filled in from
+ ;; SPEC. Does not allocate the color.
+ (cond ((string? spec) (lookup-gdkcolor widget spec))
+ ((symbol? spec) (lookup-gdkcolor widget (symbol-name spec)))
+ ((and (vector? spec) (= 3 (vector-length spec)))
+ (let ((new (malloc (C-sizeof "GdkColor") '|GdkColor|)))
+ (define-integrable (ref i)
+ (round->exact (* (vector-ref spec i) 65535)))
+ (C->= new "GdkColor red" (ref 0))
+ (C->= new "GdkColor blue" (ref 1))
+ (C->= new "GdkColor green" (ref 2))
+ new))
+ (else #f)))
+
+(define (lookup-gdkcolor widget string)
+ ;; Return a malloced GdkColor with the RGB components of a color
+ ;; named by STRING. Returns #f if the color name is unknown.
+ (let ((style (C-> (gobject-alien widget) "GtkWidget style"))
+ (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|)))
+ (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor))
+ (zero? (C-call "gdk_color_parse" string gdkcolor)))
+ (begin
+ (free gdkcolor)
+ #f)
+ gdkcolor)))
+
+(define (->gdkcolor spec widget operator)
+ (or (parse-gdkcolor spec widget)
+ (error:wrong-type-argument spec "a Gtk color spec." operator)))
+
+(define-integrable-operator (guarantee-gtk-widget-realized widget operator)
+ (guarantee-gtk-widget widget operator)
+ (if (not (gtk-widget-realized? widget))
+ (error "Not yet realized:" widget operator)))
+
+(define (gtk-widget-fg-color widget #!optional state)
+ (guarantee-gtk-widget-realized widget 'gtk-widget-fg-color)
+ (let ((state (->gtk-widget-state state 'gtk-widget-fg-color))
+ (alien (make-alien '|GdkColor|)))
+ (C-> (gobject-alien widget) "GtkWidget style" alien)
+ (C-> alien "GtkStyle fg" alien)
+ (C-array-loc! alien "GdkColor" state)
+ (peek-gdkcolor alien)))
+
+(define (gtk-widget-bg-color widget #!optional state)
+ (guarantee-gtk-widget-realized widget 'gtk-widget-bg-color)
+ (let ((state (->gtk-widget-state state 'gtk-widget-bg-color))
+ (alien (make-alien '|GdkColor|)))
+ (C-> (gobject-alien widget) "GtkWidget style" alien)
+ (C-> alien "GtkStyle bg" alien)
+ (C-array-loc! alien "GdkColor" state)
+ (peek-gdkcolor alien)))
+
+(define (gtk-widget-text-color widget #!optional state)
+ (guarantee-gtk-widget-realized widget 'gtk-widget-text-color)
+ (let ((state (->gtk-widget-state state 'gtk-widget-text-color))
+ (alien (make-alien '|GdkColor|)))
+ (C-> (gobject-alien widget) "GtkWidget style" alien)
+ (C-> alien "GtkStyle text" alien)
+ (C-array-loc! alien "GdkColor" state)
+ (peek-gdkcolor alien)))
+
+(define (gtk-widget-base-color widget #!optional state)
+ (guarantee-gtk-widget-realized widget 'gtk-widget-base-color)
+ (let ((state (->gtk-widget-state state 'gtk-widget-base-color))
+ (alien (make-alien '|GdkColor|)))
+ (C-> (gobject-alien widget) "GtkWidget style" alien)
+ (C-> alien "GtkStyle base" alien)
+ (C-array-loc! alien "GdkColor" state)
+ (peek-gdkcolor alien)))
+
+(define (set-gtk-widget-fg-color! widget color #!optional state)
+ (guarantee-gtk-widget-realized widget 'set-gtk-widget-fg-color!)
+ (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-fg-color!))
+ (state (->gtk-widget-state state 'set-gtk-widget-fg-color!)))
(modify-rcstyle widget (lambda (rcstyle)
- (set-rcstyle-fg-color! rcstyle gdkcolor)))
+ (set-rcstyle-fg-color! rcstyle gdkcolor state)))
(free gdkcolor)))
-(define (set-rcstyle-fg-color! rcstyle gdkcolor)
- (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
- (C-> rcstyle "struct _GtkRcStyle fg")
- (C-> rcstyle "struct _GtkRcStyle color_flags")
+(define (set-rcstyle-fg-color! rcstyle gdkcolor state)
+ (set-rcstyle-gdkcolor! gdkcolor state
+ (C-> rcstyle "GtkRcStyle fg")
+ (C-> rcstyle "GtkRcStyle color_flags")
(C-enum "GTK_RC_FG")))
(define (set-rcstyle-gdkcolor! newcolor index colors flagss newflag)
- ;; Hack modifier style GdkColor array and corresponding flags.
(let ((color (C-array-loc! colors "GdkColor" index))
(flags (C-array-loc! flagss "uint" index)))
(C->= color "GdkColor red" (C-> newcolor "GdkColor red"))
(C->= color "GdkColor blue" (C-> newcolor "GdkColor blue"))
(C->= flags "GtkRcFlags" (fix:or newflag (C-> flags "GtkRcFlags")))))
-(define (set-gtk-widget-bg-color! widget color)
- ;; Sets WIDGET's background color. Queues a complete redraw.
- (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-bg-color!)))
+(define-generic set-gtk-widget-bg-color! (widget color #!optional state))
+
+(define-method set-gtk-widget-bg-color! ((widget <gtk-widget>) color
+ #!optional state)
+ (let ((gdkcolor (->gdkcolor color widget '(set-gtk-widget-bg-color! <gtk-widget>)))
+ (state (->gtk-widget-state state '(set-gtk-widget-bg-color! <gtk-widget>))))
(modify-rcstyle widget (lambda (rcstyle)
- (set-rcstyle-bg-color! rcstyle gdkcolor)))
+ (set-rcstyle-bg-color! rcstyle gdkcolor state)))
(free gdkcolor)))
-(define (set-rcstyle-bg-color! rcstyle gdkcolor)
- (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
- (C-> rcstyle "struct _GtkRcStyle bg")
- (C-> rcstyle "struct _GtkRcStyle color_flags")
+(define (set-rcstyle-bg-color! rcstyle gdkcolor state)
+ (set-rcstyle-gdkcolor! gdkcolor state
+ (C-> rcstyle "GtkRcStyle bg")
+ (C-> rcstyle "GtkRcStyle color_flags")
(C-enum "GTK_RC_BG")))
-(define (set-gtk-widget-text-color! widget color)
- ;; Queues a complete redraw.
- (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-text-color!)))
+(define (set-gtk-widget-text-color! widget color #!optional state)
+ (guarantee-gtk-widget-realized widget 'set-gtk-widget-text-color!)
+ (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-text-color!))
+ (state (->gtk-widget-state state 'set-gtk-widget-text-color!)))
(modify-rcstyle widget (lambda (rcstyle)
- (set-rcstyle-text-color! rcstyle gdkcolor)))
+ (set-rcstyle-text-color! rcstyle gdkcolor state)))
(free gdkcolor)))
-(define (set-rcstyle-text-color! rcstyle gdkcolor)
- (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
- (C-> rcstyle "struct _GtkRcStyle text")
- (C-> rcstyle "struct _GtkRcStyle color_flags")
+(define (set-rcstyle-text-color! rcstyle gdkcolor state)
+ (set-rcstyle-gdkcolor! gdkcolor state
+ (C-> rcstyle "GtkRcStyle text")
+ (C-> rcstyle "GtkRcStyle color_flags")
(C-enum "GTK_RC_TEXT")))
-(define (set-gtk-widget-base-color! widget color)
- ;; Queues a complete redraw.
- (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-base-color!)))
+(define (set-gtk-widget-base-color! widget color #!optional state)
+ (guarantee-gtk-widget-realized widget 'set-gtk-widget-base-color!)
+ (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-base-color!))
+ (state (->gtk-widget-state state 'set-gtk-widget-base-color!)))
(modify-rcstyle widget (lambda (rcstyle)
- (set-rcstyle-base-color! rcstyle gdkcolor)))
+ (set-rcstyle-base-color! rcstyle gdkcolor state)))
(free gdkcolor)))
-(define (set-rcstyle-base-color! rcstyle gdkcolor)
- (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
- (C-> rcstyle "struct _GtkRcStyle base")
- (C-> rcstyle "struct _GtkRcStyle color_flags")
+(define (set-rcstyle-base-color! rcstyle gdkcolor state)
+ (set-rcstyle-gdkcolor! gdkcolor state
+ (C-> rcstyle "GtkRcStyle base")
+ (C-> rcstyle "GtkRcStyle color_flags")
(C-enum "GTK_RC_BASE")))
-(define (->gdkcolor object widget operator)
- (let ((rgb (->rgb object widget operator))
- (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|)))
- (C->= gdkcolor "GdkColor red" (round->exact (* (vector-ref rgb 0) 65535)))
- (C->= gdkcolor "GdkColor green" (round->exact(* (vector-ref rgb 1) 65535)))
- (C->= gdkcolor "GdkColor blue" (round->exact (* (vector-ref rgb 2) 65535)))
- gdkcolor))
-
-(define (->rgb object widget operator)
- (or (and (string? object)
- (gtk-widget-parse-color widget object))
- (and (vector? object) (= 3 (vector-length object))
- object)
- (error:wrong-type-argument object "a color name or #(rgb)" operator)))
-
-(define (gtk-widget-parse-color widget string)
- ;; Returns the color named by STRING, or #F. STRING can be a color
- ;; name, hex number, or symbolic color name for the WIDGET.
- (guarantee-string string 'gtk-widget-parse-color)
- (let ((style (C-> (check-gtk-widget-alien widget) "GtkWidget style"))
- (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|)))
- (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor))
- (zero? (C-call "gdk_color_parse" string gdkcolor)))
- (begin
- (free gdkcolor)
- #f)
- (let ((rgb (vector (/ (C-> gdkcolor "GdkColor red") 65535)
- (/ (C-> gdkcolor "GdkColor green") 65535)
- (/ (C-> gdkcolor "GdkColor blue") 65535))))
- (free gdkcolor)
- rgb))))
+(define (->gtk-widget-state object operator)
+ (case (if (default-object? object) 'normal object)
+ ((NORMAL) (C-enum "GTK_STATE_NORMAL"))
+ ((ACTIVE) (C-enum "GTK_STATE_ACTIVE"))
+ ((PRELIGHT) (C-enum "GTK_STATE_PRELIGHT"))
+ ((SELECTED) (C-enum "GTK_STATE_SELECTED"))
+ ((INSENSITIVE) (C-enum "GTK_STATE_INSENSITIVE"))
+ (else (error:wrong-type-argument object "a GtkWidget state" operator))))
\f
-
-;;;; GtkContainers
+;;; GtkContainers
(define-class <gtk-container> (<gtk-widget>)
+ ;; A list of child gtk-widgets, in the reverse of the order in which
+ ;; they were added.
+ (reverse-children define standard initial-value '()))
- ;; A list of child gtk-widgets.
- (children define standard initial-value '()))
+(define-guarantee gtk-container "a <gtk-container>")
-(define-method gtk-object-destroy ((widget <gtk-container>))
- ;; Calls gtk_object_destroy for WIDGET and all its children.
+(define (gtk-container-children container)
+ (reverse (gtk-container-reverse-children container)))
- (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-bin-child container)
+ (let ((c (gtk-container-reverse-children container)))
+ (if (pair? c) (car c) #f)))
(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)
+ (guarantee-gtk-container parent 'gtk-container-add)
+ (guarantee-gtk-widget child 'gtk-container-add)
+ (container-add! parent child)
+ (C-call "gtk_container_add" (gobject-alien parent) (gobject-alien child)))
+
+(define (gtk-container-remove parent child)
+ (guarantee-gtk-container parent 'gtk-container-remove)
+ (guarantee-gtk-widget child 'gtk-container-remove)
+ (container-remove! parent child)
+ (C-call "gtk_container_remove" (gobject-alien parent) (gobject-alien child)))
(define (gtk-container-set-border-width container width)
- (C-call "gtk_container_set_border_width"
- (gobject-alien (check-gtk-container container))
- width))
-
-(define-integrable (check-gtk-widget-alien object)
- (gobject-alien (check-gtk-widget object)))
-
-(declare (integrate-operator check-gtk-widget))
-(define (check-gtk-widget object)
- (if (gtk-widget? object) object
- (error:wrong-type-argument object "<gtk-widget>" 'check-gtk-widget)))
-
-(declare (integrate-operator check-gtk-container))
-(define (check-gtk-container object)
- (if (gtk-container? object) object
- (error:wrong-type-argument object "<gtk-container>"
- 'check-gtk-container)))
-\f
+ (guarantee-gtk-container container 'gtk-container-set-border-width)
+ (guarantee-positive-fixnum width 'gtk-container-set-border-width)
+ (C-call "gtk_container_set_border_width" (gobject-alien container) width))
+(define (container-add! container child)
+ (without-interrupts
+ (lambda ()
+ (if (gtk-widget-parent child)
+ (error "Already a child:" child))
+ (let ((children (gtk-container-reverse-children container)))
+ (if (memq child children)
+ (error "Already a child:" child container))
+ (set-gtk-container-reverse-children! container (cons child children)))
+ (set-gtk-widget-parent! child container))))
+
+(define (container-remove! container child)
+ (without-interrupts
+ (lambda ()
+ (if (not (eq? container (gtk-widget-parent child)))
+ (error "Not parent:" container child))
+ (let ((children (gtk-container-reverse-children container)))
+ (if (memq child children)
+ (set-gtk-container-reverse-children! container (delq! child children))
+ (error "Not in container:" child container)))
+ (set-gtk-widget-parent! child #f))))
+\f
;;; GtkLabels
-(define-class (<gtk-label> (constructor ())) (<gtk-widget>))
+(define-class (<gtk-label> (constructor () (string))) (<gtk-widget>))
+
+(define-guarantee gtk-label "a <gtk-label>")
+
+(define-method initialize-instance ((label <gtk-label>) string)
+ (call-next-method label)
+ (let ((alien (gobject-alien label)))
+ (C-call "gtk_label_new" alien string)
+ (error-if-null alien "Could not create:" label string)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-object-destroy-callback! label))
(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))
+ (guarantee-string string 'gtk-label-new)
+ (make-gtk-label string))
(define (gtk-label-get-text label)
+ (guarantee-gtk-label label 'gtk-label-get-text)
(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
+ (guarantee-gtk-label label 'gtk-label-set-text)
+ (guarantee-string string 'gtk-label-set-text)
+ (C-call "gtk_label_set_text" (gobject-alien label) string))
+(define (gtk-label-set-width-chars label n-chars)
+ (guarantee-non-negative-fixnum n-chars 'set-label-width!)
+ (C-call "gtk_label_set_width_chars" (gobject-alien label) n-chars))
+\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))
-
-(declare (integrate-operator check-gtk-button))
-(define (check-gtk-button object)
- (if (gtk-button? object) object
- (error:wrong-type-argument object "<gtk-button>" 'check-gtk-button)))
-
-(define (set-gtk-button-clicked-callback! button handler)
- (let ((b (check-gtk-button button)))
- (g-signal-connect
- b (C-callback "clicked")
- (lambda (GtkButton)
- GtkButton ;ignore
- (handler)))))
+(define-class (<gtk-button> (constructor gtk-button-new ())) (<gtk-container>))
+
+(define-guarantee gtk-button "a <gtk-button>")
+
+(define-method initialize-instance ((button <gtk-button>))
+ (call-next-method button)
+ (let ((alien (gobject-alien button)))
+ (C-call "gtk_button_new" alien)
+ (error-if-null alien "Could not create:" button)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-object-destroy-callback! button))
+
+(define (set-gtk-button-clicked-callback! button callback)
+ (guarantee-gtk-button button 'set-gtk-button-clicked-callback!)
+ (guarantee-procedure-of-arity callback 1 'set-gtk-button-clicked-callback!)
+ (g-signal-connect button (C-callback "clicked")
+ (make-clicked-callback callback)))
+
+(define (make-clicked-callback callback)
+ (named-lambda (clicked-callback button)
+ (callback button)))
+
+(define-class (<gtk-check-button> (constructor gtk-check-button-new ()))
+ (<gtk-container>))
+
+(define-guarantee gtk-check-button "a <gtk-check-button>")
+
+(define-method initialize-instance ((button <gtk-check-button>))
+ (call-next-method button)
+ (let ((alien (gobject-alien button)))
+ (C-call "gtk_check_button_new" alien)
+ (error-if-null alien "Could not create:" button)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-object-destroy-callback! button))
+
+(define (gtk-check-button-get-active button)
+ (guarantee-gtk-check-button button 'gtk-check-button-get-active)
+ (not (fix:zero?
+ (C-call "gtk_toggle_button_get_active" (gobject-alien button)))))
+
+(define (gtk-check-button-set-active button active?)
+ (guarantee-gtk-check-button button 'gtk-check-button-set-active)
+ (C-call "gtk_toggle_button_set_active"
+ (gobject-alien button) (if active? 1 0)))
+
+(define (set-gtk-check-button-toggled-callback! button callback)
+ (guarantee-gtk-check-button button 'set-gtk-check-button-toggled-callback!)
+ (guarantee-procedure-of-arity callback 1 'set-gtk-check-button-toggled-callback!)
+ (g-signal-connect button (C-callback "toggled")
+ (make-toggled-callback callback)))
+
+(define (make-toggled-callback callback)
+ (named-lambda (gtk-check-button-toggled-callback button)
+ (callback button)))
\f
-
;;; GtkVBox
-(define-class (<gtk-vbox> (constructor ())) (<gtk-container>))
+(define-class (<gtk-vbox> (constructor () (homogeneous? spacing)))
+ (<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.
+(define-guarantee gtk-vbox "a <gtk-vbox>")
- (let* ((vbox (make-gtk-vbox))
- (alien (gobject-alien vbox)))
+(define-method initialize-instance ((vbox <gtk-vbox>) homogeneous? spacing)
+ (call-next-method vbox)
+ (let ((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))
+ (error-if-null alien "Could not create:" vbox)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-object-destroy-callback! vbox))
+
+(define (gtk-vbox-new homogeneous? spacing)
+ (guarantee-boolean homogeneous? 'gtk-vbox-new)
+ (guarantee-non-negative-fixnum spacing 'gtk-vbox-new)
+ (make-gtk-vbox homogeneous? spacing))
+
+(define-integrable-operator (guarantee-boolean object operator)
+ (if (not (or (eq? object #t) (eq? object #f)))
+ (error:wrong-type-argument object "#t or #f" operator)))
+
+(define-class (<gtk-hbox> (constructor () (homogeneous? spacing)))
+ (<gtk-container>))
+
+(define-guarantee gtk-hbox "a <gtk-hbox>")
+
+(define-method initialize-instance ((hbox <gtk-hbox>) homogeneous? spacing)
+ (call-next-method hbox)
+ (let ((alien (gobject-alien hbox)))
+ (C-call "gtk_hbox_new" alien (if homogeneous? 1 0) spacing)
+ (error-if-null alien "Could not create:" hbox)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-object-destroy-callback! hbox))
+
+(define (gtk-hbox-new homogeneous? spacing)
+ (guarantee-boolean homogeneous? 'gtk-hbox-new)
+ (guarantee-non-negative-fixnum spacing 'gtk-hbox-new)
+ (make-gtk-hbox homogeneous? spacing))
(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)
+ (container-add! box child)
(C-call "gtk_box_pack_start" (gobject-alien box) (gobject-alien child)
- (if expand? 1 0) (if fill? 1 0) padding)
- unspecific)
+ (if expand? 1 0) (if fill? 1 0) padding))
(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)
+ (container-add! box child)
(C-call "gtk_box_pack_end" (gobject-alien box) (gobject-alien child)
- (if expand? 1 0) (if fill? 1 0) padding)
- unspecific)
-\f
+ (if expand? 1 0) (if fill? 1 0) padding))
-;;;; GtkScrolledWindows
+(define-class (<gtk-frame> (constructor () (label))) (<gtk-container>))
-(define-class (<gtk-scrolled-window>
- (constructor make-gtk-scrolled-window ()))
+(define-guarantee gtk-frame "a <gtk-frame>")
+
+(define-method initialize-instance ((frame <gtk-frame>) label)
+ (call-next-method frame)
+ (let ((alien (gobject-alien frame)))
+ (C-call "gtk_frame_new" alien label)
+ (error-if-null alien "Could not create:" frame)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-object-destroy-callback! frame))
+
+(define (gtk-frame-new label)
+ (guarantee-string label 'gtk-frame-new)
+ (make-gtk-frame label))
+
+(define (gtk-frame-set-shadow-type frame type)
+ (let ((t (->gtk-shadow-type type 'gtk-frame-set-shadow-type)))
+ (C-call "gtk_frame_set_shadow_type" (gobject-alien frame) t)))
+
+(define (->gtk-shadow-type object operator)
+ (case object
+ ((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
+ (error:wrong-type-argument object "a GtkShadowType symbol" operator))))
+\f
+;;; GtkScrolledWindows
+
+(define-class (<gtk-scrolled-window> (constructor ()))
(<gtk-container>))
+(define-guarantee gtk-scrolled-window "a <gtk-scrolled-window>")
+
(define (gtk-scrolled-window-new)
(let* ((window (make-gtk-scrolled-window))
(alien (gobject-alien window)))
- (C-call "gtk_scrolled_window_new" alien null-alien null-alien)
- (if (alien-null? alien) (ferror "Could not create GtkScrolledWindow."))
+ (C-call "gtk_scrolled_window_new" alien 0 0)
+ (error-if-null alien "Could not create:" window)
+ (C-call "g_object_ref_sink" alien alien)
+ (set-gtk-object-destroy-callback! window)
window))
(define (gtk-scrolled-window-set-policy window horizontal vertical)
- (let ((w (check-scrolled-window window))
- (h (check-scrollbar-policy horizontal))
- (v (check-scrollbar-policy vertical)))
- (C-call "gtk_scrolled_window_set_policy" (gobject-alien w) h v)))
+ (guarantee-gtk-scrolled-window window 'gtk-scrolled-window-set-policy)
+ (C-call "gtk_scrolled_window_set_policy" (gobject-alien window)
+ (->policy horizontal 'gtk-scrolled-window-set-policy)
+ (->policy vertical 'gtk-scrolled-window-set-policy)))
(define (gtk-scrolled-window-set-placement window placement)
- (let ((w (check-scrolled-window window))
- (p (check-scrolled-window-placement placement)))
- (C-call "gtk_scrolled_window_set_placement" (gobject-alien w) p)))
-
-(declare (integrate-operator check-scrolled-window))
-(define (check-scrolled-window object)
- (if (gtk-scrolled-window? object) object
- (error:wrong-type-argument object "<gtk-scrolled-window>"
- 'check-scrolled-window)))
-
-(declare (integrate-operator check-scrollbar-policy))
-(define (check-scrollbar-policy object)
+ (guarantee-gtk-scrolled-window window 'gtk-scrolled-window-set-placement)
+ (C-call "gtk_scrolled_window_set_placement" (gobject-alien window)
+ (->placement placement 'gtk-scrolled-window-set-placement)))
+
+(define (->policy object operator)
(case object
((ALWAYS) (C-enum "GTK_POLICY_ALWAYS"))
((AUTO) (C-enum "GTK_POLICY_AUTOMATIC"))
((NEVER) (C-enum "GTK_POLICY_NEVER"))
- (else (error:wrong-type-argument object "symbol: ALWAYS, AUTO or NEVER"
- 'check-scrollbar-policy))))
+ (else (error:wrong-type-argument
+ object "a symbol -- one of ALWAYS, AUTO or NEVER" operator))))
-(declare (integrate-operator check-scrolled-window-placement))
-(define (check-scrolled-window-placement object)
+(define (->placement object operator)
(case object
((TOP-LEFT) (C-enum "GTK_CORNER_TOP_LEFT"))
((BOTTOM-LEFT) (C-enum "GTK_CORNER_BOTTOM_LEFT"))
((TOP-RIGHT) (C-enum "GTK_CORNER_TOP_RIGHT"))
((BOTTOM-RIGHT) (C-enum "GTK_CORNER_BOTTOM_RIGHT"))
(else (error:wrong-type-argument
- object "symbol: TOP-LEFT, BOTTOM-LEFT, TOP-RIGHT or BOTTOM-RIGHT"
- 'check-scrolled-window-placement))))
+ object
+ "a symbol -- one of TOP-LEFT, BOTTOM-LEFT, TOP-RIGHT or BOTTOM-RIGHT"
+ operator))))
\f
+;;; GtkWindows
-;;;; GtkWindows
-
-(define-class (<gtk-window> (constructor make-gtk-window (type)))
+(define-class (<gtk-window> (constructor gtk-window-new () (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-guarantee gtk-window "a <gtk-window>")
+
+(define-method initialize-instance ((window <gtk-window>) type)
+ (call-next-method window)
+ (let ((type (->window-type type 'gtk-window-new))
+ (alien (gobject-alien window)))
+ (C-call "gtk_window_new" alien type)
+ (error-if-null alien "Could not create:" window type)
+ (C-call "g_object_ref_sink" alien alien)
+ (set-gtk-object-destroy-callback! window)
+ (set! toplevel-windows (cons window toplevel-windows))))
-(declare (integrate-operator check-window-type))
-(define (check-window-type type)
+(define toplevel-windows '())
+
+(define-method gtk-object-destroy-callback ((window <gtk-window>))
+ (call-next-method window)
+ (set! toplevel-windows (delq! window toplevel-windows)))
+
+(define (->window-type type operator)
(case type
- ((TOPLEVEL POPUP) type)
+ ((TOPLEVEL) (C-enum "GTK_WINDOW_TOPLEVEL"))
+ ((POPUP) (C-enum "GTK_WINDOW_POPUP"))
(else
- (error:wrong-type-argument type "symbol: TOPLEVEL or POPUP"
- 'check-window-type))))
-
-(declare (integrate-operator check-gtk-window))
-(define (check-gtk-window object)
- (if (gtk-window? object) object
- (error:wrong-type-argument object "<gtk-window>" 'check-gtk-window)))
+ (error:wrong-type-argument
+ type "a symbol -- one of TOPLEVEL or POPUP" operator))))
(define (gtk-window-set-title window title)
+ (guarantee-gtk-window window 'gtk-window-set-title)
(guarantee-string title 'gtk-window-set-title)
- (let ((alien (gobject-alien (check-gtk-window window))))
- (C-call "gtk_window_set_title" alien title)))
+ (C-call "gtk_window_set_title" (gobject-alien window) title))
+
+(define (gtk-window-set-opacity window opacity)
+ (guarantee-gtk-window window 'gtk-window-set-opacity)
+ (guarantee-real opacity 'gtk-window-set-opacity)
+ (if (not (<= 0. opacity 1.))
+ (error:bad-range-argument opacity 'gtk-window-set-opacity))
+ (C-call "gtk_window_set_opacity" (gobject-alien window) opacity))
(define (gtk-window-get-default-size window receiver)
- ;; Calls RECEIVER with WINDOW's default width and height.
+ (guarantee-gtk-window window 'gtk-window-get-default-size)
(let* ((*width (malloc (fix:* 2 (C-sizeof "gint")) 'gint))
(*height (alien-byte-increment *width (C-sizeof "gint") 'gint)))
(C-call "gtk_window_get_default_size"
(receiver width height))))
(define (gtk-window-set-default-size window width height)
+ (guarantee-gtk-window window 'gtk-window-set-default-size)
(guarantee-integer width 'gtk-window-set-default-size)
(guarantee-integer height 'gtk-window-set-default-size)
- (let ((alien (gobject-alien (check-gtk-window window))))
- (C-call "gtk_window_set_default_size" alien width height)))
+ (C-call "gtk_window_set_default_size" (gobject-alien window) width height))
+
+(define (gtk-window-set-geometry-hints window widget . hints)
+ (let ((geometry (malloc (C-sizeof "GdkGeometry")))
+ (mask 0))
+
+ (define-integrable-operator (get-fixnum name)
+ (let ((entry (assq name hints)))
+ (and entry
+ (let ((v (cdr entry)))
+ (cond ((not (fixnum? v)) (error "Not a fixnum:" v name 'gtk-window-set-geometry-hints))
+ ((fix:< v -1) (error "Negative:" v name 'gtk-window-set-geometry-hints))
+ (else v))))))
+
+ (define-integrable-operator (get-real name)
+ (let ((entry (assq name hints)))
+ (and entry
+ (let ((v (cdr entry)))
+ (if (not (real? v))
+ (error "Not real:" v name 'gtk-window-set-geometry-hints)
+ v)))))
+
+ (define-integrable (get-gravity)
+ (let ((entry (assq 'gravity hints)))
+ (and entry
+ (case (cdr entry)
+ ((north) (C-enum "GDK_GRAVITY_NORTH"))
+ ((northeast) (C-enum "GDK_GRAVITY_NORTH_EAST"))
+ ((east) (C-enum "GDK_GRAVITY_EAST"))
+ ((southeast) (C-enum "GDK_GRAVITY_SOUTH_EAST"))
+ ((south) (C-enum "GDK_GRAVITY_SOUTH"))
+ ((southwest) (C-enum "GDK_GRAVITY_SOUTH_WEST"))
+ ((west) (C-enum "GDK_GRAVITY_WEST"))
+ ((northwest) (C-enum "GDK_GRAVITY_NORTH_WEST"))
+ ((center) (C-enum "GDK_GRAVITY_CENTER"))
+ ((static) (C-enum "GDK_GRAVITY_STATIC"))
+ (else (error "Not a gravity:" (cdr entry) 'gtk-window-set-geometry-hints))))))
+
+ (let ((width (get-fixnum 'min-width))
+ (height (get-fixnum 'min-height)))
+ (cond ((and width height)
+ (C->= geometry "GdkGeometry min_width" width)
+ (C->= geometry "GdkGeometry min_height" height)
+ (set! mask (fix:+ mask (C-enum "GDK_HINT_MIN_SIZE"))))
+ ((and (not width) (not height)))
+ (else (error "Both min-width and min-height are required:" hints))))
+
+ (let ((width (get-fixnum 'max-width))
+ (height (get-fixnum 'max-height)))
+ (cond ((and width height)
+ (C->= geometry "GdkGeometry max_width" width)
+ (C->= geometry "GdkGeometry max_height" height)
+ (set! mask (fix:+ mask (C-enum "GDK_HINT_MAX_SIZE"))))
+ ((and (not width) (not height)))
+ (else (error "Both max-width and max-height are required:" hints))))
+
+ (let ((width (get-fixnum 'base-width))
+ (height (get-fixnum 'base-height)))
+ (cond ((and width height)
+ (C->= geometry "GdkGeometry base_width" width)
+ (C->= geometry "GdkGeometry base_height" height)
+ (set! mask (fix:+ mask (C-enum "GDK_HINT_BASE_SIZE"))))
+ ((and (not width) (not height)))
+ (else (error "Both base-width and base-height are required:" hints))))
+
+ (let ((width (get-fixnum 'width-increment))
+ (height (get-fixnum 'height-increment)))
+ (cond ((and width height)
+ (C->= geometry "GdkGeometry width_inc" width)
+ (C->= geometry "GdkGeometry height_inc" height)
+ (set! mask (fix:+ mask (C-enum "GDK_HINT_RESIZE_INC"))))
+ ((and (not width) (not height)))
+ (else (error "Both width-increment and height-increment are required:" hints))))
+
+ (let ((min (get-real 'min-aspect))
+ (max (get-real 'max-aspect)))
+ (cond ((and min max)
+ (C->= geometry "GdkGeometry min_aspect" min)
+ (C->= geometry "GdkGeometry max_aspect" max)
+ (set! mask (fix:+ mask (C-enum "GDK_HINT_ASPECT"))))
+ ((and (not min) (not max)))
+ (else (error "Both min-aspect and max-aspect must be specified:" hints))))
+
+ (let ((gravity (get-gravity)))
+ (if gravity
+ (begin
+ (C->= geometry "GdkGeometry win_gravity" gravity)
+ (set! mask (fix:+ mask (C-enum "GDK_HINT_WIN_GRAVITY"))))))
+
+ (C-call "gtk_window_set_geometry_hints"
+ (gobject-alien window)
+ (gobject-alien widget)
+ geometry mask)
+ (free geometry)))
(define (gtk-window-parse-geometry window geometry)
+ (guarantee-gtk-window window 'gtk-window-parse-geometry)
(guarantee-string geometry 'gtk-window-parse-geometry)
- (let ((alien (gobject-alien (check-gtk-window window))))
- (if (fix:zero? (C-call "gtk_window_parse_geometry" alien geometry))
- (ferror "Could not parse geometry string: "geometry))))
+ (if (fix:zero? (C-call "gtk_window_parse_geometry"
+ (gobject-alien window) geometry))
+ (error "Could not parse geometry string:" geometry)))
(define (gtk-window-resize window width height)
- (guarantee-integer width 'gtk-window-resize)
- (guarantee-integer height 'gtk-window-resize)
- (let ((alien (gobject-alien (check-gtk-window window))))
- (C-call "gtk_window_resize" alien width height)))
+ (guarantee-gtk-window window 'gtk-window-resize)
+ (guarantee-positive-fixnum width 'gtk-window-resize)
+ (guarantee-positive-fixnum height 'gtk-window-resize)
+ (C-call "gtk_window_resize" (gobject-alien window) width height))
(define (gtk-window-present window)
- (let ((alien (gobject-alien (check-gtk-window window))))
- (C-call "gtk_window_present" alien)))
-
-(define (set-gtk-window-delete-event-callback! window handler)
- (let ((w (check-gtk-window window)))
- (g-signal-connect
- w (C-callback "delete_event")
- (lambda (GtkWidget GdkEvent)
- GtkWidget GdkEvent ;ignore
- (handler)))))
+ (guarantee-gtk-window window 'gtk-window-present)
+ (C-call "gtk_window_present" (gobject-alien window)))
+
+(define (set-gtk-window-delete-event-callback! window callback)
+ (guarantee-gtk-window window 'set-gtk-window-delete-event-callback!)
+ (guarantee-procedure-of-arity callback 1 'set-gtk-window-delete-event-callback!)
+ (g-signal-connect window (C-callback "delete_event")
+ (make-delete-event-callback callback)))
+
+(define (make-delete-event-callback callback)
+ (named-lambda (delete-event-callback window GdkEvent)
+ (declare (ignore GdkEvent))
+ (callback window)))
(define trace? #f)
struct _ScmWidgetClass
{
GtkWidgetClass parent_class;
- void (*set_scroll_adjustments) (GtkWidget *widget,
- GtkAdjustment *hadjustment,
- GtkAdjustment *vadjustment);
/* Padding for future expansion */
void (*_gtk_reserved1) (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);
(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)))
+ (widget GtkWidget)))
(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.
(object (* GtkObject))
(ID gpointer))
+(callback void size_allocate
+ (widget (* GtkWidget))
+ (allocation (* GtkAllocation))
+ (ID gpointer))
+
+(callback void realize
+ (widget (* GtkWidget))
+ (ID gpointer))
+
+(callback void unrealize
+ (widget (* GtkWidget))
+ (ID gpointer))
+
+(callback gint event
+ (widget (* GtkWidget))
+ (event (* GdkEvent))
+ (ID gpointer))
+
+(callback void set_scroll_adjustments
+ (widget (* GtkWidget))
+ (hadj (* GtkAdjustment))
+ (vadj (* GtkAdjustment))
+ (ID gpointer))
+
(callback gboolean delete_event
(window (* GtkWidget))
(event (* GdkEventAny))
(widget (* GtkWidget))
(ID gpointer))
+(callback void toggled
+ (togglebutton (* GtkToggleButton))
+ (ID gpointer))
+
(callback void value_changed
(adjustment (* GtkAdjustment))
(ID gpointer))
(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_remove
+ (container (* GtkContainer))
+ (widget (* GtkWidget)))
+
(extern void ;gtk+-2.4.0/gtk/gtkcontainer.h
gtk_container_set_border_width
(container (* GtkContainer))
(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 (* (const gchar)) ;gtk+-2.4.0/gtk/gtklabel.h
- gtk_label_get_text
- (label (* GtkLabel)))
+(extern (* GtkWidget) ;gtk+-2.20.1/gtk/gtkcheckbutton.h
+ gtk_check_button_new)
-(extern void gtk_label_set_text ;gtk+-2.4.0/gtk/gtklabel.h
- (label (* GtkLabel))
- (str (* (const char))))
+(extern void ;gtk+-2.20.1/gtk/gtktogglebutton.h
+ gtk_toggle_button_set_active
+ (toggle_button (* GtkToggleButton))
+ (is_active gboolean))
-(extern void gdk_rgb_find_color ;gtk+-2.8.20/gdk/gdkrgb.h
- (colormap (* GdkColormap))
- (color (* GdkColor)))
+(extern gboolean ;gtk+-2.20.1/gtk/gtktogglebutton.h
+ gtk_toggle_button_get_active
+ (toggle_button (* GtkToggleButton)))
(extern (* GtkWidget) ;gtk+-2.8.20/gtk/gtkscrolledwindow.h
gtk_scrolled_window_new
(hadjustment (* GtkAdjustment))
(vadjustment (* GtkAdjustment)))
-(extern void
+(extern void ;gtk+-2.8.20/gtk/gtkscrolledwindow.h
gtk_scrolled_window_set_policy
(scrolled_window (* GtkScrolledWindow))
(hscrollbar_policy GtkPolicyType)
(vscrollbar_policy GtkPolicyType))
-(extern void
+(extern void ;gtk+-2.8.20/gtk/gtkscrolledwindow.h
gtk_scrolled_window_set_placement
(scrolled_window (* GtkScrolledWindow))
(window_placement GtkCornerType))
\ No newline at end of file
(files "gobject")
(export (gtk)
<gobject> gobject-alien
- gobject-unref gobject-finalized?
+ gobject-live? gobject-unref!
g-signal-connect g-signal-disconnect
add-gc-cleanup punt-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> make-pixbuf-loader
+ load-pixbuf-from-port load-pixbuf-from-file
pixbuf-loader-size-hook set-pixbuf-loader-size-hook!
pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook!
pixbuf-loader-update-hook set-pixbuf-loader-update-hook!
pixbuf-loader-close-hook set-pixbuf-loader-close-hook!
- pixbuf-loader-pixbuf pixbuf-loader-error-message)
- (initialization (initialize-package!)))
+ pixbuf-loader-pixbuf pixbuf-loader-error-message
+ <pixbuf>
+ gdk-window-process-updates))
+
+(define-package (gtk pango)
+ (parent (gtk))
+ (files "pango")
+ (export (gtk)
+ <pango-layout>
+ pango-layout-get-context
+ pango-layout-context-changed
+ pango-layout-get-font-description
+ pango-layout-set-font-description
+ pango-layout-set-text
+ pango-layout-get-pixel-extents
+ pango-layout-index-to-pos
+ pango-font-description-from-string
+ pango-font-description-to-string
+ pango-font-description-free
+ pango-context-get-font-description
+ pango-context-set-font-description
+ pango-context-get-metrics
+ pango-context-spacing
+ pango-font-metrics-get-ascent
+ pango-font-metrics-get-descent
+ pango-font-metrics-get-approximate-char-width
+ pango-font-metrics-unref))
(define-package (gtk 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-object> gtk-object? guarantee-gtk-object
+ gtk-object-destroyed? gtk-object-destroy
+ <gtk-adjustment> gtk-adjustment? guarantee-gtk-adjustment
+ make-gtk-adjustment set-gtk-adjustment!
+ <gtk-widget> gtk-widget? guarantee-gtk-widget
+ gtk-widget-parent
+ gtk-widget-realized?
gtk-widget-drawable? gtk-widget-has-focus?
gtk-widget-grab-focus
+ gtk-widget-show
gtk-widget-show-all
gtk-widget-error-bell
gtk-widget-queue-draw
+ gtk-widget-get-colormap
gtk-widget-get-pango-context
gtk-widget-create-pango-layout
gtk-widget-set-size-request
+ ;;gtk-widget-set-can-focus
+ set-gtk-widget-size-allocate-callback!
+ set-gtk-widget-realize-callback!
+ set-gtk-widget-unrealize-callback!
+ set-gtk-widget-event-callback!
gtk-widget-font set-gtk-widget-font!
gtk-widget-fg-color gtk-widget-bg-color
set-gtk-widget-text-color! set-gtk-widget-base-color!
gtk-widget-parse-color
- <gtk-container> gtk-container?
- gtk-container-children gtk-container-add
+ <gtk-container> gtk-container? guarantee-gtk-container
+ gtk-container-children gtk-bin-child
+ gtk-container-add gtk-container-remove
gtk-container-set-border-width
- <gtk-window> gtk-window-type
- gtk-window-new gtk-window-set-title
+ ;;gtk-container-set-resize-mode
+ ;;gtk-container-check-resize
+
+ <gtk-window> gtk-window? guarantee-gtk-window
+ gtk-window-new gtk-window-set-title gtk-window-type
+ gtk-window-set-opacity
gtk-window-set-default-size gtk-window-get-default-size
gtk-window-parse-geometry
gtk-window-resize
gtk-window-present
set-gtk-window-delete-event-callback!
- <gtk-button> gtk-button-new
- set-gtk-button-clicked-callback!
- <gtk-label> gtk-label-new
+ <gtk-label> gtk-label? guarantee-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
+ gtk-label-set-width-chars
+ <gtk-button> gtk-button? guarantee-gtk-button
+ gtk-button-new
+ set-gtk-button-clicked-callback!
+ <gtk-check-button> gtk-check-button? guarantee-gtk-check-button
+ gtk-check-button-new
+ gtk-check-button-get-active gtk-check-button-set-active
+ set-gtk-check-button-toggled-callback!
+ <gtk-vbox> gtk-vbox? guarantee-gtk-vbox gtk-vbox-new
+ <gtk-hbox> gtk-hbox? guarantee-gtk-hbox gtk-hbox-new
+ gtk-box-pack-start gtk-box-pack-end
+ <gtk-frame> gtk-frame? guarantee-gtk-frame gtk-frame-new
+ gtk-frame-set-shadow-type
+ <gtk-scrolled-window> gtk-scrolled-window?
+ guarantee-gtk-scrolled-window gtk-scrolled-window-new
gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement)
- (import (gtk gobject) gobject-cleanup gobject-signals)
- (import (gtk pango) make-pango-layout check-PangoFontDescription))
+ (import (gtk pango) make-pango-layout guarantee-pango-font-description))
(define-package (gtk widget)
(parent (gtk))
(files "scm-widget")
+ (import (gtk gtk-object)
+ set-gtk-object-destroy-callback!)
(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!))
+ set-scm-widget-set-scroll-adjustments-callback!))
-(define-package (gtk layout)
+(define-package (gtk fix-layout)
(parent (gtk))
- (files "scm-layout")
+ (files "fix-layout")
+ (import (gtk pango)
+ make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
+ (import (gtk gtk-object)
+ parse-gdkcolor set-gtk-object-destroy-callback!)
(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!
- scm-layout-scroll-step set-scm-layout-scroll-step!
+ <fix-layout> fix-layout? make-fix-layout set-fix-layout-size!
+ fix-layout-drawing set-fix-layout-drawing!
+ fix-layout-scroll-step set-fix-layout-scroll-step!
+ fix-layout-view fix-layout-scroll-to! fix-layout-scroll-nw!
+ fix-layout-new-geometry-callback fix-layout-realize-callback
+ set-fix-layout-map-handler!
+ set-fix-layout-unmap-handler!
+ set-fix-layout-focus-change-handler!
+ set-fix-layout-visibility-notify-handler!
+ set-fix-layout-key-press-handler!
+ set-fix-layout-motion-handler!
+ set-fix-layout-button-handler!
- set-scm-layout-map-handler!
- set-scm-layout-unmap-handler!
- set-scm-layout-focus-change-handler!
- set-scm-layout-visibility-notify-handler!
- set-scm-layout-key-press-handler!
- set-scm-layout-motion-handler!
- set-scm-layout-button-release-handler!
+ <fix-drawing> make-fix-drawing fix-drawing-widgets
+ set-fix-drawing-size! fix-drawing-pick-list
+ fix-drawing-add-ink!
- <drawing> make-drawing drawing-widgets
- set-drawing-size! drawing-pick-list
+ <fix-ink> fix-ink?
+ fix-ink-drawing
+ fix-ink-widgets set-fix-ink-widgets!
+ fix-ink-move! fix-ink-remove!
+ <draw-ink>
- <drawn-item>
- drawn-item-drawing drawn-item-area set-drawn-item-position!
- drawn-item-widgets set-drawn-item-widgets!
- drawn-item-remove!
+ <line-ink> line-ink? make-line-ink set-line-ink!
+ line-ink-width set-line-ink-width!
+ line-ink-color set-line-ink-color!
+ line-ink-dash-color set-line-ink-dash-color!
- <box-item> add-box-item set-box-item-size!
- set-box-item-pos-size! set-box-item-shadow!
+ <rectangle-ink> rectangle-ink? make-rectangle-ink set-rectangle-ink!
+ rectangle-ink-color set-rectangle-ink-color!
+ rectangle-ink-width set-rectangle-ink-width!
+ rectangle-ink-fill-color set-rectangle-ink-fill-color!
- <hline-item> add-hline-item set-hline-item-size!
- <vline-item> add-vline-item set-vline-item-size!
+ <arc-ink> arc-ink? make-arc-ink set-arc-ink!
+ arc-ink-start-angle set-arc-ink-start-angle!
+ arc-ink-sweep-angle set-arc-ink-sweep-angle!
+ arc-ink-color set-arc-ink-color!
+ arc-ink-width set-arc-ink-width!
+ arc-ink-fill-color set-arc-ink-fill-color!
- <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
+ <text-ink> text-ink?
+ set-text-ink-position!
+ text-ink-xy-to-index
+ with-text-ink-grapheme-rect
+ text-ink-color set-text-ink-color!
- <image-item> add-image-item-from-file))
+ <simple-text-ink> simple-text-ink? make-simple-text-ink
+ simple-text-ink-text set-simple-text-ink-text!
+ simple-text-ink-font set-simple-text-ink-font!
-(define-package (gtk pango)
- (parent (gtk))
- (files "pango")
- (export (gtk)
- <pango-layout>
- pango-layout-get-context
- pango-layout-get-font-description
- pango-layout-set-text
- pango-layout-get-pixel-extents
- pango-layout-index-to-pos
- pango-font-description-from-string
- pango-font-description-to-string
- pango-font-description-free
- pango-context-get-font-description
- pango-context-set-font-description
- pango-context-get-metrics
- pango-context-spacing
- pango-font-metrics-get-ascent
- pango-font-metrics-get-descent
- pango-font-metrics-get-approximate-char-width
- pango-font-metrics-unref
- pango-rectangle
- pangos->pixels
- pixels->pangos))
+ <image-ink> make-image-ink-from-file set-image-ink!
+
+ <box-ink> box-ink? make-box-ink
+ set-box-ink! set-box-ink-position!
+ box-ink-shadow set-box-ink-shadow!
+
+ ;;<hline-ink> make-hline-ink set-hline-ink-size!
+ ;;<vline-ink> make-vline-ink set-vline-ink-size!
+ ))
(define-package (gtk keys)
(parent (gtk))
(parent (runtime thread))
(files "thread")
(export (gtk)
- create-gtk-thread
kill-gtk-thread)
(import (gtk gobject)
run-gc-cleanups)
default/process-command-line)
(import (runtime)
ucode-primitive)
+ (import (gtk thread)
+ create-gtk-thread)
(export (gtk)
gtk-time-slice-window?
gtk-time-slice-window!
gtk-select-trace?
- gtk-select-trace!)
- (initialization (initialize-package!)))
+ gtk-select-trace!))
(define-package (gtk event-viewer)
(parent (gtk))
(files "gtk-ev")
+ (import (gtk fix-layout)
+ gdk-rectangle gdk-rectangle-from-rect
+ make-fix-rect
+ fix-rect-x fix-rect-y fix-rect-width fix-rect-height
+ fix-rect-max-y set-fix-rect! fix-rect-union!)
+ (import (gtk pango)
+ pango-rectangle pangos->pixels)
(export ()
- gtk-event-viewer))
+ make-gtk-event-viewer-demo))
-(define-package (gtk demo)
+(define-package (gtk fix-layout demo)
+ (parent (gtk fix-layout))
+ (files "fix-demo")
+ (import (gtk fix-layout)
+ fix-layout-view)
+ (export ()
+ make-fix-layout-demo))
+
+(define-package (gtk swat)
(parent (gtk))
- (files "demo")
+ (files "swat")
+ (import (gtk gtk-object)
+ gtk-object-destroy-callback)
+ (import (gtk fix-layout)
+ fix-layout-view fix-ink-extent fix-ink-expose-callback
+ fix-drawing-display-list set-fix-drawing-display-list!
+ set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in?
+ fix-rect-x fix-rect-y with-fix-rect
+ set-fix-rect-size! fix-rect-move! copy-fix-rect!
+ point-in-fix-rect? fix-rect-union!)
+ (export (swat)
+ add-child! remove-child! ask-widget
+ add-event-handler! set-callback!
+ after-delay on-death!
+ swat-open swat-close
+ make-active-variable set-active-variable!
+ make-hbox make-vbox box-children
+ make-button make-label
+ make-checkbutton checkbutton-variable-on?
+ make-canvas make-canvas-item-group
+ make-line-on-canvas make-rectangle-on-canvas
+ make-oval-on-canvas make-text-on-canvas))
+
+(define-package (swat)
+ (parent ()))
+
+#;(define-package (swat examples)
+ (parent (swat))
+ (files "swat-examples"))
+
+(define-package (swat pole-zero)
+ (parent (swat))
+ (files "swat-pole-zero")
+ (export ()
+ make-pole-zero))
+
+#;(define-package (swat plotter)
+ (parent (swat))
+ (files "swat-plotter")
(export ()
- scm-layout-demo))
\ No newline at end of file
+ plotter
+ plot
+ set-plotter-params
+ reset-plotter-params
+ make-vals
+ change-color
+ change-pt-style
+ change-num-pts
+ clear-curve
+ plot-curve
+ delete-curve
+ add-show-vals
+ clear-show-vals
+ draw-show-vals
+ delete-show-vals
+ add-xticks
+ add-yticks
+ clear-ticks
+ draw-ticks
+ delete-ticks
+ clear-plotter
+ replot
+ reset-plotter))
\ No newline at end of file
|#
;;;; Core utilities.
-;;; package: (gtk)
-
-
-(c-include "gtk")
+;;; package: (gtk utilities)
+
+(define-syntax define-integrable-operator
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (declare (ignore compare))
+ (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
+ (let ((r-begin (rename 'BEGIN))
+ (r-declare (rename 'DECLARE))
+ (r-define (rename 'DEFINE)))
+ `(,r-begin
+ (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
+ (,r-define ,@(cdr form)))))
+ (else
+ (ill-formed-syntax form))))))
+
+(define-syntax if-debugging
+ (er-macro-transformer
+ (lambda (form rename compare)
+ (declare (ignore compare))
+ (let ((r-begin (rename 'BEGIN)))
+ (if debugging?
+ `(,r-begin ,@(cdr form))
+ `(,r-begin))))))
+
+;; Setting this affects only newly-compiled code.
+(define debugging? #f)
+
+(define-syntax error-if-null
+ (syntax-rules ()
+ ((_ ALIEN . MESSAGE)
+ (if (alien-null? ALIEN)
+ ((lambda () (apply error . MESSAGE)))))))
+
+(define-integrable-operator (fix:max n m) (if (fix:> n m) n m))
+
+(define-integrable-operator (fix:min n m) (if (fix:< n m) n m))
+
+(define-integrable-operator (fix:negate i) (fix:- 0 i))
+
+(define-integrable-operator (fix:abs n)
+ (if (fix:negative? n) (fix:negate n) n))
+
+(define (bit-mask . ints)
+ ;; For bit field masks. INTS is assumed to be a list of powers
+ ;; of two, no repeats.
+ (fold-left int:+ 0 ints))
+
+(define-integrable (bit-mask-indices num)
+ ;; The indices of the bits set in NUM.
+ (let ((str (unsigned-integer->bit-string 32 num)))
+ (let loop ((start 0))
+ (let ((next (bit-substring-find-next-set-bit str start 32)))
+ (if next
+ (cons next (loop (fix:1+ next)))
+ '())))))
+
+(define-integrable (bit? int mask)
+ ;; This seems... inefficient.
+ (not (int:zero? (bit-and int mask))))
(define (bit-and . numbers)
(bit-string->unsigned-integer
(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 ((int:< window-x-end item-x-start) #f)
- ((int:< window-y-end item-y-start) #f)
- ((int:< item-x-end window-x-start) #f)
- ((int:< 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 (rect-union! rect1 rect2)
- (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)
- (let ((x (int:min min-x1 min-x2))
- (y (int:min min-y1 min-y2)))
- (set-rect! rect1
- x y
- (int:- x (int:max max-x1 max-x2))
- (int:- y (int:max max-y1 max-y2)))))))))
-
-(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
-;;;
-;;; Debugging hacks. No gc-cleanups!
-
-(define (pango-font-families widget)
- (pango-context-list-families (gtk-widget-get-pango-context widget)))
-
-(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
+ numbers)))
\ No newline at end of file
-#| -*-Scheme-*-
-
-Copyright (C) 2007, 2008, 2009, 2010 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.
-
-|#
+#| -*-Scheme-*- |#
;;;; Syntax the GTK system
(load-option 'SOS)
(load-option 'FFI))
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
- (lambda ()
- (let* ((files.packages
- '(("gtk" . (gtk))
- ("keys" . (gtk keys))
- ("main" . (gtk main))
- ("gobject" . (gtk gobject))
- ("gtk-object" . (gtk gtk-object))
- ("pango" . (gtk pango))
- ("scm-widget" . (gtk widget))
- ("scm-layout" . (gtk layout))
- ("thread" . (gtk thread))
- ("gtk-ev" . (gtk event-viewer))
- ("demo" . (gtk demo))))
- (sf+
- (lambda (files deps)
- (let loop ((files (if (pair? files) files (list files))))
- (if (pair? files)
- (let* ((file (car files))
- (file.package (assoc file files.packages))
- (package (if (pair? file.package)
- (cdr file.package)
- (error "No package: " file)))
- (env (->environment package)))
- (fluid-let ((sf/default-declarations
- (cons '(usual-integrations)
- sf/default-declarations)))
- (sf-with-dependencies file deps env))
- (loop (cdr files)))))))
- (sfx+
- (lambda (files deps)
- (fluid-let ((sf/default-declarations
- (append!
- (map (lambda (file)
- `(integrate-external
- ,(pathname-new-type file #f)))
- deps)
- sf/default-declarations)))
- (sf+ files deps)))))
-
- ;; 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)
-
- ;; These core files depend only on the constants behind the C-
- ;; syntax.
- (sf+ '("gtk" "keys" "main" "gobject" "gtk-object" "pango" "scm-widget")
- '("gtk-const"))
-
- ;; These files will want the latest rect(angle) and
- ;; pango/pixel procedures for inlining.
- (sfx+ '("scm-layout" "thread" "gtk-ev" "demo")
- '("gtk" "pango"))
+;; Load the gtkio primitives too, so SF can check their arity(?).
+(load-library-object-file "prgtkio" #t)
- ;; Depends only on (runtime thread).
- (sf+ '("thread") '())
+(sf-package-set "gtk-new")
- ;; Cross-check.
- (cref/generate-constructors "gtk" 'ALL))))
\ No newline at end of file
+(cref/generate-constructors "gtk" 'ALL)
\ No newline at end of file
(let ((counter 0))
(set-gtk-window-delete-event-callback!
window
- (lambda ()
+ (lambda (window)
(outf-console ";Bite me "(- 2 counter)" times.\n")
(set! counter (1+ counter))
;; Three or more is the charm.
(if (> counter 2) 0 1)))
(set-gtk-button-clicked-callback!
button
- (lambda ()
+ (lambda (button)
(let ((text (gtk-label-get-text label)))
(gtk-label-set-text
label (list->string (reverse! (string->list text)))))
(c-include "gtk")
(define (gdk-key-state->char-bits modifier-state)
- ;; Given a Gdk modifier-state, returns a bitmap (sum) of
- ;; char-bit:control, :meta, :super, :hyper.
(fix:+
- (if (zero? (bit-and (C-enum "GDK_CONTROL_MASK") modifier-state))
- 0 char-bit:control)
+ (if (bit? modifier-state (C-enum "GDK_CONTROL_MASK")) char-bit:control 0)
(fix:+
- (if (zero? (bit-and (C-enum "GDK_META_MASK") modifier-state))
- 0 char-bit:meta)
+ (if (bit? modifier-state (C-enum "GDK_META_MASK")) char-bit:meta 0)
(fix:+
- (if (zero? (bit-and (C-enum "GDK_SUPER_MASK") modifier-state))
- 0 char-bit:super)
- (if (zero? (bit-and (C-enum "GDK_HYPER_MASK") modifier-state))
- 0 char-bit:hyper)))))
+ (if (bit? modifier-state (C-enum "GDK_SUPER_MASK")) char-bit:super 0)
+ (if (bit? modifier-state (C-enum "GDK_HYPER_MASK")) char-bit:hyper 0)))))
(define (gdk-keyval->name keyval)
(let ((entry
;;;; Main Loop Hack
;;; package: (gtk main)
-
(c-include "gtk")
(define (initialize-package!)
(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
+(define gtk-select-trace! (ucode-primitive gtk-select-trace! 1))
+
+(initialize-package!)
\ No newline at end of file
(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
+(add-subsystem-identification! "Gtk" '(0 2))
\ 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
;;;; Pango interface.
;;; package: (gtk pango)
-
(c-include "gtk")
-\f
-;;; PangoLayout
(define-class (<pango-layout> (constructor ()))
(<gobject>))
+(define-guarantee pango-layout "a <pango-layout>")
+
(define-method initialize-instance ((pango-layout <pango-layout>))
(call-next-method pango-layout)
(set-alien/ctype! (gobject-alien pango-layout) '|PangoLayout|))
(define (pango-layout-get-context layout)
+ (guarantee-pango-layout layout 'pango-layout-get-context)
(C-call "pango_layout_get_context"
(make-alien '|PangoContext|)
(gobject-alien layout)))
+(define (pango-layout-context-changed layout)
+ (guarantee-pango-layout layout 'pango-layout-context-changed)
+ (C-call "pango_layout_context_changed" (gobject-alien layout)))
+
(define (pango-layout-get-font-description layout)
+ (guarantee-pango-layout layout 'pango-layout-get-font-description)
(C-call "pango_layout_get_font_description"
(make-alien '|PangoFontDescription|)
(gobject-alien layout)))
+(define (pango-layout-set-font-description layout font)
+ ;; The toolkit makes a copy of FONT.
+ (guarantee-pango-font-description font 'pango-layout-set-font-description)
+ (C-call "pango_layout_set_font_description"
+ (gobject-alien layout) (if (not font) 0 font)))
+
(define (pango-layout-set-text layout text)
- (let ((l (check-pango-layout layout))
- (s (check-string text)))
- (C-call "pango_layout_set_text" (gobject-alien l) s (string-length s))))
+ (guarantee-pango-layout layout 'pango-layout-set-text)
+ (guarantee-string text 'pango-layout-set-text)
+ (C-call "pango_layout_set_text" (gobject-alien layout)
+ text (string-length text)))
(define (pango-layout-get-pixel-extents layout receiver)
- ;; Calls RECEIVER with the logical(?) dimensions (width and height)
- ;; of the laid-out text.
-
- (let ((log-extent (pango-rectangle))
- (ink-extent null-alien))
+ (guarantee-pango-layout layout 'pango-layout-set-text)
+ (guarantee-procedure-of-arity receiver 2 'pango-layout-set-text)
+ (let ((ink-extent (pango-rectangle))
+ (logical-extent (pango-rectangle)))
(C-call "pango_layout_get_pixel_extents"
- (gobject-alien layout) ink-extent log-extent)
- (let ((width (C-> log-extent "GdkRectangle width"))
- (height (C-> log-extent "GdkRectangle height")))
- (free log-extent)
+ (gobject-alien layout) ink-extent logical-extent)
+ ;; Can ink extend beyond the logical extent?
+ (let ((width (C-> logical-extent "GdkRectangle width"))
+ (height (C-> logical-extent "GdkRectangle height")))
+ (free ink-extent)
+ (free logical-extent)
(receiver width height))))
(define (pango-layout-index-to-pos layout index receiver)
- ;; Calls RECEIVER with the x, y, width and height of the grapheme at
- ;; INDEX in LAYOUT.
(let ((rect (pango-rectangle)))
(C-call "pango_layout_index_to_pos" (gobject-alien layout) index rect)
(let ((x (pangos->pixels (C-> rect "PangoRectangle x")))
(height (pangos->pixels (C-> rect "PangoRectangle height"))))
(free rect)
(receiver x y width height))))
-
-(define-integrable (check-pango-layout object)
- (if (pango-layout? object)
- object
- (error:wrong-type-argument object "<pango-layout>" 'check-pango-layout)))
\f
;;; PangoFontDescription
(define (pango-font-description-from-string string)
- (let ((str (check-string string)))
- (let ((font (make-alien '|PangoFontDescription|))
- (copy (make-alien '|PangoFontDescription|)))
- (add-gc-cleanup font (pango-font-description-cleanup copy))
- (C-call "pango_font_description_from_string" copy str)
- (copy-alien-address! font copy)
- font)))
+ ;; The returned PangoFontDescription is owned by Scheme.
+ (guarantee-string string 'pango-font-description-from-string)
+ (let ((font (make-alien '|PangoFontDescription|))
+ (copy (make-alien '|PangoFontDescription|)))
+ (add-gc-cleanup font (pango-font-description-cleanup copy))
+ (C-call "pango_font_description_from_string" copy string)
+ (if (alien-null? copy)
+ (begin
+ (punt-gc-cleanup font)
+ #f)
+ (begin
+ (copy-alien-address! font copy)
+ font))))
(define (pango-font-description-cleanup alien)
(lambda ()
- ;;without-interrupts
- (if (not (alien-null? alien))
- (begin
- (C-call "pango_font_description_free" alien)
- (alien-null! alien)))))
-
-(define (pango-font-description-free font)
- (let ((alien (check-PangoFontDescription font)))
(without-interrupts
(lambda ()
(if (not (alien-null? alien))
- (let ((cleanup (punt-gc-cleanup alien)))
- (if cleanup (cleanup))
+ (begin
+ (C-call "pango_font_description_free" alien)
(alien-null! alien)))))))
-(define (pango-font-description-to-string PangoFontDescription)
- (let ((font (check-PangoFontDescription PangoFontDescription)))
- (if (alien-null? font)
- "<null>"
- (let ((cstr (make-alien '|char|)))
- (C-call "pango_font_description_to_string" cstr font)
- (let ((str (c-peek-cstring cstr)))
- (C-call "g_free" cstr)
- str)))))
-
-(define (check-PangoFontDescription object)
- (if (and (alien? object) (eq? '|PangoFontDescription| (alien/ctype object)))
- object
- (check-PangoFontDescription
- (error:wrong-type-argument
- object "PangoFontDescription's (alien) address"
- 'check-PangoFontDescription))))
-
-(define (check-string object)
- (if (string? object) object
- (error:wrong-type-argument object "a string" 'check-string)))
+(define (pango-font-description-free font)
+ (guarantee-pango-font-description font 'pango-font-description-free)
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? font))
+ (let ((cleanup (punt-gc-cleanup font)))
+ (if cleanup (cleanup))
+ (alien-null! font))))))
+
+(define (pango-font-description-to-string font)
+ (guarantee-pango-font-description font 'pango-font-description-to-string)
+ (if (alien-null? font)
+ "<null>"
+ (let ((cstr (make-alien '|char|)))
+ (C-call "pango_font_description_to_string" cstr font)
+ (let ((str (c-peek-cstring cstr)))
+ (C-call "g_free" cstr)
+ str))))
+
+(define-integrable (guarantee-pango-font-description object operator)
+ (if (not (and (alien? object)
+ (eq? '|PangoFontDescription| (alien/ctype object))))
+ (error:wrong-type-argument
+ object "a PangoFontDescription address" operator)))
\f
;;; PangoContext
(define (pango-context-get-font-description context)
- ;; Owned by the PangoContext, not Scheme.
+ ;; The returned PangoFontDescription is owned by the toolkit
+ ;; (the PangoContext), not Scheme.
+ (guarantee-pango-context context 'pango-context-get-font-description)
(C-call "pango_context_get_font_description"
- (make-alien '|PangoFontDescription|)
- (check-PangoContext context)))
+ (make-alien '|PangoFontDescription|) context))
(define (pango-context-set-font-description context font)
- (C-call "pango_context_set_font_description"
- (check-PangoContext context)
- (check-PangoFontDescription font)))
+ ;; FONT is still owned by Scheme. The toolkit makes a copy.
+ (guarantee-pango-context context 'pango-context-set-font-description)
+ (guarantee-pango-font-description font 'pango-context-set-font-description)
+ (C-call "pango_context_set_font_description" context font))
(define (pango-context-get-metrics context font)
- ;; Owned by Scheme.
- (let ((context (check-PangoContext context))
- (font (check-PangoFontDescription font)))
- (let ((alien (make-alien '|PangoFontMetrics|))
- (copy (make-alien '|PangoFontMetrics|)))
- (add-gc-cleanup alien (pango-font-metrics-cleanup copy))
- (C-call "pango_context_get_metrics" copy context font 0)
- (copy-alien-address! alien copy)
- alien)))
+ ;; The new PangoFontMetrics is owned by Scheme.
+ (guarantee-pango-context context 'pango-context-get-metrics)
+ (guarantee-pango-font-description font 'pango-context-get-metrics)
+ (let ((alien (make-alien '|PangoFontMetrics|))
+ (copy (make-alien '|PangoFontMetrics|)))
+ (add-gc-cleanup alien (pango-font-metrics-cleanup copy))
+ (C-call "pango_context_get_metrics" copy context font 0)
+ (copy-alien-address! alien copy)
+ alien))
(define (pango-context-spacing context)
+ (guarantee-pango-context context 'pango-context-spacing)
(let ((layout (make-alien '|PangoLayout|)))
- (C-call "pango_layout_new" layout (check-PangoContext context))
+ (C-call "pango_layout_new" layout context)
(let ((spacing (C-call "pango_layout_get_spacing" layout)))
(C-call "g_object_unref" layout)
spacing)))
-(define (check-PangoContext object)
- (if (and (alien? object) (eq? '|PangoContext| (alien/ctype object)))
- object
- (check-PangoContext
- (error:wrong-type-argument
- object "the (alien) address of a PangoContext"
- 'check-PangoContext))))
+(define-integrable (guarantee-pango-context object operator)
+ (if (not (and (alien? object) (eq? '|PangoContext| (alien/ctype object))))
+ (error:wrong-type-argument
+ object "a PangoContext address" operator)))
\f
;;; PangoFontMetrics
(alien-null! alien)))))
(define (pango-font-metrics-unref metrics)
- (let ((alien (check-PangoFontMetrics metrics)))
- (without-interrupts
- (lambda ()
- (if (not (alien-null? alien))
- (let ((cleanup (punt-gc-cleanup alien)))
- (if cleanup (cleanup))
- (alien-null! alien)))))))
+ (guarantee-pango-font-metrics metrics 'pango-font-metrics-unref)
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? metrics))
+ (let ((cleanup (punt-gc-cleanup metrics)))
+ (if cleanup (cleanup))
+ (alien-null! metrics))))))
(define (pango-font-metrics-get-ascent metrics)
- (C-call "pango_font_metrics_get_ascent" (check-PangoFontMetrics metrics)))
+ (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-ascent)
+ (C-call "pango_font_metrics_get_ascent" metrics))
(define (pango-font-metrics-get-descent metrics)
- (C-call "pango_font_metrics_get_descent" (check-PangoFontMetrics metrics)))
+ (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-descent)
+ (C-call "pango_font_metrics_get_descent" metrics))
(define (pango-font-metrics-get-approximate-char-width metrics)
- (C-call "pango_font_metrics_get_approximate_char_width"
- (check-PangoFontMetrics metrics)))
-
-(define (check-PangoFontMetrics object)
- (if (and (alien? object) (eq? '|PangoFontMetrics| (alien/ctype object)))
- object
- (check-PangoFontMetrics
- (error:wrong-type-argument
- object "the (alien) address of PangoFontMetrics"
- 'check-PangoFontMetrics))))
+ (guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-approximate-char-width)
+ (C-call "pango_font_metrics_get_approximate_char_width" metrics))
+
+(define-integrable (guarantee-live-pango-font-metrics object operator)
+ (guarantee-pango-font-metrics object operator)
+ (if (alien-null? object) (error "Dead:" object)))
+
+(define-integrable (guarantee-pango-font-metrics object operator)
+ (if (not (and (alien? object) (eq? '|PangoFontMetrics| (alien/ctype object))))
+ (error:wrong-type-argument
+ object "a PangoFontMetrics address" operator)))
\f
;;; PangoRectangle
(quotient (int:+ pango-units 512) 1024))
(define-integrable (pixels->pangos pixel-units)
- (* pixel-units 1024))
\ No newline at end of file
+ (* pixel-units 1024))
+\f
+;;; Debugging hacks. No gc-cleanups!
+
+(define (pango-font-families widget)
+ (pango-context-list-families (gtk-widget-get-pango-context widget)))
+
+(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-*-
-
-Copyright (C) 2007, 2008, 2009, 2010 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)
-
-
-(c-include "gtk")
-
-(define-class (<scm-layout> (constructor make-scm-layout ()))
- (<scm-widget>)
-
- ;; Our window, a GdkWindow alien. Until realized, this will be NULL.
- (window define accessor
- initializer (lambda () (make-alien '|GdkWindow|)))
-
- ;; Our window geometry (allocation) -- a rectangular area in device
- ;; coordinates (e.g. size in pixels, offset within parent window
- ;; [ancestor widget]).
- (geometry define accessor initializer make-rect)
-
- ;; Scrollbar widgets.
- (vadjustment define standard initial-value #f)
- (hadjustment define standard initial-value #f)
- (scroll-step define accessor initializer (lambda () (cons 10 20)))
-
- ;; Scrollable area (drawing size), in logical device coords.
- (scrollable-area define accessor
- initializer (lambda () (make-rect 0 0 100 100)))
-
- ;; Scroll offset (and window size) in logical device coordinates.
- ;; (The size should match the window geometry.)
- (on-screen-area define accessor
- initializer (lambda () (make-rect 0 0)))
-
- (drawing define standard
- modifier %set-scm-layout-drawing!
- initial-value #f)
-
- (event-handlers define accessor initializer
- (lambda () (make-vector (C-enum "GDK_DAMAGE") #f))))
-
-(define (scm-layout-new width height)
- (let ((w (check-non-negative-integer width))
- (h (check-non-negative-integer 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-handler layout))
- (set-scm-widget-set-scroll-adjustments!
- layout (scm-layout-set-scroll-adjustments layout))
- layout))
-
-(define-integrable (scm-layout-realized? layout)
- (not (alien-null? (scm-layout-window 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-integer width))
- (h (check-non-negative-integer 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 (scm-layout-realized? widget)
- (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.
- (let ((w (check-positive-integer width))
- (h (check-positive-integer height))
- (area (scm-layout-scrollable-area widget)))
- (if (not (and (int:= w (rect-width area))
- (int:= h (rect-height area))))
- (begin
- (set-rect-size! area w h)
- (if (scm-layout-realized? widget)
- (adjust-adjustments widget))))))
-
-(define (set-scm-layout-scroll-pos! widget x y)
- (let ((x1 (check-integer x))
- (y1 (check-integer y)))
- (scroll widget x1 y1)))
-
-(define (scroll widget new-x new-y)
- ;; Scroll if more than 25% will remain in the window, else jump.
- (if (scm-layout-realized? widget)
- (let ((scroll (scm-layout-on-screen-area widget)))
- (let ((old-x (rect-x scroll))
- (old-y (rect-y scroll)))
- (let ((dx (int:- new-x old-x))
- (dy (int:- new-y old-y)))
- (if (not (and (int:zero? dx) (int:zero? dy)))
- (let ((width (rect-width scroll))
- (height (rect-height scroll))
- (gdkwindow (scm-layout-window widget)))
- (let ((remaining-width (int:- width (int:abs dy)))
- (remaining-height (int:- height (int:abs dx))))
- (if (or (int:negative? remaining-width)
- (int:negative? remaining-height)
- (< 0.25 (/ (int:* remaining-width remaining-height)
- (int:* width height))))
- (C-call "gdk_window_scroll"
- gdkwindow (int:negate dx) (int:negate dy))
- (C-call "gtk_widget_queue_draw"
- (gobject-alien widget)))
- (set-rect-pos! scroll new-x new-y)
- (adjust-adjustments widget))
- (C-call "gdk_window_process_updates" gdkwindow 0))))))))
-
-(define-integrable (int:abs i)
- (if (int:negative? i) (int:negate i) i))
-
-(define (set-scm-layout-scroll-step! widget width height)
- ;; Tells WIDGET to use WIDTH/HEIGHT as its "step-increment" when
- ;; setting up h/vscrollbars.
- (let ((w (check-positive-integer width))
- (h (check-positive-integer height)))
- (let ((width.height (scm-layout-scroll-step widget)))
- (set-car! width.height w)
- (set-cdr! width.height h)))
- (if (scm-layout-realized? widget)
- (adjust-adjustments widget)))
-
-(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-rect! (scm-layout-scrollable-area widget)
- (rect-x a) (rect-y a) (rect-width a) (rect-height a))
- (if (scm-layout-realized? widget)
- (begin
- (adjust-adjustments widget)
- (C-call "gtk_widget_queue_draw" alien))))))
-
-(define-integrable (check-scm-layout-alien obj)
- (if (scm-layout? obj) (gobject-alien obj)
- (error:wrong-type-argument obj "<scm-layout>" 'check-scm-layout-alien)))
-\f
-
-;;;; Callback handlers.
-
-(define (scm-layout-size-request widget)
- (named-lambda (scm-layout::size-request GtkWidget GtkRequisition)
- (trace2 ";((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: "width"x"height" from "widget"\n")
- ))))
-
-(define (scm-layout-size-allocate widget)
- (named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation)
- (trace2 ";((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)
- (if (scm-layout-realized? widget)
- (begin
- (C-call "gdk_window_move_resize" (scm-layout-window widget)
- x y width height)
- (adjust-adjustments widget))))))
-
-(define (scm-layout-realize widget)
- (named-lambda (scm-layout::realize GtkWidget)
- (trace2 ";((scm-layout-realize "widget") "GtkWidget")\n")
-
- ;; ScmWidget automatically sets GTK_REALIZED.
-
- (let ((attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|))
- (main-GdkWindow (scm-layout-window widget))
- (parent-GdkWindow (make-alien '|GdkWindow|))
-; (GdkVisual (make-alien '|GdkVisual|))
-; (GdkColormap (make-alien '|GdkColormap|))
- (check-!null (lambda (alien message)
- (if (alien-null? alien)
- (ferror "scm-layout: "message)
- alien))))
-
- ;; 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)))
- (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
-
- (let ((GtkStyle (C-> GtkWidget "GtkWidget style")))
- (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow)
- (C->= GtkWidget "GtkWidget style" GtkStyle)
- (C-call "gdk_window_set_background"
- main-GdkWindow
- (C-array-loc (C-> GtkStyle "GtkStyle base" )
- "GdkColor" (C-enum "GTK_STATE_NORMAL"))))
-
- (adjust-adjustments widget)
- unspecific)))
-
-(define (scm-layout-set-scroll-adjustments widget)
- (named-lambda (scm-layout::set-scroll-adjustments
- GtkWidget hGtkAdjustment vGtkAdjustment)
- (trace2 ";((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!)
- (if (scm-layout-realized? widget)
- (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)
- (trace2 ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
- " "GtkAdjustment")\n")
-
- (let ((window-area (scm-layout-on-screen-area widget))
- (vadjustment (scm-layout-vadjustment widget))
- (hadjustment (scm-layout-hadjustment widget))
- (value (floor->exact
- (C-> (gobject-alien adjustment) "GtkAdjustment value"))))
- (cond ((eq? adjustment vadjustment)
- (trace "; Vadjustment to "value"\n")
- (scroll widget (rect-x window-area) value))
- ((eq? adjustment hadjustment)
- (trace "; Hadjustment to "value"\n")
- (scroll widget value (rect-y window-area)))
- (else (fwarn "Unexpected adjustment "adjustment
- " (not "vadjustment" nor "hadjustment")."))))))
-
-(define (adjust-adjustments widget)
- ;; Called after the widget gets new adjustment(s) or its size or
- ;; scrollable area changes.
-
- (let ((vadj (scm-layout-vadjustment widget)))
- (if (and vadj (not (gobject-finalized? vadj)))
- (let* ((window (scm-layout-on-screen-area widget))
- (window-height (rect-height window))
- (area (scm-layout-scrollable-area widget))
- (top (rect-y area)) ;most neg.
- (bottom (int:+ top ;most pos.
- (max (rect-height area) window-height)))
- (value (rect-y window))
- (page-size window-height)
- (step-incr (cdr (scm-layout-scroll-step widget)))
- (page-incr (min page-size (- page-size step-incr))))
- (set-gtk-adjustment! vadj value top bottom
- page-size step-incr page-incr))))
-
- (let ((hadj (scm-layout-hadjustment widget)))
- (if (and hadj (not (gobject-finalized? hadj)))
- (let* ((window (scm-layout-on-screen-area widget))
- (window-width (rect-width window))
- (area (scm-layout-scrollable-area widget))
- (left (rect-x area)) ;most neg.
- (right (int:+ left ;most pos.
- (max (rect-width area) window-width)))
- (value (rect-x window))
- (page-size window-width)
- (step-incr (car (scm-layout-scroll-step widget)))
- (page-incr (min page-size (- page-size step-incr))))
- (set-gtk-adjustment! hadj value left right
- page-size step-incr page-incr)))))
-\f
-
-;;;; Event Handlers
-
-(define (scm-layout-event-handler layout)
- (named-lambda (scm-layout-handle-event GtkWidget GdkEvent)
- (trace2 ";((scm-layout-handle-event "layout") "GtkWidget" "GdkEvent")\n")
-
- (let ((type (C-> GdkEvent "GdkEvent any type")))
- (if (int:= 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 layout))
- (widget-window (scm-layout-window layout)))
- (cond ((not (alien=? window widget-window))
- (trace "; Expose a strange window "window
- " (not "widget-window").\n"))
- (drawing
- (let* ((scroll (scm-layout-on-screen-area layout))
- (offx (rect-x scroll))
- (offy (rect-y scroll)))
- (trace "; Expose area "width"x"height"+"x"+"y
- " of "layout".\n")
- (drawing-expose drawing layout window
- (make-rect (int:+ x offx) (int:+ y offy)
- width height)))))
- 1 ;;TRUE -- "handled" -- done.
- )
- (let ((handler (vector-ref (scm-layout-event-handlers layout) type)))
- (if handler
- (handler GtkWidget GdkEvent)
- ;; Unhandled
- 0))))))
-
-(define (set-scm-layout-map-handler! layout handler)
- (let ((handler (check-procedure-arity handler 1)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_MAP")
- (named-lambda (scm-layout-unmap-handler GtkWidget GdkEvent)
- GtkWidget GdkEvent ;ignore
- (handler layout)))))
-
-(define (set-scm-layout-unmap-handler! layout handler)
- (let ((handler (check-procedure-arity handler 1)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_UNMAP")
- (named-lambda (scm-layout-unmap-handler GtkWidget GdkEvent)
- GtkWidget GdkEvent ;ignore
- (handler layout)))))
-
-(define (set-scm-layout-focus-change-handler! layout handler)
- (let ((handler (check-procedure-arity handler 2)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_FOCUS_CHANGE")
- (named-lambda (scm-layout-unmap-handler GtkWidget GdkEvent)
- GtkWidget ;ignore
- (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in")))))
- (handler layout in?))))))
-
-(define (set-scm-layout-visibility-notify-handler! layout handler)
- (let ((handler (check-procedure-arity handler 2)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_VISIBILITY_NOTIFY")
- (named-lambda (scm-layout-visibility-notify-handler GtkWidget GdkEvent)
- GtkWidget ;ignore
- (let ((state (C-> GdkEvent "GdkEventVisibility state")))
- (handler
- layout
- (cond
- ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE)
- ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED)
- ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED)
- (else (C-enum "GdkVisibilityState" state)))))))))
-
-(define (set-scm-layout-key-press-handler! layout handler)
- (let ((handler (check-procedure-arity handler 3)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_KEY_PRESS")
- (named-lambda (scm-layout-key-press-handler GtkWidget GdkEvent)
- GtkWidget ;ignore
- (let ((alien (C-> GdkEvent "GdkEvent key string"))
- (length (C-> GdkEvent "GdkEvent key length"))
- (state (C-> GdkEvent "GdkEvent key state"))
- (keyval (C-> GdkEvent "GdkEvent key keyval")))
- (let ((string (c-peek-cstring alien))
- (char-bits (gdk-key-state->char-bits state)))
- (if (zero? (string-length string))
- (cond ((int:= length 1)
- (handler layout #\NUL char-bits))
- ((int:= length 0)
- (handler layout (gdk-keyval->name keyval) char-bits))
- (else (error "Unexpected length in GdkEventKey.")))
- (let ((l (string-length string)))
- (let loop ((i 0))
- (if (int:< i l)
- (if (zero? (handler layout
- (string-ref string i) char-bits))
- 0 ;;NOT handled.
- (loop (int:1+ i)))
- 1 ;;Handled.
- ))))))))))
-
-(define (set-scm-layout-motion-handler! layout handler)
- (let ((handler (check-procedure-arity handler 3)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_MOTION_NOTIFY")
- (named-lambda (scm-layout-motion-handler GtkWidget GdkEvent)
- GtkWidget ;ignore
- (let ((handled?
- (handler layout
- (floor->exact (C-> GdkEvent "GdkEventMotion x"))
- (floor->exact (C-> GdkEvent "GdkEventMotion y")))))
- (C-call "gdk_window_get_pointer" #f
- (C-> GdkEvent "GdkEventMotion window") 0 0 0)
- handled?)))))
-
-(define (set-scm-layout-button-release-handler! layout handler)
- (let ((handler (check-procedure-arity handler 3)))
- (vector-set!
- (scm-layout-event-handlers layout) (C-enum "GDK_BUTTON_RELEASE")
- (named-lambda (scm-layout-button-release-handler GtkWidget GdkEvent)
- GtkWidget ;ignore
- (let ((x (floor->exact (C-> GdkEvent "GdkEventButton x")))
- (y (floor->exact (C-> GdkEvent "GdkEventButton y"))))
- (handler layout x y))))))
-
-(define-integrable (check-procedure-arity object arity)
- (cond ((not (procedure? object))
- (error:wrong-type-argument object "procedure" 'check-procedure-arity))
- ((not (procedure-arity-valid? object arity))
- (error:bad-range-argument object 'check-procedure-arity))
- (else object)))
-\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.
- (trace2 ";(drawing-damage "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 drawn 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)
- ;; WHERE can be 'TOP (or #f) or 'BOTTOM or a drawn item already in
- ;; the display list. If a drawn-item, WHERE means ITEM should be
- ;; spliced in just under (before) it.
- (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))))
- ((drawn-item? where)
- (let loop ((items (drawing-display-list drawing))
- (prev #f))
- (if (null? items)
- (error "Item not found in drawing:" item drawing)
- (let ((i (car items)))
- (if (eq? where i)
- (if (pair? prev)
- (set-cdr! prev (cons item items))
- (set-drawing-display-list! drawing (cons item items)))
- (loop (cdr items) items))))))
- (else (error:wrong-type-argument where "display list location, one of #F, TOP, BOTTOM, or a <drawn-item> already in the drawing's display list" 'drawing-add-item!)))
- (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))))
-
-(define (set-drawing-area! drawing rectangle)
- (let ((area (drawing-area drawing)))
- (set-rect! area
- (rect-x rectangle)
- (rect-y rectangle)
- (rect-width rectangle)
- (rect-height rectangle))))
-\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 ((x (check-non-negative-integer x))
- (y (check-non-negative-integer y)))
- (without-interrupts
- (lambda ()
- (let ((area (drawn-item-area item)))
- (let ((x* (rect-x area))
- (y* (rect-y area)))
- (if (and (int:= x x*) (int:= y y*))
- unspecific
- (begin
- (drawing-damage item)
- (set-rect-pos! area x y)
- (drawing-damage item)))))))))
-
-(define (set-drawn-item-size! item width height)
- (let ((area (drawn-item-area item)))
- (let ((width* (rect-width area))
- (height* (rect-height area)))
- (if (and (int:= width width*) (int:= height height*))
- unspecific
- (begin
- (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))
- (without-interrupts
- (lambda ()
- (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))))
-
-(define (drawn-item-remove! item)
- (let ((drawing (drawn-item-drawing item)))
- (if (not (memq item (drawing-display-list drawing)))
- (warn "Removing orphan drawn-item" item drawing)
- (set-drawing-display-list!
- drawing (delq! item (drawing-display-list drawing))))
- (drawing-damage item)
- (set-drawn-item-drawing! item #f)))
-\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)
- 0 alien 0 ;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-integer width))
- (h (check-non-negative-integer 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)))
- (without-interrupts
- (lambda ()
- (drawing-damage item)
- (set-rect! area xI yI wI hI)
- (drawing-damage item)))))
-
-(define (box-item-shadow item)
- (let ((shadow (%box-item-shadow item)))
- (cond
- ((int:= shadow (C-enum "GTK_SHADOW_NONE")) 'NONE)
- ((int:= shadow (C-enum "GTK_SHADOW_IN")) 'IN)
- ((int:= shadow (C-enum "GTK_SHADOW_OUT")) 'OUT)
- ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN)
- ((int:= shadow (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
- 0 alien 0 ;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-integer 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
- 0 alien 0 ;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-integer 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-cleanup-thunk (text-item-pango-layout item))))
-
-(define (text-item-cleanup-thunk pango-layout)
- ;; Return a thunk closed over PANGO-LAYOUT (but not the item).
- ;; Thunk is run as a gc-cleanup, without-interrupts.
- (named-lambda (text-item::cleanup-thunk)
- (trace ";text-item::cleanup-thunk "pango-layout"\n")
- (if (not (alien-null? pango-layout))
- (begin
- (C-call "g_object_unref" pango-layout)
- (alien-null! pango-layout)))
- (trace ";text-item::cleanup-thunk done with "pango-layout"\n")))
-
-(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
- 0 alien 0 ;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)))
-
- (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 0))
- (C-call "pango_layout_get_pixel_extents" layout ink-extent log-extent)
-
- (without-interrupts
- (lambda ()
- (drawing-damage text-item)
- (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)
- (drawing-damage text-item)))
-
- (free log-extent))))
-
-(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)))
- (if (not (alien-null? layout))
- (let ((area (drawn-item-area item))
- (index-alien (malloc (C-sizeof "int") 'int)))
- (let ((xL (int:- x (rect-x area))) ; layout coords.
- (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 0))
- (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)))
- (if (not (alien-null? layout))
- (let ((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)))
-\f
-
-;;;; Images (aka GdkPixbufLoaders)
-
-(define-class (<image-item> (constructor add-image-item (drawing) 1))
- (<drawn-item>)
- ;; This slot is set to a <pixbuf> soon after loading has begun.
- (pixbuf define standard initial-value #f)
- ;; This slot is set to #f when the pixbuf has been successfully loaded.
- (loader define standard initializer make-pixbuf-loader))
-
-(define-method initialize-instance ((item <image-item>) where)
- (call-next-method item where)
- (let ((loader (image-item-loader item)))
- (set-pixbuf-loader-size-hook! loader (image-item-size-prepared item))
- (set-pixbuf-loader-pixbuf-hook! loader (image-item-pixbuf-prepared item))
- (set-pixbuf-loader-update-hook! loader (image-item-pixbuf-updated item))
- (set-pixbuf-loader-close-hook! loader (image-item-pixbuf-loaded item))))
-
-(define (image-item-size-prepared item)
- (named-lambda (image-item::size-prepared width height)
- (trace "; image-item::size-prepared "item" "width" "height"\n")
- (set-drawn-item-size! item width height)))
-
-(define (image-item-pixbuf-prepared item)
- (named-lambda (image-item::pixbuf-prepared pixbuf)
- (trace "; image-item::pixbuf-prepared "item" "pixbuf"\n")
- (set-image-item-pixbuf! item pixbuf)))
-
-(define (image-item-pixbuf-updated item)
- (named-lambda (image-item::pixbuf-updated rectangle)
- (trace "; image-item::pixbuf-updated "item" "rectangle"\n")
- (drawing-damage item rectangle)))
-
-(define (image-item-pixbuf-loaded item)
- (named-lambda (image-item::pixbuf-loaded loader)
- (trace "; image-item::pixbuf-loaded "item" ("(image-item-pixbuf item)")"
- " "(pixbuf-loader-error-message loader)"\n")
- (if (not (pixbuf-loader-error-message loader))
- (begin
- (set-image-item-loader! item #f)
- (gobject-unref loader))
- (begin
- ;; Hack the pixbuf with a "broken image" overlay?
- ;;
- ;; Leave the loader, with dead thread and closed
- ;; input-port, for debugging purposes.
- unspecific))))
-
-(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 (let ((p (image-item-pixbuf item)))
- (if p (gobject-alien p) #f))))
- (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)
- (let ((item (add-image-item drawing where)))
- (load-pixbuf-from-file (image-item-loader item) filename)
- item))
-
-(define-integrable (check-positive-integer obj)
- (if (and (integer? obj) (int:> obj 0))
- obj
- (error:wrong-type-argument obj "positive, non-zero integer"
- 'check-positive-integer)))
-
-(define-integrable (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 trace? #f)
-
-(define-syntax trace
- (syntax-rules ()
- ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
-
-(define trace2? #f)
-(define-syntax trace2
- (syntax-rules ()
- ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
;;;; A <gtk-widget> representing a ScmWidget.
;;; package: (gtk widget)
-
(c-include "gtk")
(define-class <scm-widget> (<gtk-widget>))
+(define-guarantee scm-widget "a <scm-widget>")
+
(define-method initialize-instance ((new <scm-widget>))
- ;; Calls scm_widget_new, modifying NEW's alien.
+ (call-next-method new)
(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
+ (if (alien-null? a)
+ (error "Could not create: a Scheme widget.")
+ (C-call "g_object_ref_sink" a a))
+ (set-gtk-object-destroy-callback! new)))
+
+(define (set-scm-widget-set-scroll-adjustments-callback! widget callback)
+ (guarantee-scm-widget widget 'set-scm-widget-set-scroll-adjustments-callback!)
+ (guarantee-procedure-of-arity callback 3 'set-scm-widget-set-scroll-adjustments-callback!)
+ (g-signal-connect widget (C-callback "set_scroll_adjustments") callback))
\ No newline at end of file
/* -*-C-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
#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_class_init (ScmWidgetClass *klass);
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)
NULL, /* class_data */
sizeof (ScmWidget),
0, /* n_preallocs */
- (GInstanceInitFunc) scm_widget_init,
+ NULL, /* instance_init */
NULL /* value_table */
};
return widget_type;
}
-static GtkWidgetClass* parent_class = NULL;
+static GtkWidgetClass *parent_class = NULL;
/* VOID:OBJECT,OBJECT (./gtkmarshalers.list:91) */
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. */
+ 0, NULL, NULL, /* class_offset, accumulator, 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);
+ return ((GtkWidget*) g_object_new (GTK_TYPE_SCMWIDGET, NULL));
}
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);
- }
-}
+ /* The default GtkWidget method expects !gtk_widget_get_has_window,
+ so it is replaced by this near no-op. ScmWidget realization
+ actually happens during REALIZE signal emission. */
-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);
- }
+ gtk_widget_set_realized (widget, TRUE);
}
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2010 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.
+
+|#
+
+;;;; SWAT adapter.
+;;; package: (gtk swat)
+
+;;;; SWAT Widgets
+
+;;; These specializations of <gtk-widget> subclasses implement SWAT's
+;;; widgets.
+
+(define-class <swat-widget>
+ (<gtk-widget>)
+
+ ;; This flag is set by a realize signal handler (or fix-layout-realize).
+ (realized? define standard initial-value #f)
+
+ ;; An alist of SWAT's configuration settings (fonts, colors, etc.).
+ (options define standard initial-value '())
+
+ ;; A pair (list of pairs?): (reason . thunk).
+ (on-death define standard initial-value #f))
+
+(define-method initialize-instance ((widget <swat-widget>) . args)
+ (trace ";((initialize-instance <swat-widget>) "widget" "args")...\n")
+ (apply call-next-method widget args)
+ ;; Do NOT replace fix-layout's realize callback. (Add a method to
+ ;; fix-layout-realize-callback instead [or support a more generic
+ ;; realize-callback?].)
+ (if (not (fix-layout? widget))
+ (set-gtk-widget-realize-callback! widget realize-options)))
+
+(define-method gtk-object-destroy-callback ((object <swat-widget>))
+ (call-next-method object)
+ (let ((on-death (without-interrupts
+ (lambda ()
+ (let ((on-death (swat-widget-on-death object)))
+ (if on-death (set-swat-widget-on-death! object #f))
+ on-death)))))
+ (if on-death
+ (begin
+ (trace ";on-death "object": "on-death"\n")
+ ((cdr on-death))))))
+
+(define-class (<swat-button> (constructor ()))
+ (<swat-widget> <gtk-button>))
+
+;; <swat-checkbutton>s can have a callback AND/or a -variable. These
+;; could be two signal handlers connected to the "toggled" signal, but
+;; Gtk does not support more than one signal handler per signal name.
+;; Instead, two slots keep track of the two possible callbacks, and
+;; the "toggled" signal is always connected (even if neither a
+;; callback nor a variable is configured).
+
+(define-class (<swat-checkbutton> (constructor ()))
+ (<swat-widget> <gtk-check-button>)
+
+ ;; From (set-callback! checkbutton (lambda () ...))
+ (swat-callback define standard initial-value #f)
+
+ ;; From (make-checkbutton -variable ...)
+ (swat-variable define standard initial-value #f))
+
+;; <swat-label>s are actually GtkFrames with no "label", whose GtkBin
+;; child is a GtkLabel... so a little confusing.
+
+(define-class (<swat-label> (constructor ()))
+ (<swat-widget> <gtk-frame>))
+
+(define-method initialize-instance ((frame <swat-label>))
+ (trace ";((initialize-instance <swat-label>) "frame")...\n")
+ (call-next-method frame "")
+ (gtk-container-add frame (gtk-label-new "")))
+
+(define (set-label-relief! label relief)
+ (let ((gtk-shadow-type (relief->gtk-shadow-type relief)))
+ (gtk-frame-set-shadow-type label gtk-shadow-type)))
+
+(define (relief->gtk-shadow-type relief)
+ (case relief
+ ((raised) 'out)
+ ((sunken) 'in)
+ ((flat) 'none)
+ ((ridge) 'etched-out)
+ ((solid) (warn "unimplemented relief" relief))
+ ((groove) 'etched-in)
+ (else (warn "unexpected relief" relief))))
+\f
+;;;; SWAT canvases
+
+;;; Implemented by a specialized <fix-layout> widget whose drawing
+;;; consists of <swat-ink>s. Swat inks co-operate as "items" in
+;;; <swat-group>s.
+;;;
+;;; The implementation chosen here removes a group's items from the
+;;; drawing's display-list, keeping them in the group's item list, and
+;;; ensuring that the group's ink-extent encompasses all of its items'
+;;; ink-extents. The layout expose handler can then skip entire
+;;; groups (assuming they are relatively compact) or descend and, in
+;;; the group expose handler, perform a similar search-and-expose
+;;; among the group's items, recursively.
+;;;
+;;; To make the group ink-extent guarantee, all of a group's items
+;;; must be <swat-ink>s, which update their group's extent
+;;; (recursively) whenever their extents change.
+;;;
+;;; Updating a group's extent generally means computing a new union of
+;;; all item ink-extents. This can be expensive for a large group
+;;; when items change relative to the rest. This is presumably rare.
+;;; Once created, a group is likely only moved or hidden, with
+;;; predictable effects on the group ink-extent (and no need to
+;;; re-union-all). For large groups of widely scattered objects, a
+;;; different group implementation would be more appropriate, e.g. one
+;;; that keeps its items in the drawing display-list and perhaps does
+;;; not even appear there itself...
+
+(define-class (<swat-canvas> (constructor () (width height)))
+ (<swat-widget> <fix-layout>)
+
+ ;; An alist of (event-type . modifiers) x SWAT event handler procedures.
+ (swat-handlers define standard initial-value '()))
+
+(define-method initialize-instance ((canvas <swat-canvas>) width height)
+ (trace ";((initialize-instance <swat-canvas>) "canvas" "width" "height")...\n")
+ (call-next-method canvas width height)
+ (set-fix-layout-drawing! canvas (make-fix-drawing) 0 0))
+
+(define (set-swat-canvas-handler! canvas type.modifiers handler)
+ ;; type.modifiers is e.g. (press 3 control), (double-press 1),
+ ;; or (motion button1).
+ (let* ((handlers (swat-canvas-swat-handlers canvas))
+ (entry (assoc type.modifiers handlers)))
+ (if entry
+ (set-cdr! entry handler)
+ (set-swat-canvas-swat-handlers!
+ canvas (cons (cons type.modifiers handler) handlers)))))
+
+(define-method fix-layout-realize-callback ((canvas <swat-canvas>))
+ (call-next-method canvas)
+ (realize-options canvas)
+ (for-each
+ (lambda (type)
+ (set-fix-layout-button-handler!
+ canvas type
+ (named-lambda (canvas-button-handler canvas type button modifiers x y)
+ (trace ";canvas-button-handler "type" "button" "modifiers
+ " "x","y" "canvas"\n")
+ (handle-canvas-event canvas
+ (append! (list type button) modifiers) x y))))
+ '(press release double-press triple-press))
+ (set-fix-layout-motion-handler!
+ canvas
+ (named-lambda (canvas-motion-handler canvas modifiers x y)
+ (trace2 ";canvas-motion-handler "modifiers" "x","y" "canvas"\n")
+ (handle-canvas-event canvas (cons 'motion modifiers) x y))))
+
+(define-class <swat-ink> (<fix-ink>)
+
+ ;; A <swat-group> or #f.
+ (group define standard initial-value #f)
+
+ ;; An alist of (event-type . modifiers) x SWAT event handler procedures.
+ (swat-handlers define standard initial-value '()))
+
+(define (set-swat-ink-handler! item type.modifiers handler)
+ (let* ((handlers (swat-ink-swat-handlers item))
+ (entry (assoc type.modifiers handlers)))
+ (if entry
+ (set-cdr! entry handler)
+ (set-swat-ink-swat-handlers!
+ item (cons (cons type.modifiers handler) handlers)))))
+
+(define (item-delete! item)
+ (fix-ink-remove! item)
+ ;; No hurry here. Expose events are cut off (above). Some
+ ;; unnecessary drawing damage may occur (if items are changed before
+ ;; they lose their link to the drawing), but the redraws will still
+ ;; be correct.
+ (if (swat-group? item)
+ (let unset! ((items (swat-group-items item)))
+ (if (pair? items)
+ (let ((i (car items)))
+ (set-fix-ink-drawing! i #f)
+ (if (swat-group? i) (unset! (swat-group-items i)))
+ (unset! (cdr items)))))))
+
+(define (item-move! item dx dy)
+ (guarantee-fixnum dx 'item-move!)
+ (guarantee-fixnum dy 'item-move!)
+ (if (not (and (fix:zero? dx) (fix:zero? dy)))
+ (without-interrupts
+ (lambda ()
+ (fix-ink-move! item dx dy)
+ (let ((group (swat-ink-group item)))
+ (if group (recache-group-extent! group)))))))
+
+(define (recache-group-extent! group)
+ (let ((extent (fix-ink-extent group))
+ (items (swat-group-items group)))
+ (if (null? items)
+ (set-fix-rect-size! extent 0 0)
+ (let ((first (car items))
+ (rest (cdr items)))
+ (copy-fix-rect! extent (fix-ink-extent first))
+ (for-each (lambda (i) (fix-rect-union! extent (fix-ink-extent i)))
+ rest))))
+ (let ((group (swat-ink-group group)))
+ (if group (recache-group-extent! group))))
+
+(define-class (<swat-group> (constructor ()))
+ (<swat-ink>)
+ (items define standard initial-value '()))
+
+(define-method fix-ink-expose-callback ((group <swat-group>) widget window area)
+ (for-each (lambda (ink)
+ (if (fix-ink-in? ink widget area)
+ (fix-ink-expose-callback ink widget window area)))
+ (swat-group-items group)))
+
+(define-method fix-ink-move! ((group <swat-group>) dx dy)
+ (without-interrupts
+ (lambda ()
+ (let ((extent (fix-ink-extent group)))
+ (fix-rect-move! extent dx dy)
+ (for-each (lambda (i) (fix-ink-move! i dx dy))
+ (swat-group-items group))))))
+
+(define (group-add! group item)
+ (without-interrupts
+ (lambda ()
+ (let ((items (swat-group-items group))
+ (extent (fix-ink-extent group))
+ (drawing (fix-ink-drawing group)))
+ (if (not (eq? drawing (fix-ink-drawing item)))
+ (error "group-add!: wrong drawing:" item group))
+ (set-swat-group-items! group (append! items (list item)))
+ (if (null? items)
+ (copy-fix-rect! extent (fix-ink-extent item))
+ (fix-rect-union! extent (fix-ink-extent item)))
+ (set-fix-drawing-display-list! ;AFTER adding to group extent
+ drawing (delq! item (fix-drawing-display-list drawing)))
+ (set-swat-ink-group! item group)))))
+
+(define (group-remove! group item)
+ (without-interrupts
+ (lambda ()
+ (let ((items (swat-group-items group)))
+ (define (topmost group)
+ (let ((parent (swat-ink-group group)))
+ (if (not parent) group (topmost parent))))
+ (if (memq item items)
+ (begin
+ ;; Move ink to canvas? Under the topmost group?
+ (fix-drawing-add-ink! (fix-ink-drawing group) item (topmost group))
+ (set-swat-group-items! group (delq! item items))
+ (recache-group-extent! group))
+ (error "No such item:" item group))))))
+\f
+;;;; Event handling.
+
+;;; Tk provides some fancy massaging of the "raw" input event stream.
+;;; The <Double-ButtonPress-1> handler specified by the pole-zero
+;;; example is an abbreviation for "<Button-1><Button-1>", according
+;;; to the Tk::bind manpage. ("<Button-..." and "<ButtonPress-..."
+;;; are equivalent.) Such a sequence is matched against the GdkEvent
+;;; stream with time and space constraints.
+;;;
+;;; The Double, Triple and Quadruple modifiers are a convenience
+;;; for specifying double mouse clicks and other repeated
+;;; events. They cause a particular event pattern to be repeated
+;;; 2, 3 or 4 times, and also place a time and space requirement
+;;; on the sequence: for a sequence of events to match a Double,
+;;; Triple or Quadruple pattern, all of the events must occur
+;;; close together in time and without substantial mouse motion in
+;;; between. For example, <Double-Button-1> is equivalent to
+;;; <Button-1><Button-1> with the extra time and space
+;;; requirement. [Tk::bind(3pm)]
+;;;
+;;; This implementation uses a preview stage to convert the GdkEvent
+;;; stream into "SWAT events". Thus a Gdk event stream like this:
+;;;
+;;; P-1 R-1 2P-1 R-1
+;;;
+;;; where P-1 is a GDK_BUTTON_PRESS event whose "button" member = 1,
+;;; R-1 is a GDK_BUTTON_RELEASE with button 1,
+;;; and 2P-1 is a GDK_2BUTTON_PRESS with button 1
+;;;
+;;; within certain time and space constraints, generates the event key
+;;;
+;;; (double-press 1)
+;;;
+;;; which is looked up among the handlers of canvasitems under the
+;;; point.
+;;;
+;;; Note that the R-1 event must be ignored, not turned into a
+;;; (release 1) event, else the pole-zero example breaks in the
+;;; <ButtonRelease-1> handler of the newly created object (under the
+;;; point).
+;;;
+;;; The state machine doing the conversion is implemented by the Gtk
+;;; event handlers. Depending on the state of the machine (the event
+;;; prefix seen so far) a Gtk event or timeout handler can generate
+;;; a SWAT event, or schedule a timeout.
+;;;
+;;; An example event stream, with small mouse movements, that should
+;;; be recognized as a single (double-press 1), no (release 1):
+;;;
+;;; P1 R1 Msmall 2P1 Msmall R1 T0
+;;;
+;;; where Msmall is any number of GDK_MOTION_NOTIFY events that
+;;; stay nearby, and T0 is a timeout scheduled during the handling
+;;; of 2P1.
+;;;
+;;; An example event stream that is actually a double-click-drag:
+;;;
+;;; P1 Msmall R1 2P1 Msmall Msmall T0 Msmall Msmall R1
+;;;
+;;; should produce:
+;;;
+;;; 2P1 Msmall Msmall R1
+;;;
+;;; For now (for pole-zero), the state machine need only ignore button
+;;; release (and movement events?) that follow a button press by less
+;;; than a fraction of a second, and button presses that are followed
+;;; by a double-press within a fraction of a second.
+;;;
+;;; To handle the latter, it is natural to wait with a timeout for the
+;;; double- or triple-press, but sleep-current-thread is inappropriate
+;;; in an event handler -- a callback running at "interrupt" level
+;;; (within without-interrupts). Instead, the event handlers queue
+;;; "input events" that are read (dequeued), with a timeout, by
+;;; swat-thread (which can sleep).
+
+(define (handle-canvas-event canvas event window-x window-y)
+ (trace2 "; handle-canvas-event "event" "window-x","window-y" "canvas"\n")
+ (let* ((view (fix-layout-view canvas))
+ (x (fix:+ window-x (fix-rect-x view)))
+ (y (fix:+ window-y (fix-rect-y view))))
+ (thread-queue/queue-no-hang! swat-input-queue (list event canvas x y))
+ #t))
+
+(define swat-input-queue)
+(define swat-thread)
+
+(define (initialize-package!)
+ (set! swat-input-queue (make-thread-queue 100))
+ (set! swat-thread (make-swat-thread)))
+
+(define (make-swat-thread)
+ (create-thread
+ #f
+ (lambda ()
+ (trace ";swat-thread: "(current-thread)"\n")
+
+ (let main ()
+
+ (define-integrable (read!)
+ (thread-queue/dequeue! swat-input-queue))
+
+ (define-integrable (peek-until time)
+ (thread-queue/peek-until swat-input-queue time))
+
+ (define-integrable (handle event)
+ (apply handle-event event)
+ (main))
+
+ (let* ((event (read!))
+ (type (caar event)))
+ (cond
+ ((eq? type 'release)
+ (main)) ; Ignore EVENT.
+ ((memq type '(press double-press triple-press))
+ (let ((quitn-time (+ 500 (real-time-clock))))
+ (let wait ()
+ (let ((next-event (peek-until quitn-time)))
+ (if (not next-event)
+ (handle event)
+ (let ((next-type (caar next-event)))
+ (cond
+ ((memq next-type '(double-press triple-press))
+ (main)) ; Ignore EVENT, read NEXT-EVENT.
+ ((eq? next-type 'motion)
+ (read!) ; Ignore NEXT-EVENT,
+ (wait)) ; and wait some more.
+ (else
+ (handle event)))))))))
+ (else
+ (handle event)))))
+ (trace ";swat-thread: done\n")
+ (stop-current-thread))))
+
+(define (handle-event key canvas x y)
+ (or (let* ((handlers (swat-canvas-swat-handlers canvas))
+ (entry (assoc key handlers)))
+ (trace "; Canvas: "entry"\n")
+ (and entry ((cdr entry) canvas x y)))
+ (let ((items (pick-list canvas x y)))
+ (trace "; Pick list: "items"\n")
+ (find (lambda (item)
+ (let* ((handlers (swat-ink-swat-handlers item))
+ (entry (assoc key handlers)))
+ (trace "; "entry" "item"\n")
+ (and entry ((cdr entry) canvas x y))))
+ items))))
+
+(define (pick-list canvas x y)
+ (trace2 "; pick-list "x","y" "canvas"\n")
+ (let loop ((items (fix-drawing-display-list (fix-layout-drawing canvas)))
+ (picks '()))
+ (if (pair? items)
+ (loop (cdr items)
+ (let ((item (car items)))
+ (if (not (fix-ink-in-widget? item canvas))
+ (trace2 ";\t"item" not in "canvas"\n")
+ (begin
+ (trace2 ";\t"x","y" in "item" ("(fix-ink-extent item)")? ")
+ (if (point-in-fix-rect? x y (fix-ink-extent item))
+ (trace2 "yes!\n")
+ (trace2 "no\n"))))
+ (if (and (fix-ink-in-widget? item canvas)
+ (point-in-fix-rect? x y (fix-ink-extent item)))
+ (cons item
+ (if (swat-group? item)
+ (append! (loop (swat-group-items item) '())
+ picks)
+ picks))
+ picks)))
+ picks)))
+
+(define-class (<swat-line> (constructor ()))
+ (<line-ink> <swat-ink>))
+
+(define-class (<swat-rectangle> (constructor ()))
+ (<rectangle-ink> <swat-ink>))
+
+(define-class (<swat-oval> (constructor ()))
+ (<arc-ink> <swat-ink>))
+
+(define-class (<swat-text> (constructor ()))
+ (<simple-text-ink> <swat-ink>)
+ (anchor define standard initial-value 'nw
+ modifier set-swat-text-%anchor!))
+
+(define (set-swat-text-anchor! text anchor)
+ (if (not (eq? anchor (swat-text-anchor text)))
+ (hold-position text
+ (lambda () (set-swat-text-%anchor! text anchor)))))
+
+(define (set-swat-text-text! text string)
+ (guarantee-string string 'set-swat-text-text!)
+ (if (eq? 'nw (swat-text-anchor text))
+ (set-simple-text-ink-text! text string)
+ (hold-position text (lambda () (set-simple-text-ink-text! text string)))))
+
+(define-integrable (hold-position text thunk)
+ (with-swat-text-pos
+ text
+ (lambda (old-x old-y)
+ (thunk)
+ (with-swat-text-pos
+ text
+ (lambda (new-x new-y)
+ (let ((dx (fix:- new-x old-x))
+ (dy (fix:- new-y old-y)))
+ (if (not (and (fix:zero? dx) (fix:zero? dy)))
+ (fix-ink-move! text dx dy))))))))
+
+(define (with-swat-text-pos text receiver)
+ ;; Calls RECEIVER with the coordinates of the text's anchor position.
+ (let ((anchor (swat-text-anchor text)))
+ (with-fix-rect
+ (fix-ink-extent text)
+ (lambda (x y width height)
+ (define-integrable (top) x)
+ (define-integrable (left) y)
+ (define-integrable (right) (fix:+ x width))
+ (define-integrable (bottom) (fix:+ y height))
+ (define-integrable (mid-right) (fix:+ x (quotient width 2)))
+ (define-integrable (mid-bottom) (fix:+ y (quotient height 2)))
+ (case anchor
+ ((CENTER) (receiver (mid-right) (mid-bottom)))
+ ((NE) (receiver (right) (top)))
+ ((SE) (receiver (right) (bottom)))
+ ((SW) (receiver (left) (bottom)))
+ ((NW) (receiver (left) (top)))
+ ((N) (receiver (mid-right) (top)))
+ ((E) (receiver (right) (mid-bottom)))
+ ((S) (receiver (mid-right) (bottom)))
+ ((W) (receiver (left) (mid-bottom)))
+ (else (error "Unexpected text anchor:" anchor text)))))))
+\f
+;;;; Active Variables
+
+;;; These are tricky. A variable should, in set-active-variable!,
+;;; call any SWAT callback (if set). Those variables "connected" to a
+;;; widget should ALSO frob the widget (e.g. set a GtkLabel's text, or
+;;; toggle a check-button,...).
+;;;
+;;; Some widgets also SET variables, e.g. in a check-button "toggled"
+;;; callback. In these cases, the SWAT callback should be called (if
+;;; set), BUT the frobbing of the widget... might be a loop! Thus an
+;;; active variable separates the SWAT callback from the widget
+;;; frobbing. It always does the former, sometimes the latter.
+
+(define-structure (active-variable (constructor make-active-variable ()))
+
+ (value '())
+
+ ;; Could not find anything like SOS slot option "define initpred",
+ ;; though there seems to be something there... Anyway, this seems
+ ;; more portable.
+ (value-initialized? #f)
+
+ ;; User callback -- a thunk.
+ (swat-callback #f)
+
+ ;; Widget frobbing closure, taking one arg: the new value.
+ (frob #f))
+
+(define-guarantee active-variable "active-variable")
+
+(define (set-active-variable-callback! variable callback)
+ (guarantee-active-variable variable 'set-active-variable-callback!)
+ (guarantee-procedure-of-arity callback 0 'set-active-variable-callback!)
+ (if (active-variable-swat-callback variable)
+ (error "Callback already set:" variable callback))
+ (set-active-variable-swat-callback! variable callback))
+
+(define (set-active-variable! variable value)
+ (guarantee-active-variable variable 'set-active-variable!)
+ (frob-active-variable! variable value)
+ (let ((frob (active-variable-frob variable)))
+ (if frob (frob value))))
+
+(define-integrable (frob-active-variable! variable value)
+ ;; Used by widgets to frob an active variable without getting
+ ;; frobbed in return.
+ (set-active-variable-value-initialized?! variable #t)
+ (set-active-variable-value! variable value)
+ (let ((callback (active-variable-swat-callback variable)))
+ (if callback (callback))))
+\f
+;;;; Widget Configuration
+
+;;; Options from the examples:
+;;;
+;;; button -foreground blue
+;;; button -background yellow
+;;; button -activebackground red
+;;; button -text "Push me"
+;;;
+;;; and from Pole-0:
+;;;
+;;; button -background ,color
+;;; canvas -background ,color
+;;; label -background ,color
+;;; button -font "CourR12"
+;;; label -font "CourR12"
+;;; label -relief sunken
+;;; button -text ,string
+;;; label -textvariable ,active-variable
+;;; label -width 13
+
+(define (widget-configure! widget options)
+ (let loop ((opts options))
+ (if (pair? opts)
+ (let ((name (car opts))
+ (value (cadr opts)))
+ (case name
+ ((-foreground) (set-option! widget 'foreground value))
+ ((-background) (set-option! widget 'background value))
+ ((-activeforeground) (set-option! widget 'activeforeground value))
+ ((-activebackground) (set-option! widget 'activebackground value))
+ ((-font) (set-option! widget 'font value))
+
+ ((-width) (set-width! widget value))
+ ((-text) (set-text! widget value))
+ ((-textvariable) (set-textvariable! widget value))
+ ((-relief) (set-label-relief! widget value))
+ (else (warn "unimplemented configure option:"
+ name value widget)))
+ (loop (cddr opts))))))
+
+(define (set-option! widget name spec)
+ (let* ((options (swat-widget-options widget))
+ (entry (assq name options)))
+ (if entry
+ (set-cdr! entry spec)
+ (set-swat-widget-options! widget (cons (cons name spec) options))))
+ (if (swat-widget-realized? widget) (realize-option widget name spec)))
+
+(define (realize-option widget name spec)
+ (case name
+ ((foreground) (set-gtk-widget-fg-color! widget spec 'normal))
+ ((background) (set-gtk-widget-bg-color! widget spec 'normal))
+ ((activeforeground) (set-gtk-widget-fg-color! widget spec 'active))
+ ((activebackground) (set-gtk-widget-bg-color! widget spec 'active))
+ ((font) (set-gtk-widget-font! widget spec))
+ (else (warn "Cannot realize widget option:" name spec widget))))
+
+(define (realize-options widget)
+ (for-each (lambda (option)
+ (realize-option widget (car option) (cdr option)))
+ (swat-widget-options widget)))
+
+(define-integrable (set-width! widget width)
+ (if (swat-label? widget)
+ (gtk-label-set-width-chars (gtk-bin-child widget) width)
+ (warn "Unimplemented:" '-width widget)))
+
+(define-generic set-text! (widget string))
+
+(define-method set-text! ((button <swat-button>) string)
+ (guarantee-string string '(set-text! <swat-button>))
+ (let ((label (gtk-bin-child button)))
+ (if (not label)
+ (gtk-container-add button (gtk-label-new string))
+ (gtk-label-set-text label string))))
+
+(define-method set-text! ((label <swat-label>) string)
+ (guarantee-string string '(set-text! <swat-label>))
+ (gtk-label-set-text (gtk-bin-child label) string))
+
+(define-method set-text! ((button <swat-checkbutton>) string)
+ (guarantee-string string '(set-text! <swat-checkbutton>))
+ (let ((label (gtk-bin-child button)))
+ (if (not label)
+ (gtk-container-add button (gtk-label-new string))
+ (gtk-label-set-text label string))))
+
+(define-generic set-textvariable! (widget active-variable))
+
+(define-method set-textvariable! ((widget <swat-label>) variable)
+ (set-active-variable-frob! variable (make-label-frobbery widget))
+ (set-active-variable-value! variable
+ (gtk-label-get-text (gtk-bin-child widget)))
+ (set-active-variable-value-initialized?! variable #t))
+
+(define (make-label-frobbery label)
+ (named-lambda (label-frobbery value)
+ (trace ";label-frobbage "label" "value"\n")
+ (if (string? value)
+ (gtk-label-set-text (gtk-bin-child label) value)
+ (warn "Bogus text for swat-label frobbery:" value label))))
+\f
+;;;; Canvas Item Configuration
+
+;;; Options from pole-zero:
+;;;
+;;; text -anchor sw
+;;; text -anchor e
+;;; line -arrow last
+;;; line -arrow first
+;;; group -fill ,color
+;;; oval -fill ,color
+;;; text -font "-adobe-symbol-...-fontspecific"
+;;; oval -outline "gray"
+;;; text -text "p"
+;;; group -width 2
+;;; oval -width 2
+
+(define (item-configure! item options)
+ (without-interrupts
+ (lambda ()
+ (let loop ((opts options))
+ (if (pair? opts)
+ (let ((name (car opts))
+ (value (cadr opts)))
+ (set-item-option! item name value)
+ (loop (cddr opts))))))))
+
+(define (set-item-option! item name value)
+ (if (swat-group? item)
+ (for-each (lambda (i) (set-item-option! i name value))
+ (swat-group-items item))
+ (case name
+ ((-anchor) (set-item-anchor! item value))
+ ((-arrow) (set-item-arrow! item value))
+ ((-fill) (set-item-fill! item value))
+ ((-font) (set-item-font! item value))
+ ((-outline) (set-item-outline! item value))
+ ((-text) (set-item-text! item value))
+ ((-width) (set-item-width! item value))
+ (else (error "Unimplemented option:" name value item)))))
+
+(define-generic set-item-anchor! (item value))
+(define-method set-item-anchor! ((text <swat-text>) value)
+ (if (not (memq value '(N S E W NE SE SW NW)))
+ (error:wrong-type-argument value "an anchor direction" 'set-item-anchor!))
+ (set-swat-text-anchor! text value))
+
+(define-generic set-item-arrow! (item first?))
+(define-method set-item-arrow! ((line <swat-line>) first?)
+ (warn "Unimplemented:" '(set-item-arrow! <swat-line>) line first?))
+
+(define-generic set-item-fill! (item color))
+(define-method set-item-fill! ((item <swat-line>) color)
+ (set-line-ink-color! item color))
+(define-method set-item-fill! ((item <swat-oval>) color)
+ (set-arc-ink-fill-color! item color))
+(define-method set-item-fill! ((item <swat-rectangle>) color)
+ (set-rectangle-ink-fill-color! item color))
+(define-method set-item-fill! ((item <swat-text>) color)
+ (set-text-ink-color! item color))
+
+(define-generic set-item-font! (item font))
+(define-method set-item-font! ((item <swat-text>) font)
+ (set-simple-text-ink-font! item font))
+
+(define-generic set-item-outline! (item value))
+(define-method set-item-outline! ((item <swat-oval>) color)
+ (set-arc-ink-color! item color))
+(define-method set-item-outline! ((item <swat-rectangle>) color)
+ (set-rectangle-ink-color! item color))
+
+(define-generic set-item-text! (item value))
+(define-method set-item-text! ((text <swat-text>) string)
+ (guarantee-string string '(set-item-text! <swat-text>))
+ (set-swat-text-text! text string))
+
+(define-generic set-item-width! (item value))
+(define-method set-item-width! ((item <swat-line>) width)
+ (set-line-ink-width! item width))
+(define-method set-item-width! ((item <swat-oval>) width)
+ (guarantee-positive-fixnum width '(set-item-width! <swat-oval>))
+ (set-arc-ink-width! item width))
+(define-method set-item-width! ((item <swat-rectangle>) width)
+ (guarantee-positive-fixnum width '(set-item-width! <swat-rectangle>))
+ (set-rectangle-ink-width! item width))
+\f
+;;;; SWAT Interface
+
+;;; Here are the procedures exported to the (swat) package. They are
+;;; organized by their original SWAT files, listed in the order they
+;;; are loaded.
+
+;;; * control-floating-errors
+;;;
+;;; LAP-generating floating-exception-flag-frobing Nerds Gone Wild.
+
+;;; * structures
+;;;
+;;; Definitions of structures in Tk.
+
+;;; * structures2
+;;;
+;;; And some more.
+
+;;; * generics
+;;;
+;;; Generic operations:
+;;; SET-CONTEXT!, assign-screen-area!,
+;;; assign-drawing-surface!, handle-event,
+;;; get-desired-size, get-desired-size, EVENT-WITHIN?
+
+(define (add-child! object child . others)
+ (if (null? others)
+ (gtk-container-add object child)
+ (error "unimplemented")))
+
+(define (remove-child! object child)
+ (gtk-container-remove object child))
+
+;;; Ask-widget in the examples:
+;;;
+;;; (ask-widget button-widget '(configure -foreground blue))
+;;;
+;;; and in pole-zero.scm:
+;;;
+;;; (ask-widget oval-item `(configure -outline ,zero-color ...))
+;;; (ask-widget group-item `(configure -fill ,pole-color -width 2))
+;;; (ask-widget button-widget `(configure -text ,(car (list-ref to-switch i))))
+;;; (ask-widget label-widget `(configure -width 13 ...))
+;;; (ask-widget canvas-widget `(configure -background ,canvas-color))
+;;; (ask-widget line-item '(configure -arrow last))
+;;; (ask-widget text-item '(configure -anchor sw ...))
+;;; (ask-widget oval-item `(move ,(- x last-x) ,(- y last-y)))
+;;; (ask-widget group-item `(move ,(- x last-x) ,(- y last-y)))
+;;; (ask-widget oval-item '(delete))
+;;; (ask-widget group-item '(delete))
+;;; (ask-widget canvas-widget '(delete all))
+
+(define (ask-widget object command)
+ ;; Dispatch on command name and object type (widget or canvas item).
+ (case (car command)
+ ((CONFIGURE)
+ (cond ((swat-widget? object)
+ (widget-configure! object (cdr command)))
+ ((swat-ink? object)
+ (item-configure! object (cdr command)))
+ (else (warn "Non-SWAT widget:" object))))
+ ((MOVE)
+ (cond ((and (swat-ink? object)
+ (= 3 (length command)))
+ (item-move! object (cadr command) (caddr command)))
+ (else
+ (warn "Unexpected move command:" object command))))
+ ((DELETE)
+ (cond ((and (equal? command '(DELETE ALL))
+ (swat-canvas? object))
+ (delete-all! object))
+ ((and (equal? command '(DELETE))
+ (swat-ink? object))
+ (item-delete! object))
+ (else
+ (warn "Unexpected delete command:" object command))))
+ (else (warn "Unimplemented ask-widget command:" object command))))
+
+(define-generic add-event-handler! (object event-type handler . substitutions))
+;;; Examples: (add-event-handler! button "<Enter>" (lambda () ...))
+;;; Pole-0: (add-event-handler! item-group "<ButtonPress-1>" (lambda (x y) ...) "%x" "%y")
+;;; Pole-0: (add-event-handler! item-group "<ButtonPress-1>" (lambda (x) ...) "%x")
+;;; Pole-0: (add-event-handler! item-group "<ButtonRelease-1>" (lambda () ...))
+;;; Pole-0: (add-event-handler! item-group "<B1-Motion>" (lambda (x y) ...) "%x" "%y")
+;;; Pole-0: (add-event-handler! item-group "<B1-Motion>" (lambda (x) ...) "%x")
+
+(define-method add-event-handler! ((button <swat-button>)
+ event-type handler . substitutions)
+ (cond ((and (string=? event-type "<Enter>")
+ (null? substitutions))
+ (guarantee-procedure-of-arity handler 0 'add-event-handler!-<swat-button>)
+ (set-gtk-button-clicked-callback!
+ button (lambda (button) (declare (ignore button)) (handler))))
+ (else
+ (warn "Unimplemented:" '(add-event-handler! <swat-button>)
+ button event-type handler substitutions))))
+
+(define-method add-event-handler! ((canvas <swat-canvas>)
+ event-type handler . substitutions)
+
+ (define (unimplemented)
+ (warn "Unimplemented:" '(add-event-handler! <swat-canvas>)
+ canvas event-type handler substitutions))
+
+ (cond
+ ((and (string=? event-type "<Double-ButtonPress-1>")
+ (equal? substitutions '("%x" "%y")))
+ (guarantee-procedure-of-arity handler 2 '(add-event-handler! <swat-canvas>))
+ (set-swat-canvas-handler! canvas '(double-press 1)
+ (lambda (canvas x y)
+ (declare (ignore canvas))
+ (handler x y))))
+ (else (unimplemented))))
+
+(define-method add-event-handler! ((item <swat-ink>)
+ event-type handler . substitutions)
+
+ (define (unimplemented)
+ (warn "Unimplemented:" '(add-event-handler! <swat-ink>)
+ item event-type handler substitutions))
+
+ (cond
+ ((string=? event-type "<ButtonPress-1>")
+ (cond
+ ((equal? substitutions '("%x" "%y"))
+ (guarantee-procedure-of-arity handler 2 '(add-event-handler! <swat-ink> "<ButtonPress-1>" "%x" "%y"))
+ (set-swat-ink-handler! item '(press 1)
+ (lambda (item x y)
+ (declare (ignore item))
+ (handler x y))))
+ ((equal? substitutions '("%x"))
+ (guarantee-procedure-of-arity handler 1 '(add-event-handler! <swat-ink> "<ButtonPress-1>" "%x"))
+ (set-swat-ink-handler! item '(press 1)
+ (lambda (item x y)
+ (declare (ignore item y))
+ (handler x))))
+ (else (unimplemented))))
+ ((string=? event-type "<ButtonRelease-1>")
+ (cond
+ ((equal? substitutions '())
+ (guarantee-procedure-of-arity handler 0 '(add-event-handler! <swat-ink> "<ButtonRelease-1>"))
+ (set-swat-ink-handler! item '(release 1 button1)
+ (named-lambda (release1 item x y)
+ (declare (ignore item x y))
+ (handler))))
+ (else (unimplemented))))
+ ((string=? event-type "<B1-Motion>")
+ (cond
+ ((equal? substitutions '("%x" "%y"))
+ (guarantee-procedure-of-arity handler 2 '(add-event-handler! <swat-ink> "<B1-Motion>" "%x" "%y"))
+ (set-swat-ink-handler! item '(motion button1)
+ (named-lambda (motion-button1-x-y item x y)
+ (declare (ignore item))
+ (handler x y))))
+ ((equal? substitutions '("%x"))
+ (guarantee-procedure-of-arity handler 1 '(add-event-handler! <swat-ink> "<B1-Motion>" "%x"))
+ (set-swat-ink-handler! item '(motion button1)
+ (named-lambda (motion-button1-x item x y)
+ (declare (ignore item y))
+ (handler x))))
+ (else (unimplemented))))
+ (else (unimplemented))))
+
+(define-generic set-callback! (object callback))
+;;; Examples: (set-callback! button (lambda () ...))
+
+(define-method set-callback! ((object <swat-button>) callback)
+ (guarantee-procedure-of-arity callback 0 '(set-callback! <swat-button>))
+ (set-gtk-button-clicked-callback!
+ object (lambda (button) (declare (ignore button)) (callback))))
+
+(define-method set-callback! ((object <swat-checkbutton>) callback)
+ (guarantee-procedure-of-arity callback 0 '(set-callback! <swat-checkbutton>))
+ (set-swat-checkbutton-swat-callback! object callback))
+
+(define-method set-callback! ((object rtd:active-variable) callback)
+ (guarantee-procedure-of-arity callback 1 '(set-callback! active-variable))
+ (set-active-variable-callback! object callback))
+
+;;; * uitk
+;;;
+;;; Geometry, Events, Contexts, rectangle=, UIObj-protect-from-gc!...
+
+#;(define (create-default-context name display)
+ name display
+ unspecific)
+
+(define (on-death! object reason thunk)
+ (let ((old (swat-widget-on-death object)))
+ (if old (warn "Swat-widget already has an on-death! callback:"
+ object reason thunk old)))
+ (set-swat-widget-on-death! object (cons reason thunk)))
+
+;;; * xlibCONSTANTS
+;;;
+;;; xlib constants: enums, masks,
+
+;;; * mit-xlib
+;;;
+;;; The SCXL library for interfacing with X. E.g. XClearArea,
+;;; initialize-scxl!.
+
+;;; * tk-mit
+;;;
+;;; tk-init, %tkKillApplication, TK Callback handling.
+
+;;; * mit-xhooks
+;;;
+;;; UITK main loop, make-uitk-thread, when-idle, after-delay,
+;;; ClearArea, initialize-uitk!.
+
+(define (after-delay seconds thunk)
+ (guarantee-index-fixnum seconds 'after-delay)
+ (guarantee-procedure-of-arity thunk 0 'after-delay)
+ (create-thread
+ #f
+ (lambda ()
+ (trace ";after-delay "seconds", sleeping "(current-thread)"\n")
+ (sleep-current-thread (* seconds 1000))
+ (thunk)
+ (stop-current-thread))))
+
+;;; * widget-mit
+;;;
+;;; tk-make-menu, initialize-mit-widgets!.
+
+;;; * baseobj
+;;;
+;;; Basic objects for the Scheme User Interface Tool Kit.
+;;; E.g. make-application, swat-open, swat-close.
+
+(define (swat-open . options)
+ (let loop ((options options)
+ (objects '()))
+ (if (pair? options)
+ (if (eq? '-title (car options))
+ (if (and (pair? (cdr options)) (string? (cadr options)))
+ (let ((window (%open (reverse! objects) (cadr options))))
+ (cons window (loop (cddr options) '())))
+ (error "No title after -title keyword:" options))
+ (loop (cdr options) (cons (car options) objects)))
+ (if (null? objects)
+ '()
+ (list (%open (reverse! objects) "SWAT"))))))
+
+(define (%open children title)
+ (let ((window (gtk-window-new 'toplevel))
+ (box (gtk-hbox-new #f 5)))
+ (for-each (lambda (child) (gtk-container-add box child)) children)
+ (gtk-window-set-title window title)
+ (gtk-container-add window box)
+ (gtk-widget-show-all window)
+ window))
+
+(define (swat-close child)
+ (let ((parent (gtk-widget-parent child)))
+ (if parent (swat-close parent)
+ (if (gtk-window? child)
+ (gtk-object-destroy child)
+ (error "unexpected top-level widget" child)))))
+
+;;; * widget
+;;;
+;;; TkWidget-add-event-handler!, TkWidget-ask-widget, make-listbox,
+;;; make-active-variable, initialize-widgets!.
+
+(define (make-button #!optional options)
+ (let ((button (make-swat-button)))
+ (if (not (default-object? options))
+ (widget-configure! button options))
+ button))
+
+(define (make-label #!optional options)
+ (let ((label (make-swat-label)))
+ (if (not (default-object? options))
+ (widget-configure! label options))
+ label))
+
+(define (make-checkbutton options)
+ (let ((button (make-swat-checkbutton)))
+ (set-gtk-check-button-toggled-callback! button checkbutton-toggled-callback)
+ (let ((active (find-option options '-variable #f)))
+ (if active
+ (begin
+ (set-swat-checkbutton-swat-variable! button active)
+ (set-active-variable-frob!
+ active (make-checkbutton-frobbery button)))))
+ (widget-configure! button (delete-option! '-variable options))
+ button))
+
+(define (make-checkbutton-frobbery button)
+ (named-lambda (checkbutton-frobbery value)
+ (trace ";checkbutton-frobbery: setting "button" to "value"\n")
+ (gtk-check-button-set-active button value)))
+
+(define (checkbutton-toggled-callback button)
+ (let ((variable (swat-checkbutton-swat-variable button))
+ (callback (swat-checkbutton-swat-callback button)))
+ (if (or variable callback)
+ (let ((state (gtk-check-button-get-active button)))
+ (if variable
+ (begin
+ (trace ";checkbutton-toggled-callback:"
+ " setting "variable" to "state" for "button"\n")
+ (frob-active-variable! variable state)))
+ (if callback
+ (begin
+ (trace ";checkbutton-toggled-callback:"
+ " calling "callback" for "button"\n")
+ (callback))))
+ (trace ";checkbutton-toggled-callback: noop\n"))))
+
+(define (checkbutton-variable-on? active)
+ (active-variable-value active))
+
+;;; * geometry
+;;;
+;;; make-hbox, make-array-box.
+
+(define (make-hbox . kids)
+ (let ((box (gtk-hbox-new #f 0)))
+ (for-each (lambda (kid) (gtk-container-add box kid)) kids)
+ box))
+
+(define (make-vbox . kids)
+ (let ((box (gtk-vbox-new #f 0)))
+ (for-each (lambda (kid) (gtk-container-add box kid)) kids)
+ box))
+
+(define (box-children box)
+ (gtk-container-children box))
+
+;;; * simple
+;;;
+;;; make-shape, make-rect, make-oval, make-line.
+
+;;; * canvas
+;;;
+;;; make-scrollable-canvas, ..., make-bitmap-on-canvas...
+
+(define (make-canvas options)
+ (let ((width (find-option options '-width #f))
+ (height (find-option options '-height #f)))
+ (let ((canvas (make-swat-canvas width height)))
+ (trace ";(make-canvas "options") configuring "canvas"\n")
+ (widget-configure! canvas (delete-options! '(-width -height) options))
+ (trace ";(make-canvas "options") => "canvas"\n")
+ canvas)))
+
+(define (make-canvas-item-group canvas items)
+ (let ((group (make-swat-group)))
+ (fix-drawing-add-ink! (fix-layout-drawing canvas) group)
+ (for-each (lambda (item) (group-add! group item)) items)
+ group))
+
+(define (delete-all! canvas)
+ (let ((drawing (fix-layout-drawing canvas)))
+ (for-each fix-ink-remove! (fix-drawing-display-list drawing))))
+
+(define (make-line-on-canvas canvas x1 y1 x2 y2)
+ (guarantee-fixnum x1 'make-line-on-canvas)
+ (guarantee-fixnum y1 'make-line-on-canvas)
+ (guarantee-fixnum x2 'make-line-on-canvas)
+ (guarantee-fixnum y2 'make-line-on-canvas)
+ (let ((item (make-swat-line)))
+ (set-line-ink! item x1 y1 x2 y2)
+ (fix-drawing-add-ink! (fix-layout-drawing canvas) item)
+ item))
+
+(define (make-rectangle-on-canvas canvas x y width height)
+ (guarantee-fixnum x 'make-rectangle-on-canvas)
+ (guarantee-fixnum y 'make-rectangle-on-canvas)
+ (guarantee-positive-fixnum width 'make-rectangle-on-canvas)
+ (guarantee-positive-fixnum height 'make-rectangle-on-canvas)
+ (let ((item (make-swat-rectangle)))
+ (set-rectangle-ink! item x y width height)
+ (fix-drawing-add-ink! (fix-layout-drawing canvas) item)
+ item))
+
+(define (make-oval-on-canvas canvas x1 y1 x2 y2)
+ (guarantee-fixnum x1 'make-oval-on-canvas)
+ (guarantee-fixnum y1 'make-oval-on-canvas)
+ (guarantee-fixnum x2 'make-oval-on-canvas)
+ (guarantee-fixnum y2 'make-oval-on-canvas)
+ (let ((x (fix:min x1 x2))
+ (y (fix:min y1 y2))
+ (width (fix:abs (fix:- x2 x1)))
+ (height (fix:abs (fix:- y2 y1)))
+ (item (make-swat-oval)))
+ (set-arc-ink! item x y width height)
+ (set-arc-ink-start-angle! item 0)
+ (set-arc-ink-sweep-angle! item 360)
+ (fix-drawing-add-ink! (fix-layout-drawing canvas) item)
+ item))
+
+(define (make-text-on-canvas canvas x y options)
+ (let ((text (find-option options '-text ""))
+ (anchor (find-option options '-anchor 'center))
+ (ink (make-swat-text)))
+ (guarantee-string text 'make-text-on-canvas)
+ (set-simple-text-ink-text! ink canvas text)
+ (set-text-ink-position! ink x y)
+ (set-swat-text-anchor! ink anchor)
+ (fix-drawing-add-ink! (fix-layout-drawing canvas) ink)
+ (item-configure! ink (delete-options! '(-text -anchor) options))
+ ink))
+
+;;; * menu
+;;;
+;;; find-menu-record, delete-menuitem! add-to-menu.
+
+;;; * text
+;;;
+;;; make-scrollable-text, make-text-tag, texttag-add-event-handler!
+\f
+(define (find-option options name default)
+ (let loop ((opts options))
+ (if (pair? opts)
+ (if (eq? (car opts) name)
+ (cadr opts)
+ (loop (cddr opts))
+ ;; If multiple values can follow an option keyword:
+ #;(let collect ((opts (cdr opts))
+ (sgra '()))
+ (if (or (null? opts)
+ (and (symbol? (car opts))
+ (char=? #\-
+ (string-ref (symbol-name (car opts)) 0))))
+ ;; Return a list only if multiple values followed.
+ (if (and (not (null? sgra))
+ (null? (cdr sgra)))
+ (car sgra)
+ (reverse! sgra))
+ (collect (cdr opts) (cons (car opts) sgra))))
+ )
+ default)))
+
+(define (option-names options)
+ (let loop ((opts options))
+ (if (null? opts)
+ '()
+ (cons (car opts) (loop (cddr opts))))))
+
+(define (delete-options! names options)
+ (let loop ((names names)
+ (options options))
+ (if (pair? names)
+ (loop (cdr names)
+ (delete-option! (car names) options))
+ options)))
+
+(define (delete-option! name options)
+
+ (define (trim options)
+ (if (pair? options)
+ (if (eq? (car options) name)
+ (cddr options)
+ (begin
+ (splice! (cdr options) (cddr options))
+ options))
+ '()))
+
+ (define (splice! previous options)
+ (if (pair? options)
+ (if (eq? name (car options))
+ (set-cdr! previous (cddr options))
+ (splice! (cdr options) (cddr options)))))
+
+ (trim options))
+
+(define trace? #f)
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
+
+(define trace2? #f)
+
+(define-syntax trace2
+ (syntax-rules ()
+ ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS)))))))
+
+(initialize-package!)
\ No newline at end of file
;;; should no longer use wait-for-io, nor need to signal
;;; condition-type:no-thread!
+;;; Note that GC daemons cannot be allowed to run during a callback.
+;;; After-gc interrupts are currently serviced with
+;;; interrupt-mask/timer-ok!, which might allow a switch to a
+;;; different thread, which might return from a different callback.
+
(define (create-gtk-thread)
(if gtk-thread (error "A GTk thread already exists."))
(set! gtk-thread
(set! done-tick gc-tick))))))
(without-interrupts
(lambda ()
- (let ((time (time-limit self)))
+ (let ((time (if (thread/next self)
+ 0
+ (or next-scheduled-timeout
+ (no-threads-nor-timers)))))
(trace ";run-gtk until "time"\n")
((ucode-primitive run-gtk 2)
(select-registry-handle io-registry) time)
(yield-current-thread)
(gtk-thread-loop)))))))
-(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 (no-threads-nor-timers)
+ (error "gtk-thread: no threads, no timers: "next-scheduled-timeout))
(define (kill-gtk-thread)
(let ((thread gtk-thread))
],
[AC_MSG_RESULT([no])])
fi
+
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+AC_MSG_CHECKING([for gtk])
+if test "${with_gtk}" = "yes"; then
+ AC_MSG_RESULT([by request: yes])
+fi
+if test "${with_gtk}" = "auto"; then
+ if test "${PKG_CONFIG}" != yes; then
+ AC_MSG_RESULT([no pkg-config: no])
+ with_gtk=no
+ elif ! "${MIT_SCHEME_EXE}" --eval "(load-option'FFI)" \
+ </dev/null >/dev/null 2>&1; then
+ AC_MSG_RESULT([no FFI in ${MIT_SCHEME_EXE}: no])
+ with_gtk=no
+ elif ! pkg-config --exists gtk+-2.0; then
+ AC_MSG_RESULT([! pkg-config --exists gtk+-2.0: no])
+ with_gtk=no
+ else
+ AC_MSG_RESULT([yes])
+ with_gtk=yes
+ fi
+fi
+if test "${with_gtk}" = "yes"; then
+ MODULE_TARGETS="${MODULE_TARGETS} prgtkio.so"
+fi
M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1"
fi
-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
#include "osenv.h"
#include "ux.h"
#include "uxio.h"
-#include "uxselect.h"
#include "uxproc.h"
#include <glib.h>
(set-%alien/ctype! alien ctype))
alien)
-(define (guarantee-alien operator object #!optional ctype)
- (let loop ((object object))
- (if (and (alien? object)
- (or (default-object? ctype)
- (equal? (%alien/ctype object) ctype)))
- object
- (loop
- (call-with-current-continuation
- (lambda (continuation)
- (with-restart
- 'USE-VALUE ;name
- "Continue with an alien." ;reporter
- continuation ;effector
- (lambda () ;interactor
- (values
- (prompt-for-evaluated-expression
- "New alien (an expression to be evaluated)")))
- (lambda () ;thunk
- (error:wrong-type-argument
- object "an alien" operator)))))))))
+(declare (integrate-operator guarantee-alien))
+(define (guarantee-alien object operator)
+ (if (not (alien? object))
+ (error:not-alien object operator)))
+
+(define (error:not-alien object operator)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (with-restart
+ 'USE-VALUE ;name
+ "Continue with an alien." ;reporter
+ continuation ;effector
+ (lambda () ;interactor
+ (values
+ (prompt-for-evaluated-expression
+ "New alien (an expression to be evaluated)")))
+ (lambda () ;thunk
+ (error:wrong-type-argument object "an alien" operator))))))
\f
;;; Alien Functions
;; Band ID
band-id)
+(declare (integrate-operator guarantee-alien-function))
+(define (guarantee-alien-function object operator)
+ (if (not (alien-function? object))
+ (error:not-alien-function object operator)))
+
+(define (error:not-alien-function object operator)
+ (error:wrong-type-argument object "an alien function" operator))
+
(define (make-alien-function name library return-type params filename)
(%make-alien-function 0 0 (string-append "Scm_" name)
library return-type params filename #f))
(loop (cdr consts)))))))
(define (call-alien alien-function . args)
- (if (not (alien-function? alien-function))
- (error:bad-range-argument alien-function 'call-alien))
+ (guarantee-alien-function alien-function 'call-alien)
(alien-function-cache! alien-function)
(for-each
(lambda (arg)
(define malloced-aliens '())
(define (free-malloced-aliens)
+ (trace ";free-malloced-aliens: "(length malloced-aliens)" at start\n")
(let loop ((aliens malloced-aliens)
(prev #f))
(if (pair? aliens)
(begin
((ucode-primitive c-free 1) copy)
(alien-null! copy)))
- (loop next prev))))))
+ (loop next prev)))))
+ (trace ";free-malloced-aliens: "(length malloced-aliens)" at end\n"))
(define (reset-malloced-aliens!)
(let loop ((aliens malloced-aliens))
queue-map!
queue->list))
+(define-package (runtime thread-queue)
+ (files "thread-queue")
+ (parent (runtime))
+ (export ()
+ make-thread-queue
+ thread-queue/empty?
+ thread-queue/empty!
+ thread-queue/queue!
+ thread-queue/queue-no-hang!
+ thread-queue/push!
+ thread-queue/dequeue!
+ thread-queue/peek-no-hang
+ thread-queue/peek-until
+ thread-queue/peek))
+
(define-package (runtime simple-file-ops)
(files "sfile")
(parent (runtime))
alien-byte-increment
alien-byte-increment!
guarantee-alien
+ error:not-alien
+ guarantee-alien-function
+ error:not-alien-function
c-peek-cstring
c-peek-cstring!
c-peek-cstringp
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2005, 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.
+
+|#
+
+;;;; Thread-blocking Queues
+;;; package: (runtime thread-queue)
+
+(declare (usual-integrations))
+
+;;; These queues are like the simple queues provided by the (runtime
+;;; simple-queue) package, EXCEPT that they will, when empty, block a
+;;; thread attempting to dequeue an item. Also, a maximum size can be
+;;; specified so that the queue will, when full, block a thread
+;;; attempting to queue an item. Note that #F should not be used as
+;;; an item. Thread-queue/peek-no-hang returns #F if the queue is
+;;; empty.
+;;;
+;;; If multiple threads block on a thread-queue, bad mojo is afoot.
+;;; They are ALL restarted whenever an item becomes available and,
+;;; depending on the thread timer interrupts, ANY ONE of them may be
+;;; able to dequeue the item.
+
+(define-structure (thread-queue (constructor %make-thread-queue)
+ (conc-name %thread-queue/)
+ (print-procedure
+ (standard-unparser-method
+ 'thread-queue
+ (lambda (queue port)
+ (print-thread-queue queue port)))))
+ first-pair
+ last-pair
+ element-count
+ max-elements
+ waiting-queuers
+ waiting-dequeuers)
+
+(define-guarantee thread-queue "a thread-queue")
+
+(define (print-thread-queue queue port)
+ (write-string " elements:" port)
+ (write-string (number->string
+ (%thread-queue/element-count queue)) port)
+ (let ((max (%thread-queue/max-elements queue)))
+ (if max
+ (begin
+ (write-string " max:" port)
+ (write-string (number->string max) port)))))
+
+(define (make-thread-queue #!optional max-size)
+ (let ((max (cond ((default-object? max-size) #f)
+ ((integer? max-size) max-size)
+ (else (error "Max-size must be an integer:" max-size)))))
+ (%make-thread-queue #f #f 0 max '() '())))
+
+(define (thread-queue/empty? queue)
+ (%empty? queue))
+
+(define-integrable (%empty? queue)
+ (zero? (%thread-queue/element-count queue)))
+
+(define (thread-queue/empty! queue)
+ (without-interrupts
+ (lambda ()
+ (if (not (%empty? queue))
+ (begin
+ (set-%thread-queue/first-pair! queue #f)
+ (set-%thread-queue/last-pair! queue #f)
+ (set-%thread-queue/element-count! queue 0)
+ (%resume-queuers queue)))))
+ unspecific)
+
+(define (thread-queue/queue! queue item)
+ (if (not item) (error "Cannot queue #F:" queue))
+ (without-interrupts
+ (lambda ()
+ (do ()
+ ((%queue-no-hang! queue item))
+ (set-%thread-queue/waiting-queuers!
+ queue (append! (%thread-queue/waiting-queuers queue)
+ (list (current-thread))))
+ (suspend-current-thread)))))
+
+(define (thread-queue/queue-no-hang! queue item)
+ ;; Returns #F when QUEUE is maxed out.
+ (if (not item) (error "Cannot queue #F:" queue))
+ (without-interrupts
+ (lambda ()
+ (%queue-no-hang! queue item))))
+
+(define (%queue-no-hang! queue item)
+ (let ((max (%thread-queue/max-elements queue)))
+ (if max
+ (if (< (%thread-queue/element-count queue) max)
+ (%queue! queue item)
+ #f)
+ (%queue! queue item))))
+
+(define (thread-queue/dequeue! queue)
+ (without-interrupts
+ (lambda ()
+ (do ()
+ ((and (not (%empty? queue))
+ (%dequeue! queue)))
+ (set-%thread-queue/waiting-dequeuers!
+ queue (append! (%thread-queue/waiting-dequeuers queue)
+ (list (current-thread))))
+ (suspend-current-thread)))))
+
+(define (thread-queue/peek-no-hang queue #!optional timeout)
+ (guarantee-thread-queue queue 'thread-queue/peek-no-hang)
+ (if (not (default-object? timeout))
+ (guarantee-non-negative-fixnum timeout 'thread-queue/peek-no-hang))
+ (let ((timeout (if (default-object? timeout) 0 timeout))
+ (time (real-time-clock)))
+ (thread-queue/peek-until queue (+ time timeout))))
+
+(define (thread-queue/peek-until queue time)
+ (guarantee-thread-queue queue 'thread-queue/peek-until)
+ (guarantee-integer time 'thread-queue/peek-until)
+ (without-interrupts
+ (lambda ()
+ (let loop ()
+ (if (not (%empty? queue))
+ (car (%thread-queue/first-pair queue))
+ (let ((now (real-time-clock)))
+ (if (<= time now)
+ #f
+ (begin
+ (register-timer-event (- time now) (lambda () unspecific))
+ (suspend-current-thread)
+ (loop)))))))))
+
+(define (thread-queue/peek queue)
+ (without-interrupts
+ (lambda ()
+ (do ()
+ ((and (not (%empty? queue))
+ (car (%thread-queue/first-pair queue))))
+ (set-%thread-queue/waiting-dequeuers!
+ queue (append! (%thread-queue/waiting-dequeuers queue)
+ (list (current-thread))))
+ (suspend-current-thread)))))
+\f
+
+(define (%queue! queue item)
+ (let ((last (%thread-queue/last-pair queue))
+ (new (cons item '())))
+ (if last (set-cdr! last new))
+ (set-%thread-queue/last-pair! queue new)
+ (if (not (%thread-queue/first-pair queue))
+ (set-%thread-queue/first-pair! queue new)))
+ (set-%thread-queue/element-count!
+ queue (1+ (%thread-queue/element-count queue)))
+ (%resume-dequeuers queue)
+ item)
+
+(define (%dequeue! queue)
+ (let* ((first (%thread-queue/first-pair queue))
+ (item (car first)))
+ (if (eq? first (%thread-queue/last-pair queue))
+ (begin
+ (set-%thread-queue/first-pair! queue #f)
+ (set-%thread-queue/last-pair! queue #f))
+ (set-%thread-queue/first-pair! queue (cdr first)))
+ (set-%thread-queue/element-count!
+ queue (-1+ (%thread-queue/element-count queue)))
+ (%resume-queuers queue)
+ item))
+
+(define (%resume-queuers queue)
+ (do ((queuers (%thread-queue/waiting-queuers queue)
+ (cdr queuers)))
+ ((null? queuers)
+ unspecific)
+ (signal-thread-event (car queuers) (lambda () unspecific)))
+ (set-%thread-queue/waiting-queuers! queue '()))
+
+(define (%resume-dequeuers queue)
+ (do ((dequeuers (%thread-queue/waiting-dequeuers queue)
+ (cdr dequeuers)))
+ ((null? dequeuers)
+ unspecific)
+ (signal-thread-event (car dequeuers) (lambda () unspecific)))
+ (set-%thread-queue/waiting-dequeuers! queue '()))
+
+(define (thread-queue/push! queue item)
+ ;; Place ITEM at the head of the queue, instead of the end.
+ (if (not item) (error "Cannot queue #F:" queue))
+ (without-interrupts
+ (lambda ()
+ (let ((max (%thread-queue/max-elements queue)))
+ (if max
+ (if (< (%thread-queue/element-count queue) max)
+ (%push! queue item)
+ (let ((last (%thread-queue/last-pair queue))
+ (first (%thread-queue/first-pair queue)))
+ (let ((new-last
+ (let before-last ((list first))
+ ;; Assume LIST is always a pair, thus that
+ ;; max > 0, and LAST is in FIRST.
+ (if (eq? (cdr list) last)
+ list
+ (before-last (cdr list))))))
+ (set-cdr! new-last '())
+ (set-%thread-queue/last-pair! queue new-last)
+ (set-car! last item) ;Clobber most recently queued item!
+ (set-cdr! last first)
+ (set-%thread-queue/first-pair! queue last))
+ item))
+ (%push! queue item))))))
+
+(define (%push! queue item)
+ (let* ((first (%thread-queue/first-pair queue))
+ (new (cons item first)))
+ (set-%thread-queue/first-pair! queue new)
+ (if (not (%thread-queue/last-pair queue))
+ (set-%thread-queue/last-pair! queue new))
+ (set-%thread-queue/element-count! queue
+ (1+ (%thread-queue/element-count queue)))
+ (%resume-dequeuers queue)
+ item))
+
+(define (test)
+ ;; Sets up a "producer" thread that puts the letters of the alphabet
+ ;; into a thread-queue, one each 2-3 seconds. A "consumer" thread
+ ;; waits on the queue, printing what it reads.
+ (outf-console ";Thread Queue Test\n")
+ (let ((queue (make-thread-queue)))
+ (create-thread
+ #f
+ (lambda ()
+ (outf-console "; Consumer: "(current-thread)"\n")
+ (let loop ()
+ (outf-console "; Consumer reads.\n")
+ (let ((item (thread-queue/dequeue! queue)))
+ (outf-console "; Consumer read "item"\n")
+ (loop)))))
+ (create-thread
+ #f
+ (lambda ()
+ (outf-console "; Producer: "(current-thread)"\n")
+ (for-each (lambda (item)
+ (outf-console "; Producer: sleeping...\n")
+ (sleep-current-thread 2000)
+ (outf-console "; Producer: queuing "item"...\n")
+ (thread-queue/queue! queue item)
+ (outf-console "; Producer: queued "item"\n"))
+ '(#\a #\b #\c #\d #\e))
+ (outf-console "; Producer done.\n")))))
\ No newline at end of file
(write-char #\space)
(write (enough-namestring reason)))
reasons)))
+ (let ((com (pathname-new-type file "com"))
+ (bci (pathname-new-type file "bci")))
+ (if (file-exists? com) (delete-file com))
+ (if (file-exists? bci) (delete-file bci)))
(fluid-let ((sf/default-syntax-table env))
- (sf file))))))
- (if (pair? sources) sources (list sources)))))
\ No newline at end of file
+ (sf file))
+ #t)
+ #f)))
+ (if (pair? sources) sources (list sources)))))
+
+(define (sf-package-set filename)
+ (let* ((os-type microcode-id/operating-system)
+ (pmodel (read-package-model filename os-type))
+ (pathname (pmodel/pathname pmodel)))
+
+ (define (environment file)
+ (->environment
+ (let loop ((cps (pmodel/cref-packages pmodel)))
+ (if (pair? cps)
+ (if (find (lambda (f) (pathname=? f file))
+ (cref-package/files (car cps)))
+ (cref-package/name (car cps))
+ (loop (cdr cps)))
+ (error "No cref-package for file:" file)))))
+
+ (define (dependencies file)
+ (cref-package/depends-on
+ (find (lambda (p)
+ (find (lambda (f) (pathname=? f file)) (cref-package/files p)))
+ (pmodel/cref-packages pmodel))))
+
+ (let ((pmodel-decls (pmodel/declarations pmodel)))
+ (with-working-directory-pathname (directory-pathname pathname)
+ (lambda ()
+
+ (define (deps->decls deps)
+ (let ((decls
+ (append-map!
+ (lambda (dep)
+ (if (equal? "ext" (pathname-type dep))
+ `((integrate-external ,(pathname-new-type dep #f)))
+ '()))
+ deps)))
+ (append pmodel-decls decls)))
+
+ (define (process-file file)
+ (let ((deps (dependencies file))
+ (env (environment file)))
+ (fluid-let ((sf/default-declarations
+ (append (deps->decls deps) sf/default-declarations)))
+ (sf-with-dependencies file deps env)
+ (load file env))))
+
+ (define (make-packages)
+ (let ((existing
+ (let loop ((packages (pmodel/cref-packages pmodel)))
+ (if (pair? packages)
+ (or (name->package (cref-package/name (car packages)))
+ (loop (cdr packages)))
+ #f))))
+ (if existing
+ (warn "Package already exists:" (package/name existing))
+ ;; Build an empty package for use at syntax-time.
+ (construct-packages-from-file
+ (construct-external-descriptions pmodel)))))
+
+ (make-packages)
+ (for-each process-file
+ (append-map cref-package/files
+ (pmodel/cref-packages pmodel))))))))
\ No newline at end of file
(declare (usual-integrations))
+(load-option 'CREF)
(with-loader-base-uri (system-library-uri "sf/")
(lambda ()
(load-package-set "sf")
;;;; SF Packaging
\f
(global-definitions "../runtime/runtime")
+(global-definitions "../cref/cref")
(define-package (scode-optimizer)
(files "pthmap"
(define-package (scode-optimizer build-utilities)
(files "butils")
(parent ())
+ (import (cross-reference)
+ construct-external-descriptions
+ (cref-package/depends-on package/depends-on)
+ (cref-package/files package/files)
+ (cref-package/name package/name)
+ (pmodel/cref-packages pmodel/packages)
+ pmodel/declarations
+ pmodel/pathname
+ read-package-model)
(export ()
compile-directory
compile-directory?
sf-conditionally
sf-with-dependencies
sf-directory
- sf-directory?))
\ No newline at end of file
+ sf-directory?
+ sf-package-set))
\ No newline at end of file
projects / mit-scheme.git / commitdiff