--- /dev/null
+# Copyright (C) 2014 Matthew Birkholz
+#
+# This file is part of an extension to 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.
+
+MITSCHEME_EXE = mit-scheme
+exe = '$(MITSCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+prefix = @prefix@
+datarootdir = @datarootdir@
+infodir = @infodir@
+
+all: cairo-shim.so cairo-types.bin cairo-const.bin
+ echo '(load "compile")' | $(exe)
+ @if [ -s cairo-unx.crf ]; then \
+ echo "cairo-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check:
+ ( echo '(begin'; \
+ echo ' (load "check")'; \
+ echo ' (load "check-doc"))' ) | $(exe)
+
+doc: mit-scheme-cairo.info
+doc: mit-scheme-cairo.html
+
+mit-scheme-cairo.info: cairo.texinfo
+ makeinfo --no-split --output=$@ $^
+
+mit-scheme-cairo.html: cairo.texinfo
+ makeinfo --html --no-split --output=$@ $^
+
+.PHONY: all check doc
+
+install:
+ ( echo '(begin'; \
+ echo ' (install-shim "$(DESTDIR)" "cairo")'; \
+ echo ' (install-load-option "$(DESTDIR)" "cairo"))' ) \
+ | $(exe) -- *.com *.bci *.pkd make.scm
+
+install-info: mit-scheme-cairo.info
+ install $< $(DESTDIR)$(infodir)/
+ install-info $< $(DESTDIR)$(infodir)/dir
+
+install-html: mit-scheme-cairo.html
+ echo "(install-html \"$(DESTDIR)\" \"GNOME interface\")" | $(exe) -- $<
+
+.PHONY: install install-info install-html
+
+clean:
+ rm -f cairo-const.scm cairo-const cairo-const.c cairo-shim.c
+ rm -f cairo-*.crf cairo-*.fre cairo-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f mit-scheme-cairo.html mit-scheme-cairo.info
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+tags:
+ etags *.h \
+ `echo *.c | sed 's/ cairo-const.c//; s/ cairo-shim.c//'` \
+ `echo *.scm | sed 's/ cairo-const.scm//'` \
+ -r '/^([^iI].*/' Includes/*.cdecl
+
+.PHONY: clean distclean maintainer-clean tags
+
+cairo-shim.so: cairo-shim.o
+ echo "(link-shim)" | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
+ `pkg-config --libs cairo`
+
+cairo-shim.o: cairo-shim.c
+ echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
+ `pkg-config --cflags pangocairo` -c $<
+
+cairo-shim.c cairo-const.c cairo-types.bin: cairo.cdecl
+ echo '(generate-shim "cairo" "#include <pango/pangocairo.h>")' | $(exe)
+
+cairo-const.bin: cairo-const.scm
+ echo '(sf "cairo-const")' | $(exe)
+
+cairo-const.scm: cairo-const
+ ./cairo-const
+
+cairo-const: cairo-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+cairo-const.o: cairo-const.c
+ $(CC) $(CPPFLAGS) $(CFLAGS) `pkg-config --cflags pangocairo` -c $<
--- /dev/null
+The Cairo vector graphics plugin.
+
+To build:
+
+ ./configure
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path, and re-writes the optiondb.scm
+found there. You can override the default command name "mit-scheme"
+(and thus the system library path) by setting MITSCHEME_EXE.
+
+For more information see the accompanying user / reference manual.
--- /dev/null
+(warn "No Cairo plugin tests!")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test optiondb, includes the installed system's optiondb.
+
+(define-load-option 'CAIRO
+ (let ((pathname
+ (merge-pathnames "make"
+ (directory-pathname (current-load-pathname)))))
+ (named-lambda (cairo-option-loader)
+ (load pathname))))
+
+(further-load-options
+ (merge-pathnames "optiondb"
+ (last (access library-directory-path
+ (->environment '(runtime pathname))))))
\ No newline at end of file
#| -*-Scheme-*-
-cairo/cairo.h |#
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2014 Matthew Birkholz
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for cairo-shim.so.
+\f
(typedef cairo_matrix_t
(struct _cairo_matrix
(xx double) (yx double)
(extern void
cairo_pattern_add_color_stop_rgba
(pattern (* cairo_pattern_t))
- (offset double) (red double)(green double)(blue double)(alpha double))
\ No newline at end of file
+ (offset double) (red double)(green double)(blue double)(alpha double))
+\f
+;;;; pangocairo
+
+(extern (* PangoLayout) pango_cairo_create_layout (cr (* cairo_t)))
+(extern void pango_cairo_update_layout (cr (* cairo_t))(layout (* PangoLayout)))
+(extern void pango_cairo_show_layout (cr (* cairo_t))(layout (* PangoLayout)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+
+|#
+
+;;;; Cairo System Packaging
+
+(global-definitions runtime/)
+(global-definitions sos/)
+(global-definitions glib/)
+(global-definitions pango/)
+
+(define-package (cairo)
+ (parent (glib))
+ (files "cairo")
+ (import (pango)
+ pango-color-parse
+ guarantee-pango-layout)
+ (export ()
+ cairo-image-surface-create
+ cairo-surface-destroy
+ cairo-surface-write-to-png
+ cairo-surface-flush
+ cairo-pattern-create-linear
+ cairo-pattern-create-radial
+ cairo-pattern-destroy
+ cairo-pattern-add-color-stop
+ cairo-create
+ cairo-destroy
+ cairo-save
+ cairo-restore
+ cairo-translate
+ cairo-scale
+ cairo-set-source-color
+ cairo-set-source
+ cairo-set-source-surface
+ cairo-clip
+ cairo-reset-clip
+ cairo-clip-extents
+ cairo-move-to
+ cairo-close-path
+ cairo-new-sub-path
+ cairo-set-operator
+ cairo-set-line-width
+ cairo-set-dash
+ cairo-line-to cairo-rel-line-to
+ cairo-rectangle
+ cairo-arc
+ cairo-show-pango-layout
+ cairo-show-text
+ cairo-paint
+ cairo-fill cairo-fill-preserve
+ cairo-stroke cairo-stroke-preserve
+ cairo-set-font-matrix
+ cairo-matrix))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2012, 2013 Matthew Birkholz
+Copyright (C) 2012, 2013, 2014 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
;;;; Cairo interface.
;;; package: (gtk cairo)
+(C-include "cairo")
+
(define (cairo-image-surface-create width height)
(let ((surface (make-alien '|cairo_surface_t|))
(copy (make-alien '|cairo_surface_t|)))
(let ((c (->color color 'cairo-pattern-add-color-stop)))
(C-call "cairo_pattern_add_color_stop_rgba" pattern (->flonum offset)
(color-red c) (color-green c) (color-blue c) (color-alpha c))))
+
+(define (->color spec operator)
+ (cond ((color? spec) spec)
+ ((string? spec)
+ (pango-color-parse spec))
+ (else
+ (error:wrong-type-argument spec "a color spec" operator))))
\f
(define (cairo-create surface)
(guarantee-cairo-surface surface 'cairo-create)
(check-cairo-status cairo)
cairo))
-(define (gdk-cairo-create GdkWindow)
- (let ((cairo (make-alien '|cairo_t|))
- (copy (make-alien '|cairo_t|)))
- (add-gc-cleanup cairo (make-cairo-cleanup copy))
- (C-call "gdk_cairo_create" copy GdkWindow)
- (copy-alien-address! cairo copy)
- (check-cairo-status cairo)
- cairo))
-
(define (make-cairo-cleanup alien)
(named-lambda (cairo-cleanup)
;;without-interrupts
object
(error:wrong-type-argument object "a cairo_t alien" operator)))
+(define (cairo-save cairo)
+ (guarantee-cairo cairo 'cairo-save)
+ (C-call "cairo_save" cairo))
+
+(define (cairo-restore cairo)
+ (guarantee-cairo cairo 'cairo-save)
+ (C-call "cairo_restore" cairo))
+
(define (cairo-translate cairo dx dy)
- (guarantee-cairo cairo 'cairo-set-source)
+ (guarantee-cairo cairo 'cairo-translate)
(C-call "cairo_translate" cairo (->flonum dx) (->flonum dy)))
(define (cairo-scale cairo sx sy)
- (guarantee-cairo cairo 'cairo-set-source)
+ (guarantee-cairo cairo 'cairo-scale)
(C-call "cairo_scale" cairo (->flonum sx) (->flonum sy)))
(define (cairo-set-source-color cairo color)
(guarantee-cairo-pattern pattern 'cairo-set-source)
(C-call "cairo_set_source" cairo pattern))
+(define (cairo-set-source-surface cairo surface x y)
+ (guarantee-cairo cairo 'cairo-set-source-surface)
+ (guarantee-cairo-surface surface 'cairo-set-source-surface)
+ (C-call "cairo_set_source_surface" cairo surface (->flonum x) (->flonum y)))
+
+(define (cairo-reset-clip cairo)
+ (guarantee-cairo cairo 'cairo-reset-clip)
+ (C-call "cairo_reset_clip" cairo))
+
+(define (cairo-clip cairo)
+ (guarantee-cairo cairo 'cairo-clip)
+ (C-call "cairo_clip" cairo))
+
(define-integrable (cairo-clip-extents cairo receiver)
(let ((doubles (malloc (fix:* 4 (C-sizeof "double")) 'double)))
(let ((y1 (C-array-loc doubles "double" 1))
(receiver x1. y1. x2. y2.)))))
(define (cairo-move-to cairo x y)
- (guarantee-cairo cairo 'cairo-new-sub-path)
+ (guarantee-cairo cairo 'cairo-move-to)
(let ((x (->flonum x))
(y (->flonum y)))
(C-call "cairo_move_to" cairo x y)))
+(define (cairo-close-path cairo)
+ (guarantee-cairo cairo 'cairo-close-path)
+ (C-call "cairo_close_path" cairo))
+
(define (cairo-new-sub-path cairo)
(guarantee-cairo cairo 'cairo-new-sub-path)
(C-call "cairo_new_sub_path" cairo))
+(define (cairo-set-operator cairo operator)
+ (guarantee-cairo cairo 'cairo-set-operator)
+ (C-call "cairo_set_operator" cairo
+ (case operator
+ ((CLEAR) (C-enum "CAIRO_OPERATOR_CLEAR"))
+ ((SOURCE) (C-enum "CAIRO_OPERATOR_SOURCE"))
+ ((OVER) (C-enum "CAIRO_OPERATOR_OVER"))
+ ((IN) (C-enum "CAIRO_OPERATOR_IN"))
+ ((OUT) (C-enum "CAIRO_OPERATOR_OUT"))
+ ((ATOP) (C-enum "CAIRO_OPERATOR_ATOP"))
+ ((DEST) (C-enum "CAIRO_OPERATOR_DEST"))
+ ((DEST-OVER) (C-enum "CAIRO_OPERATOR_DEST_OVER"))
+ ((DEST-IN) (C-enum "CAIRO_OPERATOR_DEST_IN"))
+ ((DEST-OUT) (C-enum "CAIRO_OPERATOR_DEST_OUT"))
+ ((DEST-ATOP) (C-enum "CAIRO_OPERATOR_DEST_ATOP"))
+ ((XOR) (C-enum "CAIRO_OPERATOR_XOR"))
+ ((ADD) (C-enum "CAIRO_OPERATOR_ADD"))
+ ((SOURCE) (C-enum "CAIRO_OPERATOR_SOURCE"))
+ ((SATURATE) (C-enum "CAIRO_OPERATOR_SATURATE"))
+ ((MULTIPLY) (C-enum "CAIRO_OPERATOR_MULTIPLY"))
+ ((SCREEN) (C-enum "CAIRO_OPERATOR_SCREEN"))
+ ((OVERLAY) (C-enum "CAIRO_OPERATOR_OVERLAY"))
+ ((DARKEN) (C-enum "CAIRO_OPERATOR_DARKEN"))
+ ((LIGHTEN) (C-enum "CAIRO_OPERATOR_LIGHTEN"))
+ ((COLOR-DODGE) (C-enum "CAIRO_OPERATOR_COLOR_DODGE"))
+ ((COLOR-BURN) (C-enum "CAIRO_OPERATOR_COLOR_BURN"))
+ ((HARD-LIGHT) (C-enum "CAIRO_OPERATOR_HARD_LIGHT"))
+ ((SOFT-LIGHT) (C-enum "CAIRO_OPERATOR_SOFT_LIGHT"))
+ ((DIFFERENCE) (C-enum "CAIRO_OPERATOR_DIFFERENCE"))
+ ((EXCLUSION) (C-enum "CAIRO_OPERATOR_EXCLUSION"))
+ ((HSL-HUE) (C-enum "CAIRO_OPERATOR_HSL_HUE"))
+ ((HSL-SATURATION) (C-enum "CAIRO_OPERATOR_HSL_SATURATION"))
+ ((HSL-COLOR) (C-enum "CAIRO_OPERATOR_HSL_COLOR"))
+ ((HSL-LUMINOSITY) (C-enum "CAIRO_OPERATOR_HSL_LUMINOSITY"))
+ (else (error:wrong-type-argument operator "a drawing operator"
+ 'cairo-set-operator)))))
+
+(define (cairo-set-line-width cairo width)
+ (guarantee-cairo cairo 'cairo-set-line-width)
+ (C-call "cairo_set_line_width" cairo (->flonum width)))
+
+(define (cairo-set-dash cairo dashes)
+ (guarantee-cairo cairo 'cairo-set-dash)
+ (let* ((num (length dashes))
+ (alien (malloc (fix:* num (C-sizeof "double")) 'double))
+ (scan (copy-alien alien)))
+ (for-each
+ (lambda (len)
+ (C->= scan "double" (->flonum len))
+ (alien-byte-increment! scan (C-sizeof "double")))
+ dashes)
+ (C-call "cairo_set_dash" cairo alien num 0)
+ (free alien)))
+
+(define (cairo-line-to cairo x y)
+ (guarantee-cairo cairo 'cairo-line-to)
+ (let ((x (->flonum x))
+ (y (->flonum y)))
+ (C-call "cairo_rel_line_to" cairo x y)))
+
+(define (cairo-rel-line-to cairo dx dy)
+ (guarantee-cairo cairo 'cairo-rel-line-to)
+ (let ((dx (->flonum dx))
+ (dy (->flonum dy)))
+ (C-call "cairo_rel_line_to" cairo dx dy)))
+
+(define (cairo-rectangle cairo x y width height)
+ (guarantee-cairo cairo 'cairo-rectangle)
+ (C-call "cairo_rectangle" cairo
+ (->flonum x) (->flonum y) (->flonum width) (->flonum height)))
+
(define (cairo-arc cairo xc yc radius start-angle end-angle)
- (guarantee-cairo cairo 'cairo-set-source)
+ (guarantee-cairo cairo 'cairo-arc)
(C-call "cairo_arc" cairo (->flonum xc) (->flonum yc) (->flonum radius)
(->flonum start-angle) (->flonum end-angle)))
+(define (cairo-show-pango-layout cairo layout)
+ (guarantee-cairo cairo 'cairo-pango-layout)
+ (guarantee-pango-layout layout 'cairo-pango-layout)
+ (C-call "pango_cairo_show_layout" cairo (gobject-alien layout)))
+
+(define (cairo-show-text cairo string)
+ (guarantee-cairo cairo 'cairo-show-text)
+ (guarantee-string string 'cairo-show-text)
+ (C-call "cairo_show_text" cairo string))
+
(define (cairo-paint cairo)
(guarantee-cairo cairo 'cairo-paint)
(C-call "cairo_paint" cairo))
(guarantee-cairo cairo 'cairo-fill)
(C-call "cairo_fill" cairo))
+(define (cairo-fill-preserve cairo)
+ (guarantee-cairo cairo 'cairo-fill-preserve)
+ (C-call "cairo_fill_preserve" cairo))
+
(define (cairo-stroke cairo)
(guarantee-cairo cairo 'cairo-stroke)
(C-call "cairo_stroke" cairo))
+(define (cairo-stroke-preserve cairo)
+ (guarantee-cairo cairo 'cairo-stroke-preserve)
+ (C-call "cairo_stroke_preserve" cairo))
+
(define (cairo-set-font-matrix cairo matrix)
(guarantee-cairo cairo 'cairo-set-font-matrix)
(guarantee-cairo-matrix matrix 'cairo-set-font-matrix)
--- /dev/null
+\input texinfo @c -*-Texinfo-*-
+@comment %**start of header
+@setfilename mit-scheme-cairo
+@set VERSION 0.5
+@settitle MIT/GNU Scheme Cairo Plugin @value{VERSION}
+@comment %**end of header
+
+@ifhtml
+@macro bref {name}
+@ref{\name\,,@code{\name\}}
+@end macro
+@end ifhtml
+@ifinfo
+@macro bref {name}
+\name\
+@end macro
+@end ifinfo
+@ifnothtml
+@ifnotinfo
+@macro bref {name}
+@code{\name\}
+@end macro
+@end ifnotinfo
+@end ifnothtml
+
+@copying
+This manual documents MIT/GNU Scheme's @acronym{Cairo} plugin @value{VERSION}.
+
+Copyright @copyright{} 2014 Matthew Birkholz
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.2 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
+and with the Back-Cover Texts as in (a) below. A copy of the
+license is included in the section entitled ``GNU Free Documentation
+License.''
+
+(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
+this GNU Manual, like GNU software. Copies published by the Free
+Software Foundation raise funds for GNU development.''
+@end quotation
+@end copying
+
+@dircategory Programming Languages
+@direntry
+* MIT/GNU Scheme Cairo: (mit-scheme-cairo).
+ Cairo vector graphics plugin.
+@end direntry
+
+@titlepage
+@title The MIT/GNU Scheme Cairo Plugin Manual
+@subtitle Schemely access (@value{VERSION}) to the GNOME toolkits
+@subtitle for MIT/GNU Scheme version 9.1
+@author by Matt Birkholz (@email{birkholz@@alum.mit.edu})
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@ifnottex
+@node Top, Introduction, (dir), (dir)
+@top Cairo Plugin
+
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction::
+* API Reference::
+* Installation::
+* GNU Free Documentation License::
+@end menu
+
+@node Introduction, API Reference, Top, Top
+@chapter Introduction
+
+The Cairo system is a collection of Scheme data types and procedures
+providing a Schemely interface to the Cairo vector graphics library.
+Very little of the library's 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.
+
+@node API Reference, Installation, Introduction, Top
+@chapter API Reference
+
+@menu
+* Cairo Context::
+* Cairo Surface::
+* Cairo Pattern::
+@end menu
+
+@node Cairo Context, Cairo Surface, API Reference, API Reference
+@section Cairo Context
+
+This simple wrapper for @code{cairo_t} objects ensures that the
+toolkit object is de-referenced when the Scheme object is garbage
+collected. The Scheme object is an alien of type @code{cairo_t}.
+
+@deffn Procedure cairo-create surface
+Creates a new cairo context with all graphics state parameters set to
+default values and with @var{surface} as the target surface. The
+context will reference the surface so @bref{cairo-surface-destroy} can
+be called on it if the surface will no longer be used directly.
+@end deffn
+
+@deffn Procedure cairo-destroy cairo
+De-references a @var{cairo} context object. Further operations on
+@var{cairo} will produce an error.
+@end deffn
+
+@deffn Procedure cairo-set-source-color cairo color
+Sets the source pattern within @var{cairo} to @var{color} which will
+then be used for future drawing operations. The default source
+pattern is opaque black.
+@xref{colors}.
+@end deffn
+
+@deffn Procedure cairo-set-source cairo pattern
+Sets the source pattern within @var{cairo} to @var{pattern} which will
+then be used for future drawing operations. The default source is
+solid, opaque black.
+@end deffn
+
+@deffn Procedure cairo-translate cairo dx dy
+Modifies the current transformation matrix of @var{cairo} by
+translating the user-space origin to (dx, dy).
+@end deffn
+
+@deffn Procedure cairo-scale cairo sx sy
+Modifies the current transformation matrix of @var{cairo} by scaling
+the X and Y user-space axes by @var{sx} and @var{sy} respectively.
+@end deffn
+
+@anchor{cairo-move-to}
+@deffn Procedure cairo-move-to cairo x y
+Begin a new sub-path. After this call @var{cairo}'s current point
+will be (@var{x}, @var{y}).
+@end deffn
+
+@anchor{cairo-new-sub-path}
+@deffn Procedure cairo-new-sub-path cairo
+Begins a new sub-path. Note that @var{cairo}'s existing path is not
+affected. After this call there will be no current point.
+
+In many cases, this call is not needed since new sub-paths are
+frequently started with @bref{cairo-move-to}.
+
+A call to @bref{cairo-new-sub-path} is particularly useful when
+beginning a new sub-path with one of the @bref{cairo-arc} calls. This
+makes things easier as it is no longer necessary to manually compute
+the arc's initial coordinates for a call to @bref{cairo-move-to}.
+@end deffn
+
+@anchor{cairo-arc}
+@deffn Procedure cairo-arc cairo x y radius start end
+Adds a circular arc to the current path. The arc is centered at
+(@var{x}, @var{y}), has @var{radius}, begins at @var{start} and
+proceeds in the direction of increasing angles to @var{end}. If
+@var{end} is less than @var{start} it will be progressively increased
+by 2pi until it is greater than @var{start}.
+
+If there is a current point, an initial line segment will be added to
+the path to connect the current point to the beginning of the arc. If
+this initial line is undesired, it can be avoided by calling
+@bref{cairo-new-sub-path} before calling @code{cairo-arc}.
+
+@var{Start} and @var{end} should be given in radians. An angle of 0.0
+is in the direction of the positive X axis (in user space). An angle
+of pi/2 radians (90 degrees) is in the direction of the positive Y
+axis (in user space). With the default transformation matrix, angles
+increase in a clockwise direction.
+@end deffn
+
+@deffn Procedure cairo-paint cairo
+Paints the current source everywhere within the current clip region.
+@end deffn
+
+@deffn Procedure cairo-stroke cairo
+Strokes @var{cairo}'s current path according to the
+current line width, line join, line cap, and dash settings. The
+current path is then cleared.
+@end deffn
+
+@deffn Procedure cairo-fill cairo
+Fills @var{cairo}'s current path according to the current fill rule.
+Each sub-path is implicitly closed before being filled. The current
+path is then cleared.
+@end deffn
+
+@deffn Procedure cairo-clip-extents cairo receiver
+Calls @var{receiver} with the user-space bounding box of the area
+inside @var{cairo}'s current clip. @var{Receiver} will be called with
+four flonums: the left, top, right and bottom bounds of the clip.
+@end deffn
+
+@deffn Procedure cairo-set-font-matrix cairo matrix
+Sets @var{cairo}'s current font matrix to @var{matrix}, which gives a
+transformation from the design space of the font (in this space, the
+em-square is 1 unit by 1 unit) to user space. @var{Matrix} should be
+created using @bref{cairo-matrix}.
+@end deffn
+
+@anchor{cairo-matrix}
+@deffn Procedure cairo-matrix xx yx x0 xy yy y0
+Creates a Cairo transformation matrix. A point @code{(x,y)} is
+transformed by this matrix into @code{(xx * x + xy * y + x0, yx * x +
+yy * y + y0)}.
+@end deffn
+
+@subsection Cairo Colors
+@anchor{colors}
+
+Colors are floating-vectors containing four flonums between 0. and
+1. inclusive: the red, green, blue and alpha components. For example
+@code{#[floating-vector 42 0. 1. 0. 1.]} represents completely opaque
+green.
+
+Colors can also be specified with a string:
+@itemize
+@item A standard color name (per the Cascading Style Sheets standard).
+@item A hex value: 'RGB', 'RRGGBB', 'RRRGGGBBB', or 'RRRRGGGGBBBB'.
+@item An RGB color: 'rgb(R,G,B)' where R, G and B are decimal
+numbers between 0 and 255 inclusive or percentages.
+@item An RGBA color: 'rgba(R,G,B,A)' where R, G and B are numbers or
+percentages as above, and A is a floating point number between 0. and
+1. inclusive.
+@end itemize
+
+@node Cairo Surface, Cairo Pattern, Cairo Context, API Reference
+@section Cairo Surface
+
+This simple wrapper for @code{cairo_surface_t} objects ensures that the
+toolkit object is de-referenced when the Scheme object is garbage
+collected. The Scheme object is an alien of type
+@code{cairo_surface_t}.
+
+@deffn Procedure cairo-image-surface-create width height
+Creates a Cairo image surface @var{width}x@var{height} pixels.
+@end deffn
+
+@anchor{cairo-surface-write-to-png}
+@deffn Procedure cairo-surface-write-to-png surface filename
+Writes @var{surface} to a new file @var{filename} as a PNG image.
+@end deffn
+
+@anchor{cairo-surface-flush}
+@deffn Procedure cairo-surface-flush surface
+Does any pending drawing for @var{surface}. Also restores any
+temporary modifications Cairo has made to the surface's state.
+@end deffn
+
+@anchor{cairo-surface-destroy}
+@deffn Procedure cairo-surface-destroy surface
+De-references a cairo @var{surface} object. Further operations on
+@var{surface} will produce an error.
+@end deffn
+
+@node Cairo Pattern, API Reference, Cairo Surface, API Reference
+@section Cairo Pattern
+
+This simple wrapper for @code{cairo_pattern_t} objects ensures that the
+toolkit object is de-referenced when the Scheme object is garbage
+collected. The Scheme object is an alien of type
+@code{cairo_pattern_t}.
+
+@deffn Procedure cairo-pattern-create-radial x0 y0 radius0 x1 y1 radius1
+Creates a new radial gradient pattern from the circle defined by
+(@var{x0}, @var{y0}, @var{radius0}) to a second circle defined by
+(@var{x1}, @var{y1}, @var{radius1}). Before using the gradient
+pattern, a number of color stops should be defined using
+@bref{cairo-pattern-add-color-stop}.
+@end deffn
+
+@deffn Procedure cairo-pattern-create-linear x0 y0 x1 y1
+Creates a new linear gradient pattern along the line from (@var{x0},
+@var{y0}) to (@var{x1}, @var{y1}). Before using the gradient pattern,
+a number of color stops should be defined using
+@bref{cairo-pattern-add-color-stop}.
+@end deffn
+
+@anchor{cairo-pattern-add-color-stop}
+@deffn Procedure cairo-pattern-add-color-stop pattern offset color
+Adds a color stop to a gradient @var{pattern}. @var{Offset} specifies
+the location along the gradient's control vector. @var{Color} should
+be an RGBA color. @xref{colors}. If two (or more) stops are
+specified with identical offset values, they will be sorted according
+to the order in which the stops are added. Stops added earlier will
+compare less than stops added later. This can be useful for reliably
+making sharp color transitions instead of the typical blend.
+@end deffn
+
+@deffn Procedure cairo-pattern-destroy pattern
+De-references a cairo @var{pattern} object. Further operations on
+@var{pattern} will produce an error.
+@end deffn
+
+@node Installation, GNU Free Documentation License, API Reference, Top
+@chapter Installation
+
+Unpack the source and build in the usual way, but do not call
+@code{./configure} with a @code{--prefix} argument. This plugin will
+be installed in the system library path of the machine run by the
+@code{mit-scheme} command. You can override this command name by
+setting @code{MITSCHEME_EXE}. You can override the system library
+path of any machine by passing it the @code{--library} option on the
+commandline, or the @code{MITSCHEME_LIBRARY_PATH} variable in the
+environment.
+
+@example
+ tar xzf mit-scheme-cairo-0.5.tar.gz
+ cd gtk-0.5
+ ./configure
+ make
+ make check
+ make install
+ make install-info
+ make install-html
+ make install-pdf
+@end example
+
+@node GNU Free Documentation License, , Installation, Top
+@appendix GNU Free Documentation License
+
+@center Version 1.2, November 2002
+
+@display
+Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc.
+51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The ``Document'', below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as ``you''. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject. (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+@sc{ascii} without markup, Texinfo input format, La@TeX{} input
+format, @acronym{SGML} or @acronym{XML} using a publicly available
+@acronym{DTD}, and standard-conforming simple @acronym{HTML},
+PostScript or @acronym{PDF} designed for human modification. Examples
+of transparent image formats include @acronym{PNG}, @acronym{XCF} and
+@acronym{JPG}. Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, @acronym{SGML} or
+@acronym{XML} for which the @acronym{DTD} and/or processing tools are
+not generally available, and the machine-generated @acronym{HTML},
+PostScript or @acronym{PDF} produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''. You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warrany Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License. Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License. However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+@end enumerate
+
+@page
+@appendixsec ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+ Copyright (C) @var{year} @var{your name}.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.2
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+ A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with...Texts.'' line with this:
+
+@smallexample
+@group
+ with the Invariant Sections being @var{list their titles}, with
+ the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+ being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@bye
--- /dev/null
+#| -*-Scheme-*-
+
+ Check that every binding exported to () has a
+ corresponding @deffn in cairo.texinfo. |#
+
+(load-option 'cref)
+(define read-package-model)
+(define pmodel/packages)
+(define package/name)
+(define package/bindings)
+(define package/links)
+(define link/source)
+(define link/destination)
+(define binding/package)
+(define binding/name)
+(let ((cref (->environment '(cross-reference))))
+ (set! read-package-model (access read-package-model cref))
+ (set! pmodel/packages (access pmodel/packages cref))
+ (set! package/name (access package/name cref))
+ (set! package/bindings (access package/bindings cref))
+ (set! package/links (access package/links cref))
+ (set! link/source (access link/source cref))
+ (set! link/destination (access link/destination cref))
+ (set! binding/package (access binding/package cref))
+ (set! binding/name (access binding/name cref)))
+
+(define (deffn-name line)
+ (let ((regs (re-string-match
+ (string-append "@deffnx?"
+ " \\(Class\\|Procedure\\|{Generic Procedure}\\)"
+ " \\([-A-Za-z0-9<>?!+./:]+\\)")
+ line)))
+ (if regs
+ (intern (re-match-extract line regs 2))
+ (error "Could not find binding name:" line))))
+
+(define (texinfo-deffns lines)
+ (let ((len (vector-length lines)))
+ (let loop ((i 0) (deffns '()))
+ (if (fix:< i len)
+ (let ((line (vector-ref lines i)))
+ (loop (fix:1+ i)
+ (if (string-prefix? "@deffn" line)
+ (cons (deffn-name line) deffns)
+ deffns)))
+ deffns))))
+
+(define (read-lines port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ '()
+ (cons line (loop))))))
+
+(define (pmodel/find-package pmodel package-name)
+ (find-matching-item (pmodel/packages pmodel)
+ (lambda (p) (equal? package-name (package/name p)))))
+
+(define (pmodel/global-exports pmodel)
+ (define (global-exports package)
+ (append-map! (lambda (link)
+ (if (eq? '() (package/name
+ (binding/package
+ (link/destination link))))
+ (list (binding/name (link/destination link)))
+ '()))
+ (package/links package)))
+ (append-map! global-exports (pmodel/packages pmodel)))
+
+(define (pmodel/package-bindings pmodel package-name)
+ (let ((package (pmodel/find-package pmodel package-name)))
+ (if package
+ (map binding/name (package/bindings package))
+ (error "No such package:" package-name))))
+
+(define (duplicates listset)
+ (let loop ((items listset) (duplicates '()))
+ (cond ((null? items)
+ (reverse! duplicates))
+ ((memq (car items) (cdr items))
+ (if (memq (car items) duplicates)
+ (loop (cdr items) duplicates)
+ (loop (cdr items) (cons (car items) duplicates))))
+ (else
+ (loop (cdr items) duplicates)))))
+
+(define (minus set1 set2)
+ (let loop ((items set1) (difference '()))
+ (cond ((null? items)
+ difference)
+ ((memq (car items) set2)
+ (loop (cdr items) difference))
+ (else
+ (loop (cdr items) (cons (car items) difference))))))
+
+(define (check)
+ (let* ((texinfo (list->vector (call-with-input-file "cairo.texinfo"
+ read-lines)))
+ (deffns (texinfo-deffns texinfo))
+ (dups (duplicates deffns))
+ (pmodel (read-package-model "cairo" microcode-id/operating-system))
+ (bindings (pmodel/global-exports pmodel))
+ (missing (minus bindings deffns))
+ (extras (minus deffns bindings)))
+ (if (not (null? dups))
+ (for-each (lambda (name) (warn "multiple-descriptions:" name)) dups))
+ (if (not (null? extras))
+ (for-each (lambda (name) (warn "not bound:" name)) extras))
+ (if (not (null? missing))
+ (for-each (lambda (name) (warn "not documented:" name)) missing))))
+
+(check)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the cairo wrapper.
+
+(let ((env (->environment '(runtime pathname)))
+ (dirname (directory-pathname (current-load-pathname))))
+ (set! (access library-directory-path env)
+ (cons dirname (access library-directory-path env)))
+ (set! *initial-options-file* (merge-pathnames "cairo-optiondb" dirname)))
+
+(load-option 'CAIRO)
+(load "cairo-check" (->environment '(CAIRO)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+
+|#
+
+;;;; Compile the Cairo wrapper.
+
+(load-option 'CREF)
+(load-option 'PANGO)
+(load-option 'FFI)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (with-system-library-directories
+ '("./")
+ (lambda ()
+ (if (name->package '(CAIRO))
+ (error "The Cairo package already exists.")
+ (let ((package-set (package-set-pathname "cairo")))
+ (if (not (file-modification-time<? "cairo.pkg" package-set))
+ (cref/generate-trivial-constructor "cairo"))
+ (construct-packages-from-file (fasload package-set))))
+
+ (compile-file "cairo" '("cairo-const.bin")
+ (->environment '(cairo)))
+
+ (cref/generate-constructors "cairo" 'ALL)))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme Cairo interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-cairo])
+AC_CONFIG_SRCDIR([cairo.pkg])
+
+AC_COPYRIGHT(
+[Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+])
+
+AH_TOP([/*
+
+Copyright (C) 2014 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.
+
+*/])
+
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+
+if ! pkg-config --exists cairo 2>/dev/null; then
+ AC_MSG_ERROR([Cairo not found.])
+fi
+
+AC_SUBST([CFLAGS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_SUBST([LIBS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+#| -*-Scheme-*-
+
+Load the Cairo option. |#
+
+(load-option 'PANGO)
+(with-loader-base-uri (system-library-uri "cairo/")
+ (lambda ()
+ (load-package-set "cairo")))
+(add-subsystem-identification! "Cairo" '(0 5))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+glib-2.0/glib-object.h |#
+
+;;; topmost include file for GObject header files
+
+;(include "gobject/gbinding")
+;(include "gobject/gboxed")
+(include "gobject/genums")
+(include "gobject/gobject")
+(include "gobject/gparam")
+(include "gobject/gparamspecs")
+(include "gobject/gsignal")
+;(include "gobject/gsourceclosure")
+(include "gobject/gtype")
+;(include "gobject/gtypemodule")
+;(include "gobject/gtypeplugin")
+(include "gobject/gvalue")
+;(include "gobject/gvaluearray")
+(include "gobject/gvaluetypes")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+glib-2.0/glib.h |#
+
+;(include "glib/galloca")
+;(include "glib/garray")
+;(include "glib/gasyncqueue")
+;(include "glib/gatomic")
+;(include "glib/gbacktrace")
+;(include "glib/gbase64")
+;(include "glib/gbitlock")
+;(include "glib/gbookmarkfile")
+;(include "glib/gcache")
+;(include "glib/gchecksum")
+;(include "glib/gcompletion")
+;(include "glib/gconvert")
+;(include "glib/gdataset")
+;(include "glib/gdate")
+;(include "glib/gdatetime")
+;(include "glib/gdir")
+(include "glib/gerror")
+;(include "glib/gfileutils")
+;(include "glib/ghash")
+;(include "glib/ghook")
+;(include "glib/ghostutils")
+;(include "glib/giochannel")
+;(include "glib/gkeyfile")
+(include "glib/glist")
+;(include "glib/gmacros")
+;(include "glib/gmain")
+;(include "glib/gmappedfile")
+;(include "glib/gmarkup")
+;(include "glib/gmem")
+;(include "glib/gmessages")
+;(include "glib/gnode")
+;(include "glib/goption")
+;(include "glib/gpattern")
+;(include "glib/gpoll")
+;(include "glib/gprimes")
+;(include "glib/gqsort")
+(include "glib/gquark")
+;(include "glib/gqueue")
+;(include "glib/grand")
+;(include "glib/grel")
+;(include "glib/gregex")
+;(include "glib/gscanner")
+;(include "glib/gsequence")
+;(include "glib/gshell")
+;(include "glib/gslice")
+;(include "glib/gslist")
+;(include "glib/gspawn")
+;(include "glib/gstrfuncs")
+;(include "glib/gstring")
+;(include "glib/gtestutils")
+;(include "glib/gthread")
+;(include "glib/gthreadpool")
+;(include "glib/gtimer")
+;(include "glib/gtree")
+(include "glib/gtypes")
+;(include "glib/gunicode")
+;(include "glib/gurifuncs")
+;(include "glib/gutils")
+(include "glib/gvariant")
\ No newline at end of file
--- /dev/null
+# Copyright (C) 2014 Matthew Birkholz
+#
+# This file is part of an extension to 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.
+
+MITSCHEME_EXE = mit-scheme
+exe = '$(MITSCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+prefix = @prefix@
+datarootdir = @datarootdir@
+infodir = @infodir@
+
+all: glib-shim.so glib-types.bin glib-const.bin
+ echo '(load "compile")' | $(exe)
+ @if [ -s glib-unx.crf ]; then \
+ echo "glib-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check:
+ ( echo '(begin'; \
+ echo ' (load "check")'; \
+ echo ' (load "check-doc"))' ) | $(exe)
+
+doc: mit-scheme-glib.info
+doc: mit-scheme-glib.html
+
+mit-scheme-glib.info: glib.texinfo
+ makeinfo --no-split --output=$@ $^
+
+mit-scheme-glib.html: glib.texinfo
+ makeinfo --html --no-split --output=$@ $^
+
+.PHONY: all check doc
+
+install:
+ ( echo '(begin'; \
+ echo ' (install-shim "$(DESTDIR)" "glib")'; \
+ echo ' (install-load-option "$(DESTDIR)" "glib"))' ) \
+ | $(exe) -- *.com *.bci *.pkd make.scm
+
+install-info: mit-scheme-glib.info
+ install $< $(DESTDIR)$(infodir)/
+ install-info $< $(DESTDIR)$(infodir)/dir
+
+install-html: mit-scheme-glib.html
+ echo "(install-html \"$(DESTDIR)\" \"GNOME interface\")" | $(exe) -- $<
+
+.PHONY: install install-info install-html
+
+clean:
+ rm -f glib-const.scm glib-const glib-const.c glib-shim.c
+ rm -f glib-*.crf glib-*.fre glib-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f mit-scheme-glib.html mit-scheme-glib.info
+
+distclean: clean
+ rm -f Makefile config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure
+ rm -rf autom4te.cache
+
+tags:
+ etags *.h \
+ `echo *.c | sed 's/ glib-const.c//; s/ glib-shim.c//'` \
+ `echo *.scm | sed 's/ glib-const.scm//'` \
+ -r '/^([^iI].*/' Includes/*.cdecl
+
+.PHONY: clean distclean maintainer-clean tags
+
+glib-shim.so: glib-shim.o glibio.o
+ echo "(link-shim)" | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
+ `pkg-config --libs glib-2.0 gthread-2.0 gio-2.0`
+
+glibio.o: glibio.c
+ echo "(compile-shim)" | $(exe) -- `pkg-config --cflags gio-2.0` -c $<
+
+glib-shim.o: glib-shim.c glib-shim.h
+ echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
+ `pkg-config --cflags gio-2.0` -c $<
+
+glib-shim.c glib-const.c glib-types.bin: glib-shim.h glib.cdecl \
+ Includes/*.cdecl Includes/*/*.cdecl
+ echo '(generate-shim "glib" "#include \"glib-shim.h\"")' | $(exe)
+
+glib-const.bin: glib-const.scm
+ echo '(sf "glib-const")' | $(exe)
+
+glib-const.scm: glib-const
+ ./glib-const
+
+glib-const: glib-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+glib-const.o: glib-const.c glib-shim.h
+ $(CC) $(CPPFLAGS) $(CFLAGS) `pkg-config --cflags gio-2.0` -c $<
--- /dev/null
+The GLib GNOME utility library plugin.
+
+To build:
+
+ ./configure...
+ make all check
+ make install install-info install-html
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path, and re-writes the optiondb.scm
+found there. You can override the default command name "mit-scheme"
+(and thus the system library path) by setting MITSCHEME_EXE.
+
+For more information see the accompanying user / reference manual.
--- /dev/null
+#| -*-Scheme-*-
+
+ Check that every binding in (glib) or exported to () has a
+ corresponding @deffn in glib.texinfo. |#
+
+(load-option 'cref)
+(define read-package-model)
+(define pmodel/packages)
+(define package/name)
+(define package/bindings)
+(define package/links)
+(define link/source)
+(define link/destination)
+(define binding/package)
+(define binding/name)
+(let ((cref (->environment '(cross-reference))))
+ (set! read-package-model (access read-package-model cref))
+ (set! pmodel/packages (access pmodel/packages cref))
+ (set! package/name (access package/name cref))
+ (set! package/bindings (access package/bindings cref))
+ (set! package/links (access package/links cref))
+ (set! link/source (access link/source cref))
+ (set! link/destination (access link/destination cref))
+ (set! binding/package (access binding/package cref))
+ (set! binding/name (access binding/name cref)))
+
+(define (deffn-name line)
+ (let ((regs (re-string-match
+ (string-append "@deffnx?"
+ " \\(Class\\|Procedure\\|{Generic Procedure}\\)"
+ " \\([-A-Za-z0-9<>?!+./:]+\\)")
+ line)))
+ (if regs
+ (intern (re-match-extract line regs 2))
+ (error "Could not find binding name:" line))))
+
+(define (texinfo-deffns lines)
+ (let ((len (vector-length lines)))
+ (let loop ((i 0) (deffns '()))
+ (if (fix:< i len)
+ (let ((line (vector-ref lines i)))
+ (loop (fix:1+ i)
+ (if (string-prefix? "@deffn" line)
+ (cons (deffn-name line) deffns)
+ deffns)))
+ deffns))))
+
+(define (read-lines port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ '()
+ (cons line (loop))))))
+
+(define (pmodel/find-package pmodel package-name)
+ (find-matching-item (pmodel/packages pmodel)
+ (lambda (p) (equal? package-name (package/name p)))))
+
+(define (pmodel/global-exports pmodel)
+ (define (global-exports package)
+ (append-map! (lambda (link)
+ (if (eq? '() (package/name
+ (binding/package
+ (link/destination link))))
+ (list (binding/name (link/destination link)))
+ '()))
+ (package/links package)))
+ (append-map! global-exports (pmodel/packages pmodel)))
+
+(define (pmodel/package-bindings pmodel package-name)
+ (let ((package (pmodel/find-package pmodel package-name)))
+ (if package
+ (map binding/name (package/bindings package))
+ (error "No such package:" package-name))))
+
+(define (duplicates listset)
+ (let loop ((items listset) (duplicates '()))
+ (cond ((null? items)
+ (reverse! duplicates))
+ ((memq (car items) (cdr items))
+ (if (memq (car items) duplicates)
+ (loop (cdr items) duplicates)
+ (loop (cdr items) (cons (car items) duplicates))))
+ (else
+ (loop (cdr items) duplicates)))))
+
+(define (minus set1 set2)
+ (let loop ((items set1) (difference '()))
+ (cond ((null? items)
+ difference)
+ ((memq (car items) set2)
+ (loop (cdr items) difference))
+ (else
+ (loop (cdr items) (cons (car items) difference))))))
+
+(define (check)
+ (let* ((texinfo (list->vector (call-with-input-file "glib.texinfo"
+ read-lines)))
+ (deffns (texinfo-deffns texinfo))
+ (dups (duplicates deffns))
+ (pmodel (read-package-model "glib" microcode-id/operating-system))
+ (bindings (append (pmodel/global-exports pmodel)
+ (pmodel/package-bindings pmodel '(glib))))
+ (missing (minus bindings deffns))
+ (extras (minus deffns bindings)))
+ (if (not (null? dups))
+ (for-each (lambda (name) (warn "multiple-descriptions:" name)) dups))
+ (if (not (null? extras))
+ (for-each (lambda (name) (warn "not bound:" name)) extras))
+ (if (not (null? missing))
+ (for-each (lambda (name) (warn "not documented:" name)) missing))))
+
+(check)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the glib wrapper.
+
+(let ((env (->environment '(runtime pathname)))
+ (dirname (directory-pathname (current-load-pathname))))
+ (set! (access library-directory-path env)
+ (cons dirname (access library-directory-path env)))
+ (set! *initial-options-file* (merge-pathnames "glib-optiondb" dirname)))
+
+(load-option 'GLIB)
+(load "glib-check" (->environment '(GLIB)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+
+|#
+
+;;;; Compile the GLIB wrapper.
+
+(load-option 'CREF)
+(load-option 'SOS)
+(load-option 'FFI)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (with-system-library-directories
+ '("./")
+ (lambda ()
+ (if (name->package '(GLIB))
+ (error "The GLIB package already exists.")
+ (let ((package-set (package-set-pathname "glib")))
+ (if (not (file-modification-time<? "glib.pkg" package-set))
+ (cref/generate-trivial-constructor "glib"))
+ (construct-packages-from-file (fasload package-set))))
+
+ ;; glib.scm includes the Glib c-includes, but does not otherwise
+ ;; use the FFI.
+ (compile-file "glib" '("glib-const.bin") (->environment '(glib)))
+ ;; Mostly to set! c-includes:
+ (load "glib" (->environment '(glib)))
+
+ ;; The wrappers use the FFI, c-includes, and some integrable
+ ;; definitions in glib.scm. Dependencies between them are
+ ;; rare.
+ (compile-file "gobject" '("glib") (->environment '(gobject)))
+ (compile-file "gio" '("glib") (->environment '(gio)))
+ (compile-file "glib-main" '("glib") (->environment '(glib main)))
+ (compile-file "glib-thread" '("glib-main")
+ (->environment '(glib thread)))
+
+ (cref/generate-constructors "glib" 'ALL)))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme glib interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-glib])
+AC_CONFIG_SRCDIR([glib.pkg])
+
+AC_COPYRIGHT(
+[Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+])
+
+AH_TOP([/*
+
+Copyright (C) 2014 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.
+
+*/])
+
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+
+if ! pkg-config --exists glib-2.0 2>/dev/null; then
+ AC_MSG_ERROR([GLib 2.0 not found.])
+fi
+
+AC_SUBST([CFLAGS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_SUBST([LIBS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
|#
;;;; GIO Objects
-;;; package: (gtk gio)
+;;; package: (glib gio)
+
+(C-include "glib")
(define (open-input-gfile uri)
(let* ((uri* (->uri* uri 'open-input-gfile))
;; g-stream's queue AND signal the main loop if Scheme has become
;; runnable.
(thread-queue/queue! queue value)
- (maybe-yield-gtk))
+ (maybe-yield-glib))
(define (g-input-stream-skip gstream count)
(let* ((gio-info (gio-cleanup-info gstream))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2012, 2013, 2014 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.
+
+|#
+
+;;;; Test the Glib interface.
+
+(let ((new (extend-top-level-environment (->environment '(glib))))
+ (ffi (->environment '(runtime ffi))))
+ (load "glib-tests" new)
+ (let ((gcp (access gcp new))
+ (gls (access gls new))
+ (ls (access ls new))
+ (registered-callback-count (access registered-callback-count ffi))
+ (malloced-aliens (named-lambda (malloced-aliens)
+ (access malloced-aliens ffi))))
+
+ (define (run-test name thunk)
+ (let ((condition (ignore-errors thunk)))
+ (cond ((eq? condition #t)
+ (for-each display (list "; Test "name" succeeded.\n")))
+ ((condition? condition)
+ (for-each display (list "; Test "name" failed with error:\n"))
+ (write-condition-report condition (current-output-port))
+ (newline))
+ (else
+ (for-each display (list "; Test "name" returned "condition
+ ".\n"))))))
+
+ (define (assert = obj1 obj2 form)
+ (if (not (= obj1 obj2))
+ (error "Assertion failed:" form))
+ #t)
+
+ (run-test
+ 'gio-copy
+ (let ((cwd (directory-pathname (current-load-pathname))))
+ (named-lambda (gio-copy-test)
+ (with-working-directory-pathname cwd
+ (lambda ()
+ (let ((file1 "../README.txt")
+ (file2 "test-copy-1.txt"))
+ (gcp file1 file2)
+ (assert equal? (md5-file file2) (md5-file file1)
+ `(GCP ,file1 ,file2))))))))
+
+ (run-test
+ 'gio-list
+ (let ((cwd (directory-pathname (current-load-pathname))))
+ (named-lambda (gio-list-test)
+ (with-working-directory-pathname cwd
+ (lambda ()
+ (let ((native (sort (ls "../runtime/") string<?))
+ (gio (sort (gls "../runtime/") string<?)))
+ (assert equal? gio native
+ '(GLS "../runtime/"))))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2008, 2009, 2010, 2011, 2014 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Main Loop Hack
+;;; package: (glib main)
+
+(C-include "glib")
+
+(define (glib-start)
+ ;; Called from glib/make.scm, from a (load-option 'Glib).
+ (set! hook/subprocess-wait nonblocking/subprocess-wait)
+ (let ((path (system-library-pathname "glib-shim.so")))
+ (if (not (file-loadable? path)) (error "Glib shim not loadable.")))
+ (if (fix:zero? (C-call "start_glib"))
+ (error "Could not start Glib main loop."))
+ (create-glib-thread))
+
+(define-integrable (run-glib select-registry-handle time)
+ (C-call "run_glib" select-registry-handle time))
+
+(define (maybe-yield-glib)
+ ;; Used by callbacks that may have made threads runnable.
+ (if (other-running-threads?)
+ (C-call "yield_glib")))
+
+(define (stop-glib)
+ ;; Sortof does the opposite of glib-start.
+ (without-interrupts
+ (lambda ()
+ (exit-glib-thread)
+ (C-call "stop_glib"))))
+
+(define (glib-select-trace?)
+ (C-call "glib_select_trace_p"))
+
+(define (glib-select-trace! on?)
+ (C-call "glib_select_trace" (if on? 1 0)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test optiondb, includes the installed system's optiondb.
+
+(define-load-option 'GLIB
+ (let ((pathname
+ (merge-pathnames "make"
+ (directory-pathname (current-load-pathname)))))
+ (named-lambda (glib-option-loader)
+ (load pathname))))
+
+(further-load-options
+ (merge-pathnames "optiondb"
+ (last (access library-directory-path
+ (->environment '(runtime pathname))))))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2014 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Header for glib-shim.c and glib-const.c. */
+
+#define GSEAL_ENABLE 1
+
+#include <glib.h>
+#include <glib-object.h>
+#include <gio/gio.h>
+#include <gio/gio.h>
+
+typedef unsigned int uint;
+extern gboolean start_glib (void);
+extern void stop_glib (void);
+extern void run_glib (unsigned long registry, double time);
+extern void yield_glib (void);
+extern gboolean glib_select_trace_p (void);
+extern void glib_select_trace (gboolean trace_p);
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2010, 2011, 2012, 2013, 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+
+|#
+
+;;;; Test procedures for the glib interface.
+\f
+;;; GIO tests.
+
+(define test-copy-integrity
+ (let ((cwd (directory-pathname (current-load-pathname))))
+ (named-lambda (test-copy-integrity)
+ (with-working-directory-pathname cwd
+ (lambda ()
+ (let ((file1 "../README.txt")
+ (file2 "test-copy-1.txt"))
+ (gcp file1 file2)
+ (assert-equal (md5-file file2) (md5-file file1))))))))
+
+(define test-child-enumeration
+ (let ((cwd (directory-pathname (current-load-pathname))))
+ (named-lambda (test-child-enumeration)
+ (with-working-directory-pathname cwd
+ (lambda ()
+ (let ((native (sort (ls "../runtime/") string<?))
+ (gio (sort (gls "../runtime/") string<?)))
+ (assert-equal gio native)))))))
+
+(define (gcp src dst)
+ (let ((gsrc (open-input-gfile src))
+ (gdst (open-output-gfile dst)))
+ (let loop ()
+ (let ((line (read-line gsrc)))
+ (if (eof-object? line)
+ (begin
+ ;; Close the streams OR NOT, e.g. to test GCing of
+ ;; abandoned (quiet) ports. Testing GCing of a port
+ ;; with an operation pending would be... useful, and
+ ;; tricky.
+ (close-input-port gsrc)
+ (close-output-port gdst))
+ (begin
+ (write-string line gdst) (newline gdst)
+ (loop)))))))
+
+(define (gcat uri)
+ (let ((gstream (open-input-gfile uri)))
+ (let loop ()
+ (let ((line (read-line gstream)))
+ (if (eof-object? line)
+ (begin
+ ;; Close the gstream OR NOT, e.g. to test GCing of
+ ;; abandoned (quiet) ports. Testing GCing of a port
+ ;; with an operation pending would be... useful, and
+ ;; tricky.
+ (close-input-port gstream))
+ (begin
+ (write-string line) (newline)
+ (loop)))))))
+
+(define (ls pathname)
+ (let ((names (map file-namestring
+ (directory-read (->simple-namestring pathname)))))
+ (sort (delete! ".." (delete! "." names)) string<?)))
+
+(define (gls uri)
+ (sort (gdirectory-read uri) string<?))
+
+(define ->simple-namestring
+ (access ->simple-namestring (->environment '(gio))))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2014 Matthew Birkholz
This file is part of MIT/GNU Scheme.
|#
;;;; The Toolkit Thread
-;;; package: (gtk thread)
+;;; package: (glib thread)
;;; parent: (runtime thread)
-(define gtk-thread #f)
+(define glib-thread #f)
-;;; With the gtk-thread always running, the runtime system should no
+;;; With the glib-thread always running, the runtime system should no
;;; longer use wait-for-io and thus never signal
;;; condition-type:no-thread!
;;; which might allow a switch to a different thread, which might
;;; return from a different callback.
-;;; The Gtk system's "GC cleanups" are run by gtk-thread sometime
-;;; after a flip. The secondary gc daemons are also run by gtk-thread
+;;; The Glib system's "GC cleanups" are run by glib-thread sometime
+;;; after a flip. The secondary gc daemons are also run by glib-thread
;;; after some number of flips.
;; Number of GCs between applications of trigger-secondary-gc-daemons!
(define secondary-gc-rate 100)
-(define (gtk-thread-running?)
- ;; Used by dependent systems, e.g. gtk-screen, to defer while the
- ;; Gtks are unavailable, e.g. when "DISPLAY not set".
- (and gtk-thread (memq (thread-execution-state gtk-thread)
- '(RUNNING RUNNING-WITHOUT-PREEMPTION))))
-
-(define (create-gtk-thread)
- (if gtk-thread (error "A GTk thread already exists."))
- (set! gtk-thread
+(define (create-glib-thread)
+ (if glib-thread (error "A Glib thread already exists."))
+ (set! glib-thread
(create-thread
#f (lambda ()
(let ((self (current-thread))
(done-tick 0)
(next-secondary-tick secondary-gc-rate))
- (let gtk-thread-loop ()
+ (let glib-thread-loop ()
(without-interrupts
(lambda ()
(let ((gc-tick (car (gc-timestamp))))
(and timer-records
(timer-record/time timer-records))
-1)))
- (%trace ";run-gtk until "time"\n")
- (run-gtk (select-registry-handle io-registry) time)
- (%trace ";run-gtk done at "(real-time-clock)"\n"))))
+ (%trace ";run-glib until "time"\n")
+ (run-glib (select-registry-handle io-registry) time)
+ (%trace ";run-glib done at "(real-time-clock)"\n"))))
(yield-current-thread)
- (gtk-thread-loop))))))
- (detach-thread gtk-thread))
+ (glib-thread-loop))))))
+ (detach-thread glib-thread))
-(define (exit-gtk-thread)
- (let ((thread gtk-thread))
- (set! gtk-thread #f)
- (if (not thread) (error "A GTk thread was not running."))
+(define (exit-glib-thread)
+ (let ((thread glib-thread))
+ (set! glib-thread #f)
+ (if (not thread) (error "A Glib thread was not running."))
(signal-thread-event
thread (lambda ()
(exit-current-thread #t)))))
-(define (stop-gtk-thread)
- (signal-thread-event gtk-thread (lambda () (stop-current-thread))))
+(define (stop-glib-thread)
+ (signal-thread-event glib-thread (lambda () (stop-current-thread))))
-(define (restart-gtk-thread)
- (restart-thread gtk-thread #t #f))
+(define (restart-glib-thread)
+ (restart-thread glib-thread #t #f))
(define %trace? #f)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2014 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for glib-shim.so.
+\f
+(include "Includes/glib")
+(include "Includes/glib-object")
+(include "Includes/gio/gio")
+
+;;; gio.scm
+
+(extern gpointer
+ g_try_malloc0
+ (n_bytes gsize))
+
+(callback void
+ async_ready
+ (source (* GObject))
+ (res (* GAsyncResult))
+ (ID gpointer))
+
+(callback void
+ ask_password
+ (op (* GMountOperation))
+ (message (* gchar))
+ (default_user (* gchar))
+ (default_domain (* gchar))
+ (flags GAskPasswordFlags)
+ (ID gpointer))
+
+(callback void
+ ask_question
+ (op (* GMountOperation))
+ (message (* gchar))
+ (choices GStrv)
+ (ID gpointer))
+
+(callback void
+ show_processes
+ (op (* GMountOperation))
+ (message (* gchar))
+ (processes (* GArray))
+ (choices GStrv)
+ (ID gpointer))
+
+;;; glibio.c
+
+(extern gboolean start_glib)
+(extern void stop_glib)
+(extern void run_glib (registry ulong) (time double))
+(extern void yield_glib)
+(extern gboolean glib_select_trace_p)
+(extern void glib_select_trace (trace_p gboolean))
+
+(extern void g_free ;glib-2.8.6/glib/gmem.h
+ (mem gpointer))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+
+|#
+
+;;;; Glib System Packaging
+
+;;; When loaded, Scheme becomes a g_source attached to the default
+;;; GMainContext. A glib-thread is spawned to periodically yield to
+;;; the toolkit(s).
+
+(global-definitions runtime/)
+(global-definitions sos/)
+
+(define-package (glib)
+ (parent ())
+ (files "glib"))
+
+(define-package (gobject)
+ (parent (glib))
+ (files "gobject")
+ ;;(depends-on "glib.bin" "glib")
+ (export (glib)
+ <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))
+
+(define-package (gio)
+ (parent (glib))
+ (files "gio")
+ ;;(depends-on "glib.bin" "glib")
+ (import (runtime)
+ ucode-primitive)
+ (import (runtime ffi)
+ %set-alien/address!)
+ (import (runtime generic-i/o-port)
+ make-gsource
+ make-gsink)
+ (import (glib main)
+ maybe-yield-glib)
+ (export ()
+ open-input-gfile
+ open-output-gfile
+ gdirectory-read)
+ (export (glib)
+ <g-stream>
+ <g-input-stream>
+ g-input-stream-read
+ g-input-stream-skip
+ g-input-stream-close
+ <g-output-stream>
+ g-output-stream-write
+ g-output-stream-flush
+ g-output-stream-close
+ <gfile-input-stream>
+ gfile-read
+ <gfile-output-stream>
+ gfile-append-to
+ gfile-create
+ gfile-replace
+ <gfile-info>
+ gfile-query-info
+ gfile-info-list-attributes
+ gfile-info-get-attribute-status
+ gfile-info-get-attribute-value
+ <gfile-enumerator>
+ gfile-enumerate-children
+ gfile-enumerator-next-files
+ gfile-enumerator-close
+ <gfile>
+ make-gfile))
+
+(define-package (glib main)
+ (parent (glib))
+ (files "glib-main")
+ ;;(depends-on "glib.bin" "glib")
+ (import (runtime load)
+ *unused-command-line*
+ hook/process-command-line
+ default/process-command-line)
+ (import (runtime)
+ ucode-primitive)
+ (import (runtime subprocess)
+ hook/subprocess-wait nonblocking/subprocess-wait)
+ (import (glib thread)
+ create-glib-thread exit-glib-thread)
+ (export ()
+ glib-select-trace?
+ glib-select-trace!))
+
+(define-package (glib thread)
+ (parent (runtime thread))
+ (files "glib-thread")
+ ;;(depends-on "main")
+ (export ()
+ stop-glib-thread)
+ (import (gobject)
+ run-gc-cleanups)
+ (import (glib main)
+ run-glib)
+ (import (runtime primitive-io)
+ select-registry-handle))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Core utilities.
+;;; package: (glib)
+
+(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)))))
+
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (declare (ignore environment))
+ (if (syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
+ `(BEGIN
+ (DECLARE (INTEGRATE-OPERATOR ,(caadr form)))
+ (DEFINE ,@(cdr form)))
+ (ill-formed-syntax form)))))
+
+(define-syntax error-if-null
+ (syntax-rules ()
+ ((_ ALIEN MESSAGE ...)
+ (if (alien-null? ALIEN)
+ (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-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)
+ (not (int:zero? (bitwise-and int mask))))
+
+(declare (integrate-operator bit-ior))
+(define (bit-ior . ints)
+ (reduce bitwise-ior 0 ints))
+\f
+(define-integrable (color? object)
+ (and (flo:flonum? object) (fix:= 4 (flo:vector-length object))))
+
+(define-integrable (make-color) (flo:vector-cons 4))
+
+(define-integrable-operator (color-red o)
+ (if (color? o) (flo:vector-ref o 0) (error:wrong-type-argument o "a color")))
+
+(define-integrable-operator (color-green o)
+ (if (color? o) (flo:vector-ref o 1) (error:wrong-type-argument o "a color")))
+
+(define-integrable-operator (color-blue o)
+ (if (color? o) (flo:vector-ref o 2) (error:wrong-type-argument o "a color")))
+
+(define-integrable-operator (color-alpha o)
+ (if (color? o) (flo:vector-ref o 3) (error:wrong-type-argument o "a color")))
+
+(define-integrable-operator (set-color-red! o r)
+ (if (color? o) (flo:vector-set! o 0 r)(error:wrong-type-argument o"a color")))
+
+(define-integrable-operator (set-color-green! o g)
+ (if (color? o) (flo:vector-set! o 1 g)(error:wrong-type-argument o"a color")))
+
+(define-integrable-operator (set-color-blue! o b)
+ (if (color? o) (flo:vector-set! o 2 b)(error:wrong-type-argument o"a color")))
+
+(define-integrable-operator (set-color-alpha! o a)
+ (if (color? o) (flo:vector-set! o 3 a)(error:wrong-type-argument o"a color")))
\ No newline at end of file
--- /dev/null
+\input texinfo @c -*-Texinfo-*-
+@comment %**start of header
+@setfilename mit-scheme-glib
+@set VERSION 0.5
+@settitle Glib @value{VERSION}
+@comment %**end of header
+
+@ifhtml
+@macro bref {name}
+@ref{\name\,,@code{\name\}}
+@end macro
+@end ifhtml
+@ifinfo
+@macro bref {name}
+\name\
+@end macro
+@end ifinfo
+@ifnothtml
+@ifnotinfo
+@macro bref {name}
+@code{\name\}
+@end macro
+@end ifnotinfo
+@end ifnothtml
+
+@copying
+This manual documents @acronym{Glib} @value{VERSION}.
+
+Copyright @copyright{} 2008, 2009, 2010, 2011, 2012, 2013 Matthew Birkholz
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.2 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
+and with the Back-Cover Texts as in (a) below. A copy of the
+license is included in the section entitled ``GNU Free Documentation
+License.''
+
+(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
+this GNU Manual, like GNU software. Copies published by the Free
+Software Foundation raise funds for GNU development.''
+@end quotation
+@end copying
+
+@dircategory Programming Languages
+@direntry
+* MIT/GNU Scheme Glib: (mit-scheme-glib).
+ GNOME Interface
+@end direntry
+
+@titlepage
+@title The Glib Reference Manual
+@subtitle Schemely access (@value{VERSION}) to the GNOME toolkits
+@subtitle for MIT/GNU Scheme version 9.1
+@author by Matt Birkholz (@email{birkholz@@alum.mit.edu})
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@ifnottex
+@node Top, Introduction, (dir), (dir)
+@top Glib Interface
+
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction::
+* API Reference::
+* Installation::
+* Implementation Notes:: This is for Scheme widget developers.
+* GNU Free Documentation License::
+@end menu
+
+@node Introduction, API Reference, Top, Top
+@chapter Introduction
+
+The Glib system is a collection of Scheme data types and procedures
+providing a Schemely interface to the Glib, GObject and GIO libraries.
+It is used by the GStreamer and Gtk wrappers. Very little of the
+libraries' APIs 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.
+
+@node API Reference, Installation, Introduction, Top
+@unnumberedsec The Glib Package
+
+Most of the Glib system's public bindings are in the @code{(glib)}
+package --- not exported to the global environment. It is assumed
+that other systems will import bindings from @code{(glib)} or create
+child packages (e.g. a Glib child that exports its entry points by
+adding procedures to generics imported from a more abstract package).
+
+@menu
+* GObject::
+* GIO::
+* Debugging Facilities::
+@end menu
+
+@node GObject, GIO, API Reference, API Reference
+@section GObject
+
+An instance of @code{<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, or perhaps just without-toolkit).
+Connecting a second callback disconnects the
+first.
+
+@anchor{pinned-objects}
+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
+also pinned and the garbage collector will never 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 binding through which the instance is reachable.
+
+@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
+@code{#t} while @var{gobject} is alive, @code{#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:
+
+@example
+ (g-signal-connect window (C-callback "delete_event") delete-callback)
+@end example
+
+Note that @var{delete-callback} should reference @var{window} via
+parameter @emph{only}. @xref{pinned-objects}.
+@end deffn
+
+@deffn Procedure g-signal-disconnect gobject name
+@var{name} should be a string, e.g.:
+@example
+ (g-signal-disconnect window "delete_event")
+@end example
+@end deffn
+
+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}.
+
+@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 GIO, Debugging Facilities, GObject, API Reference
+@section GIO
+
+The basic interface to the GIO library is three procedures taking a
+URI argument and returning either a Scheme port or a list of strings.
+The URI can specify file, http and sftp protocols (and perhaps more,
+depending on support in the GIO library). If an SFTP URI requires a
+password, Scheme's @code{call-with-pass-phrase} procedure is called.
+If the ports are GCed or the stack unwound, pending operations are
+cancelled. Re-winding the stack is an error.
+
+@deffn Procedure open-input-gfile uri
+Returns an input port that reads from @var{uri}.
+@end deffn
+
+@deffn Procedure open-output-gfile uri
+Returns an output port that writes a new file replacing @var{uri}.
+@end deffn
+
+@deffn Procedure gdirectory-read uri
+Returns a list of strings --- the names of the ``children'' of
+@var{uri}, a directory resource.
+@end deffn
+
+A more direct interface to GIO's GFile operations is provided by the
+following 8 classes and 18 operations.
+
+@verbatim
+ <gfile>
+ make-gfile
+ <gfile-info>
+ gfile-query-info
+ gfile-info-list-attributes
+ gfile-info-get-attribute-status
+ gfile-info-get-attribute-value
+ <gfile-enumerator>
+ gfile-enumerate-children
+ gfile-enumerator-next-files
+ gfile-enumerator-close
+ <g-stream>
+ <g-input-stream>
+ g-input-stream-read
+ g-input-stream-skip
+ g-input-stream-close
+ <gfile-input-stream>
+ gfile-read
+ <g-output-stream>
+ g-output-stream-write
+ g-output-stream-flush
+ g-output-stream-close
+ <gfile-output-stream>
+ gfile-append-to
+ gfile-create
+ gfile-replace
+@end verbatim
+
+@deffn Class <gfile>
+Represents a @code{GFile} toolkit object.
+@end deffn
+
+@deffn Procedure make-gfile uri
+Constructs a gfile for the given @var{uri}. This operation never
+fails, but the returned object might not support any I/O if @var{uri}
+is malformed or if the uri type is not supported.
+@end deffn
+
+@deffn Class <gfile-info>
+Represents a @code{GFileInfo} toolkit object containing key-value
+attributes (such as the type or size of a gfile).
+@end deffn
+
+@deffn Procedure gfile-query-info gfile attributes follow-symlinks?
+Gets the requested information about @var{gfile}. The result is a
+gfile-info instance.
+
+@var{Attributes} should be a string specifying the file attributes to
+be gathered. It is not an error if it's not possible to read a
+particular requested attribute from a file --- it just won't be set.
+@var{Attributes} should be a comma-separated list of attributes or
+attribute wildcards. The wildcard @code{*} means all attributes, and
+a wildcard like @code{standard::*} means all attributes in the
+standard namespace. An example attribute query is
+@code{standard::*,owner::user}.
+
+Normally information about the target of a symlink
+is returned, rather than information about the symlink itself. However
+if @var{follow-symlinks?} is @code{#f}, information about the
+symlink itself will be returned. If the target does not exist,
+information about the symlink itself will be returned.
+@end deffn
+
+There are many gfile attributes. Most have boolean or integer values.
+Some are enum constants. For example the @code{standard::type}
+attribute's value is a GFileType member, e.g. @code{(C-enum
+"G_FILE_TYPE_UNKNOWN")}. For a complete list of GFileType members and
+other GIO constants, see your @file{gioenums.h} header file.
+
+Here are the 76 keys listed in the @file{gfileinfo.h} header:
+@code{standard::type},
+@code{standard::is-hidden},
+@code{standard::is-backup},
+@code{standard::is-symlink},
+@code{standard::is-virtual},
+@code{standard::name},
+@code{standard::display-name},
+@code{standard::edit-name},
+@code{standard::copy-name},
+@code{standard::description},
+@code{standard::icon},
+@code{standard::content-type},
+@code{standard::fast-content-type},
+@code{standard::size},
+@code{standard::allocated-size},
+@code{standard::symlink-target},
+@code{standard::target-uri},
+@code{standard::sort-order},
+@code{etag::value},
+@code{id::file},
+@code{id::filesystem},
+@code{access::can-read},
+@code{access::can-write},
+@code{access::can-execute},
+@code{access::can-delete},
+@code{access::can-trash},
+@code{access::can-rename},
+@code{mountable::can-mount},
+@code{mountable::can-unmount},
+@code{mountable::can-eject},
+@code{mountable::unix-device},
+@code{mountable::unix-device-file},
+@code{mountable::hal-udi},
+@code{mountable::can-start},
+@code{mountable::can-start-degraded},
+@code{mountable::can-stop},
+@code{mountable::start-stop-type},
+@code{mountable::can-poll},
+@code{mountable::is-media-check-automatic},
+@code{time::modified},
+@code{time::modified-usec},
+@code{time::access},
+@code{time::access-usec},
+@code{time::changed},
+@code{time::changed-usec},
+@code{time::created},
+@code{time::created-usec},
+@code{unix::device},
+@code{unix::inode},
+@code{unix::mode},
+@code{unix::nlink},
+@code{unix::uid},
+@code{unix::gid},
+@code{unix::rdev},
+@code{unix::block-size},
+@code{unix::blocks},
+@code{unix::is-mountpoint},
+@code{dos::is-archive},
+@code{dos::is-system},
+@code{owner::user},
+@code{owner::user-real},
+@code{owner::group},
+@code{thumbnail::path},
+@code{thumbnail::failed},
+@code{preview::icon},
+@code{filesystem::size},
+@code{filesystem::free},
+@code{filesystem::used},
+@code{filesystem::type},
+@code{filesystem::readonly},
+@code{filesystem::use-preview},
+@code{gvfs::backend},
+@code{selinux::context},
+@code{trash::item-count},
+@code{trash::orig-path}, or
+@code{trash::deletion-date}.
+
+@deffn Procedure gfile-info-list-attributes ginfo namespace
+Lists the gfile-info attribute keys.
+@var{Namespace} should be e.g. @code{standard} or @code{*}.
+@end deffn
+
+@deffn Procedure gfile-info-get-attribute-status ginfo key
+Returns @code{set} if the @code{key} attribute in @code{ginfo} has
+been set. Returns @code{unset} if not. Returns @code{error-setting}
+if there was an error collecting the value.
+@end deffn
+
+@deffn Procedure gfile-info-get-attribute-value ginfo key
+Returns a boolean, integer, string or list of strings depending on the
+value of @var{key} in @var{ginfo}.
+@end deffn
+
+@deffn Class <gfile-enumerator>
+Represents a @code{GFileEnumerator}.
+@end deffn
+
+@deffn Procedure gfile-enumerate-children gfile attributes follow-symlinks?
+Gets the requested information about the files in @var{gfile} --- a
+directory. The result is a gfile-enumerator that produces a gfile-info
+for each file in the directory. If @var{gfile} is not a directory, an
+error is signaled.
+
+@var{Attributes} should be a string specifying the file attributes to
+be gathered. It is not an error if it's not possible to read a
+particular requested attribute from a file --- it just won't be set.
+@var{Attributes} should be a comma-separated list of attributes or
+attribute wildcards. The wildcard @code{*} means all attributes, and
+a wildcard like @code{standard::*} means all attributes in the
+standard namespace. An example attribute query is
+@code{standard::*,owner::user}.
+@end deffn
+
+@deffn Procedure gfile-enumerator-next-files genum n
+Gets up to @var{n} more gfile-infos from @var{genum}.
+@end deffn
+
+@deffn Procedure gfile-enumerator-close genum
+Closes @var{genum}.
+@end deffn
+
+@deffn Class <g-stream>
+Abstract superclass of GIO streams.
+@end deffn
+
+@deffn Class <g-input-stream>
+A subclass of g-stream.
+@end deffn
+
+@deffn Procedure g-input-stream-read gstream buffer start end
+Returns the number of bytes read from @var{gstream} and
+written into @var{buffer}.
+@end deffn
+
+@deffn Procedure g-input-stream-skip gstream count
+Returns the number of bytes read from @var{gstream} and discarded.
+@end deffn
+
+@deffn Procedure g-input-stream-close gstream
+Closes @var{gstream}.
+@end deffn
+
+@deffn Class <gfile-input-stream>
+A subclass of g-input-stream representing input from a file.
+@end deffn
+
+@deffn Procedure gfile-read gfile
+Returns a gfile-input-stream opened for reading from @var{gfile}.
+@end deffn
+
+@deffn Class <g-output-stream>
+A subclass of g-stream.
+@end deffn
+
+@deffn Procedure g-output-stream-write gstream buffer start end
+Returns the number of bytes written to @var{gstream}. Will return 0
+only if @var{start} equals @var{end}.
+@end deffn
+
+@deffn Procedure g-output-stream-flush gstream
+Forces a write of all user-space buffered data for @var{gstream}.
+@end deffn
+
+@deffn Procedure g-output-stream-close gstream
+Closes @var{gstream}.
+@end deffn
+
+@deffn Class <gfile-output-stream>
+A subclass of g-output-stream representing output to a file.
+@end deffn
+
+@deffn Procedure gfile-replace gfile etag backup? . flags
+Returns a gfile-output-stream that overwrites @var{gfile}, possibly
+creating a backup copy of the file first. If the file doesn't exist,
+it will be created.
+
+This will try to replace the file in the safest way possible so that
+any errors during the writing will not affect an already existing copy
+of the file. For instance, for local files it may write to a temporary
+file and then atomically rename over the destination when the stream
+is closed.
+
+By default files are generally created readable by everyone, but if
+you include the symbol @code{private} in @var{flags} the file will be
+made readable only to the current user, to the level that is supported
+on the target filesystem.
+
+@var{Etag} should be zero or false, or an alien. If @var{etag} is an
+alien, it is compared to the current entity tag of the file, and if
+they differ an error is signaled. This generally means that the file
+has been changed since you last read it. You can get the etag for a
+gfile from the @code{etag::value} attribute in
+its gfile-info. You can get the gfile-info for a gfile-input-stream
+with @code{gfile-input-stream-query-info}. The etag for a
+gfile-output-stream is available from
+@code{gfile-output-stream-get-etag}.
+
+@var{Backup?} should be @code{#f} unless you require a backup of
+an existing file to be made. If a backup cannot be made, an error
+will be signaled. If you want to replace the file anyway, call
+again with @var{backup?} @code{#f}.
+@end deffn
+
+@deffn Procedure gfile-append-to gfile . flags
+Returns a gfile-output-stream that appends to @var{gfile}. If the file
+doesn't already exist it is created.
+
+By default files are created readable by everyone, but if you include
+the symbol @code{private} in @var{flags} the file will be made
+readable only to the current user, to the level that is supported on
+the target filesystem.
+@end deffn
+
+@deffn Procedure gfile-create gfile . flags
+Returns a gfile-output-stream that writes to @var{gfile}. If the file
+already exists an error is signaled.
+
+By default files are created readable by everyone, but if you include
+the symbol @code{private} in @var{flags} the file will be made
+readable only to the current user, to the level that is supported on
+the target filesystem.
+@end deffn
+
+@node Debugging Facilities, , GIO, API Reference
+@section Debugging Facilities
+
+@deffn Procedure stop-glib-thread
+A convenient procedure to call in an emergency.
+@end deffn
+
+@deffn Procedure glib-select-trace?
+@code{#t} if Scheme's GSource is being traced, else @code{#f}.
+@end deffn
+
+@deffn Procedure glib-select-trace! trace?
+If @var{trace?} is @code{#t}, turns on tracing of Scheme's GSource.
+@end deffn
+
+@node Installation, Implementation Notes, API Reference, Top
+@chapter Installation
+
+Unpack the source and build in the usual way, but do not call
+@code{./configure} with a @code{--prefix} argument. This plugin will
+be installed in the system library path of the machine run by the
+@code{mit-scheme} command. You can override this command name by
+setting @code{MITSCHEME_EXE}. You can override the system library
+path of any machine by passing it the @code{--library} option on the
+commandline, or the @code{MITSCHEME_LIBRARY_PATH} variable in the
+environment.
+
+@example
+ tar xzf glib-0.5.tar.gz
+ cd gtk-0.5
+ ./configure
+ make
+ make check
+ make install
+ make install-info
+ make install-html
+ make install-pdf
+@end example
+
+@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.
+
+@example
+ (let ((retval (make-alien '|gchar|)))
+ (C-call "gtk_label_get_text" retval (gobject-alien label))
+ (c-peek-cstring retval))
+@result{} "!dlrow ,olleH"
+@end example
+
+The @code{gtk-label-get-text} wrapper procedure hides these details.
+
+@example
+ (gtk-label-get-text label)
+@result{} "!dlrow ,olleH"
+@end example
+
+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
+
+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
+initialize 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 instance, 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 --- the object
+cannot be erroneously used by Scheme in the future.
+
+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
+
+@display
+Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc.
+51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The ``Document'', below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as ``you''. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject. (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+@sc{ascii} without markup, Texinfo input format, La@TeX{} input
+format, @acronym{SGML} or @acronym{XML} using a publicly available
+@acronym{DTD}, and standard-conforming simple @acronym{HTML},
+PostScript or @acronym{PDF} designed for human modification. Examples
+of transparent image formats include @acronym{PNG}, @acronym{XCF} and
+@acronym{JPG}. Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, @acronym{SGML} or
+@acronym{XML} for which the @acronym{DTD} and/or processing tools are
+not generally available, and the machine-generated @acronym{HTML},
+PostScript or @acronym{PDF} produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''. You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warrany Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License. Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License. However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+@end enumerate
+
+@page
+@appendixsec ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+ Copyright (C) @var{year} @var{your name}.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.2
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+ A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with...Texts.'' line with this:
+
+@smallexample
+@group
+ with the Invariant Sections being @var{list their titles}, with
+ the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+ being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@bye
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* SchemeSource -- the custom GSource that runs Scheme in an idle task. */
+
+#include <mit-scheme.h>
+#include <glib.h>
+#include <math.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <malloc.h>
+
+/* Presumed externs/const of the Glib-ready machine. */
+extern double OS_real_time_clock (void);
+extern int OS_process_any_status_change (void);
+extern int OS_select_registry_length (unsigned long registry);
+#define SELECT_MODE_READ 1
+#define SELECT_MODE_WRITE 2
+extern void OS_select_registry_entry (unsigned long registry,
+ int i, int *fd, unsigned int *mode);
+extern void OS_syserr_names (unsigned long *, const char ***);
+extern void Interpret (int pop_return_p);
+extern void alienate_float_environment (void);
+extern void foreach_async_signal (void(*func)(int signo));
+extern void abort_to_c (void);
+extern int interrupts_p (void);
+
+static void init_signal_handling (void);
+
+struct _SchemeSource
+{
+ GSource source;
+
+ /* The list of GPollFDs that have been added to the main_context. */
+ GSList * gpollfds;
+
+ /* When to give up waiting. */
+ double time_limit;
+
+ /* TRUE when Scheme has a runnable thread. Set to FALSE at the
+ start of run_glib. Set to TRUE by a callback that has made a
+ Scheme thread runnable. */
+ gboolean runnable;
+};
+typedef struct _SchemeSource SchemeSource;
+
+static gboolean scheme_source_prepare (GSource * source, gint * timeout);
+static gboolean scheme_source_check (GSource * source);
+static int pending_io (SchemeSource * source);
+static gboolean scheme_source_dispatch (GSource * source, GSourceFunc callback, gpointer user_data);
+static void install_scheme_source (void);
+static void destroy_scheme_source (void);
+static void clear_registry (SchemeSource * source);
+static void set_registry (SchemeSource * source, GSList * new, double time);
+
+static SchemeSource * scheme_source = NULL;
+static gboolean tracing_glib_select = 0;
+static void trace (const char *format, ...);
+static GSList * glib_registry (unsigned long registry);
+
+int slice_counter = 0;
+static gchar * gpollfds_string (GSList * gpollfds);
+
+void
+trace (const char * format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ if (tracing_glib_select)
+ {
+ vfprintf (stderr, format, args);
+ fflush (stderr);
+ }
+ va_end (args);
+}
+
+static gboolean
+scheme_source_prepare (GSource * source, gint * timeout)
+{
+ /* Return TRUE when ready to dispatch (without a poll).
+
+ Return FALSE and set `timeout' to do a poll/check before
+ dispatching. */
+
+ SchemeSource * src = (SchemeSource *)source;
+
+ if (src->runnable
+ || interrupts_p ()
+ || OS_process_any_status_change ())
+ {
+ trace (";scheme_source_prepare: ready (%s)\n",
+ src->runnable ? "thread"
+ : interrupts_p () ? "interrupt"
+ : "subprocess");
+ *timeout = 0;
+ return (TRUE);
+ }
+ if (src->time_limit == -1.0)
+ {
+ trace (";scheme_source_prepare: waiting\n");
+ *timeout = -1;
+ return (FALSE);
+ }
+ if (src->time_limit == 0.0)
+ {
+ trace (";scheme_source_prepare: polling\n");
+ *timeout = 0;
+ return (FALSE);
+ }
+ {
+ double dtime = OS_real_time_clock ();
+ gint timeo = ceil (src->time_limit - dtime);
+
+ if (timeo <= 0)
+ {
+ trace (";scheme_source_prepare: ready (timeout)\n");
+ *timeout = 0;
+ return (TRUE);
+ }
+
+ trace (";scheme_source_prepare: polling for %dmsec\n", timeo);
+ *timeout = timeo;
+ return (FALSE);
+ }
+}
+
+static gboolean
+scheme_source_check (GSource * source)
+{
+ /* Return TRUE when ready to dispatch (after the poll). */
+
+ SchemeSource * src = (SchemeSource *)source;
+
+ if (src->time_limit == 0.0
+ || src->runnable
+ || interrupts_p ()
+ || OS_process_any_status_change ()
+ || pending_io (src))
+ {
+ trace (";scheme_source_check: ready (%s)\n",
+ src->runnable ? "thread"
+ : interrupts_p () ? "interrupt"
+ : OS_process_any_status_change () ? "subprocess"
+ : src->time_limit == 0.0 ? "" : "i/o");
+ return (TRUE);
+ }
+ if (src->time_limit == -1.0)
+ {
+ trace (";scheme_source_check: waiting forever\n");
+ return (FALSE);
+ }
+ {
+ double dtime = OS_real_time_clock ();
+ gint timeo = ceil (src->time_limit - dtime);
+
+ if (timeo <= 0)
+ {
+ trace (";scheme_source_check: ready (timeout)\n");
+ return (TRUE);
+ }
+
+ trace (";scheme_source_check: waiting %dmsec\n", timeo);
+ return (FALSE);
+ }
+}
+
+static int
+pending_io (SchemeSource * src)
+{
+ GSList * scan;
+
+ if (tracing_glib_select)
+ {
+ scan = src->gpollfds;
+ while (scan != NULL)
+ {
+ GPollFD * gfd = scan->data;
+ if (gfd->revents != 0)
+ {
+ fprintf (stderr, ";scheme_source_check: i/o ready on %d\n",
+ gfd->fd);
+ }
+ scan = scan->next;
+ }
+ }
+
+ scan = src->gpollfds;
+ while (scan != NULL)
+ {
+ GPollFD * gfd = scan->data;
+ if (gfd->revents != 0)
+ return (TRUE);
+ scan = scan->next;
+ }
+ return (FALSE);
+}
+
+static gboolean
+do_scheme (GSource *source)
+{
+ slice_counter += 1;
+ trace (";scheme_source_dispatch: running time slice %d\n", slice_counter);
+
+ Interpret (1);
+ alienate_float_environment ();
+
+ trace (";scheme_source_dispatch: finished time slice %d\n", slice_counter);
+ return (TRUE); /* Not a once-only. */
+}
+
+static gboolean
+scheme_source_dispatch (GSource * source,
+ GSourceFunc callback, gpointer user_data)
+{
+ /* Executes our "idle" task. Ignore the callback and user_data
+ arguments. Must return TRUE to stay on the list of event
+ sources. */
+
+ gboolean ret = FALSE;
+
+ if (!g_source_is_destroyed (source))
+ ret = do_scheme (source);
+
+ return ret;
+}
+
+GSourceFuncs scheme_source_funcs =
+{
+ scheme_source_prepare,
+ scheme_source_check,
+ scheme_source_dispatch,
+ NULL,
+ NULL,
+ NULL
+};
+
+static void
+install_scheme_source (void)
+{
+ scheme_source = (SchemeSource *)
+ g_source_new (&scheme_source_funcs, sizeof (SchemeSource));
+ scheme_source->gpollfds = NULL;
+ scheme_source->time_limit = 0.0;
+ scheme_source->runnable = FALSE;
+ g_source_set_priority ((GSource *) scheme_source, G_PRIORITY_LOW);
+ g_source_attach ((GSource *) scheme_source, NULL);
+}
+
+static void
+destroy_scheme_source (void)
+{
+ clear_registry (scheme_source);
+ g_source_destroy ((GSource *) scheme_source);
+ scheme_source = NULL;
+}
+
+static void
+clear_registry (SchemeSource * source)
+{
+ GSList * gpollfds = source->gpollfds;
+ if (gpollfds != NULL)
+ {
+ GMainContext * context = g_source_get_context ((GSource *)source);
+ GSList * scan = gpollfds;
+ while (scan != NULL)
+ {
+ GPollFD * gfd = scan->data;
+ g_main_context_remove_poll (context, gfd);
+ g_free (gfd);
+ scan->data = NULL;
+ scan = scan->next;
+ }
+ g_slist_free (gpollfds);
+ }
+ source->gpollfds = NULL;
+}
+
+static void
+set_registry (SchemeSource * source, GSList * new, double time)
+{
+ /* Set the source's current gpollfds to match NEW. Warns if the
+ registry is already set. */
+
+ if (source->gpollfds != NULL)
+ clear_registry (source);
+
+ source->time_limit = time;
+ source->runnable = FALSE;
+ source->gpollfds = new;
+ {
+ GMainContext * context = g_source_get_context ((GSource *)source);
+ while (new != NULL)
+ {
+ GPollFD * gfd = new->data;
+ /* G_PRIORITY_LOW ensures that window resizes can happen even
+ when Scheme is spinning, thus allowing the time-slice
+ window to grow with its count. */
+ g_main_context_add_poll (context, gfd, G_PRIORITY_LOW);
+ new = new->next;
+ }
+ }
+}
+\f
+
+/* Invoking g_main_loop_run. */
+
+extern SCM Scm_continue_start_glib (void);
+extern SCM Scm_continue_stop_glib (void);
+extern int cstack_depth;
+typedef void (*SliceHook)(void);
+SliceHook slice_hook = NULL;
+static GMainLoop *loop;
+
+gboolean
+start_glib (void)
+{
+ /* Runs g_main_loop_run with scheme_source attached. Returns TRUE when
+ successful. Returns FALSE when main loop is already running. */
+
+ if (scheme_source != NULL)
+ return (FALSE);
+
+ slice_hook = NULL;
+ init_signal_handling ();
+ CalloutTrampIn tramp = &Scm_continue_start_glib;
+ gboolean retval = TRUE;
+
+ /* Prep the machine for re-entry via scheme_source->dispatch(),
+ which should continue with the seemingly aborted application of
+ C-CALL-CONTINUE, which should call Scm_continue_start_glib().
+ That function expects one gboolean in the top CSTACK frame. */
+ callout_unseal (tramp);
+ CSTACK_PUSH (gboolean, retval);
+ CSTACK_PUSH (int, cstack_depth);
+ CSTACK_PUSH (CalloutTrampIn, tramp);
+
+ install_scheme_source ();
+ loop = g_main_loop_new (NULL, TRUE);
+ g_main_loop_run (loop);
+ g_main_loop_unref (loop);
+ destroy_scheme_source ();
+ return (FALSE);
+}
+
+void
+stop_glib (void)
+{
+ /* Returns TRUE when successful. */
+
+ if (scheme_source == NULL)
+ return;
+ g_main_loop_quit (loop);
+ /* NOTREACHED */
+}
+
+void
+run_glib (unsigned long registry, double time)
+{
+ /* Return to the toolkit with the scheme_source set up to dispatch
+ to Scheme again when I/O is ready, or a certain TIME has passed.
+ If TIME has already passed, the I/O registry is ignored and
+ Scheme is ready to run again immediately. If I/O is empty, the
+ simulated poll should not re-enter Scheme until TIME. */
+
+ set_registry (scheme_source,
+ glib_registry (registry),
+ time);
+ if (tracing_glib_select)
+ {
+ GSList * gpollfds = scheme_source->gpollfds;
+ gchar * fdstr = gpollfds_string (gpollfds);
+ fprintf (stderr, ";run_glib%s%s until %.1f\n",
+ gpollfds == NULL ? "" : " waiting on", fdstr, time);
+ fflush (stderr);
+ if (fdstr[0] != '\0')
+ g_free (fdstr);
+ }
+
+ if (slice_hook != NULL) (*slice_hook)();
+
+ /* The c-call primitive has arranged for c-call-continue to run (and
+ thus Scm_run_glib_continue) when Scheme continues. */
+ abort_to_c ();
+ /*NOTREACHED*/
+}
+
+void
+yield_glib (void)
+{
+ scheme_source->runnable = TRUE;
+ trace (";yield_glib: runnable at %.1f\n", OS_real_time_clock ());
+}
+\f
+/* Glib Select Registries -- GSLists of GPollFDs. */
+
+/* SELECT_MODE_ -> GIOCondition */
+#define DECODE_MODE(mode) \
+ (((((mode) & SELECT_MODE_READ) != 0) ? G_IO_IN : 0) \
+ | ((((mode) & SELECT_MODE_WRITE) != 0) ? G_IO_OUT : 0))
+
+/* GIOCondition -> SELECT_MODE_ */
+#define ENCODE_MODE(revents) \
+ (((((revents) & G_IO_IN) != 0) ? SELECT_MODE_READ : 0) \
+ | ((((revents) & G_IO_OUT) != 0) ? SELECT_MODE_WRITE : 0) \
+ | ((((revents) & G_IO_ERR) != 0) ? SELECT_MODE_ERROR : 0) \
+ | ((((revents) & G_IO_HUP) != 0) ? SELECT_MODE_HUP : 0))
+
+static GSList *
+glib_registry (unsigned long registry)
+{
+ /* Construct Glib's version of a select_registry_t. */
+
+ int len = OS_select_registry_length (registry);
+ int i = 0;
+ GSList * list = NULL;
+
+ while (i < len)
+ {
+ int fd;
+ unsigned int mode;
+ GPollFD * item = g_malloc (sizeof (GPollFD));
+ OS_select_registry_entry (registry, i, (&fd), (&mode));
+ item->fd = fd;
+ item->events = DECODE_MODE (mode) | G_IO_ERR | G_IO_HUP;
+ item->revents = 0;
+ list = g_slist_prepend (list, item);
+ i += 1;
+ }
+ return (list);
+}
+
+static gchar *
+gpollfds_string (GSList * gpollfds)
+{
+ /* Construct a string describing the fds and r/w flags in GPOLLFDS,
+ e.g. " 0(r)" */
+
+ gchar * string = "";
+ GSList * scan = gpollfds;
+ while (scan != NULL)
+ {
+ GPollFD * gfd = scan->data;
+ int mode = (gfd->events) & (~(G_IO_HUP|G_IO_ERR));
+ gchar * next = g_strdup_printf ("%s %d(%s)", string, gfd->fd,
+ (mode == (G_IO_IN|G_IO_OUT) ? "rw"
+ : mode == G_IO_IN ? "r"
+ : mode == G_IO_OUT ? "w" : "?"));
+ if (string[0] != '\0')
+ g_free (string);
+ string = next;
+ scan = scan->next;
+ }
+ return (string);
+}
+
+gchar *
+current_gpollfds_string (void)
+{
+ return (gpollfds_string (scheme_source->gpollfds));
+}
+
+gboolean
+glib_select_trace_p (void)
+{
+ return (tracing_glib_select);
+}
+
+void
+glib_select_trace (gboolean trace_p)
+{
+ tracing_glib_select = trace_p;
+}
+\f
+/* signal_forwarder
+
+ This signal handler can run in any thread because it forwards the
+ signal to the scheme_thread. When the handler (subsequently) finds
+ itself running in the scheme_thread, it invokes the original
+ handler. */
+
+#include <signal.h>
+#include <pthread.h>
+static const char * errno_name (int err);
+static void complain (const char *format, ...);
+
+static pthread_t scheme_thread;
+static struct handler_record * old_handlers = NULL;
+struct handler_record
+{
+ int signo;
+ void (*handler)(int, siginfo_t *, void *);
+ struct handler_record *next;
+};
+
+void
+signal_forwarder (int signo, siginfo_t *siginfo, void *ptr)
+{
+ pthread_t self;
+
+ self = pthread_self ();
+ if (self == scheme_thread)
+ {
+ struct handler_record * scan;
+
+ scan = old_handlers;
+ while (scan != NULL)
+ {
+ if (scan->signo == signo)
+ {
+ (scan->handler)(signo, siginfo, ptr);
+ return;
+ }
+ scan = scan->next;
+ }
+ complain (";signal_forwarder: no handler for signo %d\n", signo);
+ }
+ else
+ {
+ int err;
+
+ err = pthread_kill (scheme_thread, signo);
+ if (err != 0)
+ {
+ complain (";signal_forwarder: pthread_kill failed: %s\n",
+ errno_name (err));
+ sleep (1);
+ }
+ }
+}
+
+static void
+init_signal_forwarder (int signo)
+{
+ int err;
+ struct handler_record *hrec;
+ struct sigaction act;
+
+ err = sigaction (signo, 0, (&act));
+ if (err != 0)
+ {
+ complain ("init_signal_forwarder: sigaction access failed\n");
+ return;
+ }
+
+ if (((act.sa_flags & SA_SIGINFO) == 0)
+ && ((act.sa_handler == SIG_DFL)
+ || (act.sa_handler == SIG_IGN)))
+ return;
+
+ if ((act.sa_flags & SA_SIGINFO) == 0)
+ {
+ complain ("init_signal_forwarder: no SA_SIGINFO\n");
+ return;
+ }
+
+ hrec = malloc (sizeof (struct handler_record));
+ if (hrec == NULL)
+ {
+ complain ("init_signal_forwarder: malloc failed\n");
+ return;
+ }
+ hrec->signo = signo;
+ hrec->handler = act.sa_sigaction;
+ hrec->next = old_handlers;
+ act.sa_sigaction = &signal_forwarder;
+ err = sigaction (signo, &act, 0);
+ if (err != 0)
+ complain ("init_signal_forwarder: sigaction modify failed\n");
+ old_handlers = hrec;
+}
+
+static void
+init_signal_handling (void)
+{
+ scheme_thread = pthread_self ();
+ foreach_async_signal (&init_signal_forwarder);
+}
+
+static const char *
+errno_name (int err)
+{
+ unsigned long length;
+ const char ** names;
+ OS_syserr_names (&length, &names);
+ if (err < length)
+ return names[err];
+ else
+ return "unknown errno";
+}
+
+static void
+complain (const char *format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ vfprintf (stderr, format, args);
+ fflush (stderr);
+ va_end (args);
+}
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2014 Matthew Birkholz
This file is part of MIT/GNU Scheme.
|#
;;;; GObjects
-;;; package: (gtk gobject)
+;;; package: (glib gobject)
+
+(C-include "glib")
(define-class <gobject> ()
(set! gquark-from-string-cache (make-string-hash-table))
(set! gquark-to-string-cache (make-eqv-hash-table))
unspecific)
-\f
-;;; GdkPixbufLoaders
-
-(define-class (<pixbuf-loader> (constructor ()))
- (<gobject>)
- (port define standard initial-value #f)
- (thread define standard initial-value #f)
- (size define standard initial-value #f)
- (pixbuf define standard initial-value #f)
- (error-message define standard initial-value #f)
- (closed? define standard initial-value #f)
- (size-hook define standard initial-value #f
- modifier %set-pixbuf-loader-size-hook!)
- (pixbuf-hook define standard initial-value #f
- modifier %set-pixbuf-loader-pixbuf-hook!)
- (update-hook define standard initial-value #f)
- (close-hook define standard initial-value #f
- modifier %set-pixbuf-loader-close-hook!))
-
-(define-class (<pixbuf> (constructor ()))
- (<gobject>))
-
-(define-method initialize-instance ((pixbuf <pixbuf>))
- (call-next-method pixbuf)
- (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|))
-
-(define-method initialize-instance ((loader <pixbuf-loader>))
- (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)
- (g-signal-connect loader (C-callback "area_prepared")
- pixbuf-loader-area-prepared)
- (g-signal-connect loader (C-callback "area_updated")
- 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)
- (%trace "; pixbuf-loader-area-prepared "loader"\n")
- (let* ((alien (gobject-alien loader))
- (pixbuf (let ((p (pixbuf-loader-pixbuf loader)))
- (if p
- (error "Pixbuf loader already has a pixbuf:" loader)
- (make-pixbuf))))
- (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)))))
-
-(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 (load-pixbuf-from-port loader input-port)
- (without-interrupts
- (lambda ()
- (if (pixbuf-loader-port loader)
- (error "Pixbuf loader has already started:" loader))
- (set-pixbuf-loader-port! loader input-port)
- (let ((thread (create-pixbuf-loader-thread loader)))
- (set-pixbuf-loader-thread! loader thread)
- (detach-thread thread)))))
-
-(define (create-pixbuf-loader-thread loader)
- (create-thread
- #f (lambda ()
- (%trace "; "loader" started in "(current-thread)"\n")
- (let ((port (pixbuf-loader-port loader))
- (alien (gobject-alien loader))
- (gerror* (malloc (C-sizeof "*") '(* |GError|)))
- (buff (allocate-external-string 4200)))
- (C->= gerror* "* GError" 0)
- (let ((buff-address (external-string-descriptor buff)))
-
- (define (note-done)
- (free gerror*)
- (without-interrupts
- (lambda ()
- (set-pixbuf-loader-closed?! loader #t)
- (close-input-port port)))
- (%trace "; "loader" closed by "(current-thread)"\n")
- (let ((proc (pixbuf-loader-close-hook loader)))
- (if proc
- (proc loader))))
-
- (define (note-error)
- (let* ((gerror (C-> gerror* "* GError"))
- (message (or (and (not (alien-null? gerror))
- (c-peek-cstring
- (C-> gerror "GError message")))
- "GError pointer not set.")))
- (if (not (alien-null? gerror))
- (begin
- (C-call "g_error_free" gerror)))
- (set-pixbuf-loader-error-message! loader message))
- (note-done))
-
- (let loop ()
- (let ((n (input-port/read-string! port buff)))
- (cond ((and (fix:zero? n) (eof-object? (peek-char port)))
- (if (fix:zero? (C-call "gdk_pixbuf_loader_close"
- alien gerror*))
- (note-error)
- (note-done)))
- ((not (fix:zero?
- (C-call "gdk_pixbuf_loader_write"
- alien buff-address n gerror*)))
- (loop))
- (else
- (note-error))))))))))
-
-(define (load-pixbuf-from-file loader filename)
- (load-pixbuf-from-port
- loader (open-binary-input-file (->namestring (->truename filename)))))
-
-(define (set-pixbuf-loader-size-hook! loader receiver)
- (without-interrupts
- (lambda ()
- (%set-pixbuf-loader-size-hook! loader receiver)
- (let ((size (pixbuf-loader-size loader)))
- (if size (receiver (car size) (cdr size)))))))
-
-(define (set-pixbuf-loader-pixbuf-hook! loader receiver)
- (without-interrupts
- (lambda ()
- (%set-pixbuf-loader-pixbuf-hook! loader receiver)
- (let ((pixbuf (pixbuf-loader-pixbuf loader)))
- (if pixbuf (receiver pixbuf))))))
-
-(define (set-pixbuf-loader-close-hook! loader thunk)
- (without-interrupts
- (lambda ()
- (%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-operator (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!)
--- /dev/null
+#| -*-Scheme-*-
+
+Load the Glib option. |#
+
+(load-option 'SOS)
+(with-loader-base-uri (system-library-uri "glib/")
+ (lambda ()
+ (load-package-set "glib")))
+(add-subsystem-identification! "Glib" '(0 5))
+((access glib-start (->environment '(glib main))))
\ No newline at end of file
--- /dev/null
+Structure and construction of the MIT/GNU Scheme source tree
+
+This README delves into the details of building MIT/GNU Scheme from
+source on GNU/Linux. If you found this README in a binary
+distribution, you probably want the installation instructions in
+../doc/user-manual/mit-scheme-user.info node "Installation", also
+available online at http://www.gnu.org/software/mit-scheme/.
+
+The rest of this file assumes you were able to successfully complete
+an installation. Mit-scheme is used to build mit-scheme, so a binary
+distribution must be installed first. The only alternative is to
+cross-compile on a host that has a binary distribution installed.
+
+If you have the "Portable C" distribution, you have the result of LIAR
+cross-compiling itself to C. The resulting .c files can be compiled
+almost anywhere, e.g. on a 64bit target withOUT an mit-scheme already
+installed. To build mit-scheme from this distribution, see node
+"Portable C Installation" in ../doc/user-manual/mit-scheme-user.info,
+also available online at http://www.gnu.org/software/mit-scheme/. To
+build this distribution from sources, use src/etc/make-liarc-dist.sh.
+\f
+Directories
+===========
+
+MIT/GNU Scheme is a large program consisting of many subdirectories.
+These subdirectories can be further grouped together into rough
+functional subsystems.
+
+The core subsystem consists of these directories:
+
+* "microcode" contains the C code that is used to build the executable
+ program "scheme".
+
+* "runtime" contains the bulk of the run-time library, including
+ almost everything documented in the reference manual.
+
+* "runtime-check" is a build directory used to make alternate run-time
+ library binaries that are safer than the standard binaries. The
+ standard binaries are compiled with type-checking disabled for many
+ common operations; the alternate binaries have type-checking
+ enabled.
+
+* "sos" contains the SOS object-oriented programming extension.
+
+* "star-parser" contains the pattern-matching parser language
+ extension.
+
+* "win32" contains extra parts of the run-time library that are
+ specific to the Microsoft Windows platform.
+
+* "xml" contains support for XML and XHTML I/O.
+
+* "ffi" provides syntax for calling foreign (C) functions and
+ manipulating alien (C) data.
+
+The compiler subsystem consists of these three directories:
+
+* "sf" contains a program that translates Scheme source code to an
+ internal binary format called SCode. SCode is the internal
+ representation used by the MIT/GNU Scheme interpreter. The "sf"
+ program also performs a handful of optimizations, such as
+ user-directed beta substitution and early binding of known variables
+ such as CAR.
+
+* "compiler" contains the native-code compiler. This program
+ translates SCode to machine-language instructions.
+
+* "cref" is a cross-reference program that also implements a
+ rudimentary module system.
+
+The editor subsystem consists of two directories:
+
+* "edwin" contains our Emacs-like editor written in Scheme.
+
+* "imail" contains an email-reading program for Edwin.
+
+There is one C/Unix FFI wrapper thus far:
+
+* "gdbm" wraps libgdbm, the GNU dbm database routines, and provides a
+ drop-in replacement for the microcode module based package (runtime
+ gdbm).
+\f
+These are miscellaneous extras:
+
+* "6001" is extra code used here at MIT for teaching 6.001, our
+ introductory computer-science course based on "Structure and
+ Interpretation of Computer Programs". "sicp" contains an older
+ version of this code that is no longer in use (and probably no
+ longer works).
+
+* "etc" contains miscellaneous files for building the program.
+
+* "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.
+
+* "ssp" is an implementation of "Scheme Server Pages" that supports
+ server-side web programming. It works in conjunction with Apache
+ and mod-lisp.
+
+* "xdoc" is a web-programming document language, used at MIT for an
+ experimental electronics circuit course during spring term 2004.
+ This language is no longer in active use and will not be supported.
+ But it is a good example of "ssp" usage.
+
+These directories are no longer actively in use and the code they
+contain may not work:
+
+* "pcsample" contains a profiling extension.
+
+* "swat" contains an extension that interfaces MIT/GNU Scheme to the
+ Tk graphical toolkit.
+
+* "wabbit" contains program for finding all of the objects that
+ contain pointers to a given object.
+\f
+Building from source on unix systems
+====================================
+
+Building MIT/GNU Scheme from the sources in the git repository is a
+multi-stage process designed around a number of "build states" and
+specific commands that move the build tree from one state to another.
+These are the build states, ordered from least to most "built".
+
+* The `fresh' state is the initial state of the tree when it is
+ freshly checked out of the git repository.
+
+* The `distribution' state is what we distribute to the world. In
+ this state, all of the target-system independent configuration has
+ been done.
+
+* In the `configured' state, the tree is customized for a particular
+ target system, but it is not yet compiled.
+
+* In the `compiled' state, the tree is fully compiled.
+
+The following table shows the commands used to transition the build
+tree from one build state to another. All of the commands must be run
+in the "src" directory.
+
+ From To Command
+ ------------ ------------ ---------------------
+ fresh distribution ./Setup.sh
+ distribution configured ./configure
+ configured compiled make
+ compiled configured make clean
+ compiled distribution make distclean
+ compiled fresh make maintainer-clean
+ configured distribution make distclean
+ configured fresh make maintainer-clean
+
+Thus the following sequence of commands can be used to build and
+install MIT/GNU Scheme, assuming you have already installed a
+compatible binary release.
+
+ ./Setup.sh
+ ./configure
+ make
+ make install
+
+Note that the "./Setup.sh" command requires a compiler that supports
+the "-M" option for generating dependencies. Normally this step is
+executed on a GNU/Linux system.
+
+All of these commands require a working mit-scheme command from a
+compatible binary release. This "host scheme" is usually any recent
+release, but the most recent is most likely to have all of the runtime
+primitives and macros and whatnot required by the latest sources. If
+you have the latest release installed and working, yet cannot compile
+the latest sources, please feel free to report this as a bug, via the
+bug tracking system mentioned on the project homepage:
+
+ http://www.gnu.org/software/mit-scheme/
+
+If you have installed your host scheme somewhere other than the usual
+system-wide location(s), you may want to set the MIT_SCHEME_EXE
+environment variable. The Makefiles expect it to be the host scheme's
+command name. For information about installing MIT/GNU Scheme in
+unusual locations, please see the Unix Installation instructions.
+\f
+Building an incompatible compiler
+=================================
+
+If the basic compiler data structures have changed, it may not be
+possible to directly build the compiler by invoking make. (This is a
+known bug.)
+
+However, it is possible to build the compiler from the Scheme sources
+if you have a working installation with a runtime band. Here is how:
+
+ 1. Put the source tree into the `configured' state as per the
+ above instructions.
+
+ 2. Make the "src/compiler/" directory be your working directory.
+
+ 3. `Syntax' the compiler with these steps:
+
+ a. Start scheme with the runtime band:
+ scheme --band runtime.com
+
+ b. ]=> (load-option 'sf)
+
+ c. ]=> (load "compiler.sf")
+
+ d. ]=> (exit)
+
+ 4. Compile the compiler with these steps:
+
+ a. Start scheme with the runtime band:
+ scheme --band runtime.com
+
+ b. ]=> (load-option 'sf)
+
+ c. ]=> (load "make")
+
+ d. ]=> (load "compiler.cbf")
+
+ e. ]=> (exit)
+
+ 5. Build a new compiler band with these steps:
+
+ a. Start scheme with the runtime band:
+ scheme --band runtime.com
+
+ b. ]=> (load-option 'cref)
+
+ c. ]=> (load-option 'sf)
+
+ d. ]=> (load "make")
+
+ e. ]=> (disk-save "compiler-band.com")
+
+The resulting band, compiler-band.com, should be suitable for
+compiling the compiler.
+\f
gdk/gdkcairo.h |#
-(include "pangocairo")
+;(include "pangocairo")
(extern (* cairo_t) gdk_cairo_create
(window (* GdkWindow)))
(enum (GDK_CURRENT_TIME))
(typedef GdkRectangle cairo_rectangle_int_t)
+(typedef cairo_rectangle_int_t
+ (struct _cairo_rectangle_int
+ (x int)
+ (y int)
+ (width int)
+ (height int)))
(typedef GdkAtom (* (struct _GdkAtom)))
;(include "gobject/gbinding")
;(include "gobject/gboxed")
-(include "gobject/genums")
-(include "gobject/gobject")
-(include "gobject/gparam")
-(include "gobject/gparamspecs")
-(include "gobject/gsignal")
+;;;(include "gobject/genums")
+;;;(include "gobject/gobject")
+(typedef GObject (struct _GObject))
+(struct _GObject
+ (g_type_instance GTypeInstance)
+ ;; < private >
+ (ref_count guint)
+ (qdata (* GData)))
+;;;(include "gobject/gparam")
+;;;(include "gobject/gparamspecs")
+;;;(include "gobject/gsignal")
;(include "gobject/gsourceclosure")
-(include "gobject/gtype")
+;;;(include "gobject/gtype")
+(typedef GType guint)
+(typedef GTypeInstance (struct _GTypeInstance))
+(struct _GTypeInstance
+ ;; < private >
+ (g_class (* GTypeClass)))
+(extern gpointer g_object_ref_sink (object gpointer))
+(extern gpointer g_object_ref (object gpointer))
+(extern void g_object_unref (object gpointer))
;(include "gobject/gtypemodule")
;(include "gobject/gtypeplugin")
-(include "gobject/gvalue")
+;;;(include "gobject/gvalue")
;(include "gobject/gvaluearray")
-(include "gobject/gvaluetypes")
\ No newline at end of file
+;;;(include "gobject/gvaluetypes")
\ No newline at end of file
#| -*-Scheme-*-
-glib-2.0/glib.h |#
-
-;(include "glib/galloca")
-;(include "glib/garray")
-;(include "glib/gasyncqueue")
-;(include "glib/gatomic")
-;(include "glib/gbacktrace")
-;(include "glib/gbase64")
-;(include "glib/gbitlock")
-;(include "glib/gbookmarkfile")
-;(include "glib/gcache")
-;(include "glib/gchecksum")
-;(include "glib/gcompletion")
-;(include "glib/gconvert")
-;(include "glib/gdataset")
-;(include "glib/gdate")
-;(include "glib/gdatetime")
-;(include "glib/gdir")
-(include "glib/gerror")
-;(include "glib/gfileutils")
-;(include "glib/ghash")
-;(include "glib/ghook")
-;(include "glib/ghostutils")
-;(include "glib/giochannel")
-;(include "glib/gkeyfile")
-(include "glib/glist")
-;(include "glib/gmacros")
-;(include "glib/gmain")
-;(include "glib/gmappedfile")
-;(include "glib/gmarkup")
-;(include "glib/gmem")
-;(include "glib/gmessages")
-;(include "glib/gnode")
-;(include "glib/goption")
-;(include "glib/gpattern")
-;(include "glib/gpoll")
-;(include "glib/gprimes")
-;(include "glib/gqsort")
-(include "glib/gquark")
-;(include "glib/gqueue")
-;(include "glib/grand")
-;(include "glib/grel")
-;(include "glib/gregex")
-;(include "glib/gscanner")
-;(include "glib/gsequence")
-;(include "glib/gshell")
-;(include "glib/gslice")
-;(include "glib/gslist")
-;(include "glib/gspawn")
-;(include "glib/gstrfuncs")
-;(include "glib/gstring")
-;(include "glib/gtestutils")
-;(include "glib/gthread")
-;(include "glib/gthreadpool")
-;(include "glib/gtimer")
-;(include "glib/gtree")
-(include "glib/gtypes")
-;(include "glib/gunicode")
-;(include "glib/gurifuncs")
-;(include "glib/gutils")
-(include "glib/gvariant")
\ No newline at end of file
+ Just the glib declarations needed by the gtk shim. |#
+
+(typedef gint8 char)
+(typedef gint16 short)
+;(typedef gint32 int)
+;(typedef gint64 long)
+(typedef guint8 uchar)
+(typedef guint16 ushort)
+(typedef guint32 uint)
+;(typedef guint64 ulonglong)
+;(typedef gssize int)
+(typedef gsize uint)
+
+;(typedef gchar char)
+(typedef gshort short)
+;(typedef glong long)
+(typedef gint int)
+(typedef gboolean gint)
+
+;(typedef guchar uchar)
+;(typedef gushort ushort)
+;(typedef gulong ulong)
+(typedef guint uint)
+
+(typedef gdouble double)
+
+(typedef gpointer (* void))
+
+(extern gpointer g_try_malloc0 (n_bytes gsize))
+(extern void g_free (mem gpointer))
+(extern void g_error_free (error (* GError)))
+
+(typedef GError (struct _GError))
+
+(struct _GError
+ (domain GQuark)
+ (code gint)
+ (message (* gchar)))
+
+(typedef GQuark guint32)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-pango-1.0/pango/pangocairo.h |#
-
-(include "pango-context")
-;(include "pango-fontmap")
-(include "pango-layout")
-(include "cairo")
-
-;(typedef PangoCairoFont (struct _PangoCairoFont))
-;(typedef PangoCairoFontMap (struct _PangoCairoFontMap))
-
-(extern (* PangoLayout) pango_cairo_create_layout (cr (* cairo_t)))
-(extern void pango_cairo_update_layout (cr (* cairo_t))(layout (* PangoLayout)))
-(extern void pango_cairo_show_layout (cr (* cairo_t))(layout (* PangoLayout)))
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-MIT_SCHEME_EXE = mit-scheme
-exe = '$(MIT_SCHEME_EXE)' --batch-mode
+MITSCHEME_EXE = mit-scheme
+exe = '$(MITSCHEME_EXE)' --batch-mode
CFLAGS = @CFLAGS@
CPPFLAGS = @CPPFLAGS@
echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
`pkg-config --cflags gtk+-3.0` -c $<
-gtk-shim.c gtk-const.c gtk-types.bin: gtk-shim.h gtk.cdecl \
- Includes/*.cdecl Includes/*/*.cdecl
+gtk-shim.c gtk-const.c gtk-types.bin: gtk-shim.h gtk.cdecl Includes/*.cdecl
echo '(generate-shim "gtk" "#include \"gtk-shim.h\"")' | $(exe)
gtk-const.bin: gtk-const.scm
(set! *initial-options-file* (merge-pathnames "gtk-optiondb" dirname)))
(load-option 'GTK)
-(if (gtk-thread-running?)
+(if (gtk-initialized?)
(load "gtk-check" (->environment '(GTK)))
(warn "Could not test the GTK subsystem without a DISPLAY."))
\ No newline at end of file
;;;; Compile the GTK wrapper.
(load-option 'CREF)
-(load-option 'SOS)
+(load-option 'CAIRO)
(load-option 'FFI)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
;; The wrappers use the FFI, c-includes, and some integrable
;; definitions in gtk.scm. Dependencies between them are
;; rare.
- (compile-file "gobject" '("gtk") (->environment '(gtk gobject)))
- (compile-file "gio" '("gtk") (->environment '(gtk gio)))
- (compile-file "pango" '("gtk") (->environment '(gtk pango)))
- (compile-file "cairo" '("gtk") (->environment '(gtk cairo)))
+ (compile-file "gdk" '("gtk") (->environment '(gtk gdk)))
(compile-file "gtk-widget" '("gtk") (->environment '(gtk gtk-widget)))
(compile-file "scm-widget" '("gtk") (->environment '(gtk widget)))
- (compile-file "fix-layout" '("pango" "cairo" "gtk")
- (->environment '(gtk fix-layout)))
+ (compile-file "fix-layout" '("gtk") (->environment '(gtk fix-layout)))
(compile-file "keys" '("gtk") (->environment '(gtk keys)))
(compile-file "main" '("gtk") (->environment '(gtk main)))
- (compile-file "thread" '("main") (->environment '(gtk thread)))
+ ;(compile-file "thread" '("main") (->environment '(gtk thread)))
(compile-file "gtk-ev" '("gtk") (->environment '(gtk event-viewer)))
(compile-file "gtk-graphics" '("gtk")
(->environment '(runtime gtk-graphics)))
(fix:- y2 y1))))))
(define (layout-draw-callback layout cr)
+ (set-alien/ctype! cr '|cairo_t|)
(%trace2 ";draw "layout" at "
(cairo-clip-extents
cr (lambda (min-x min-y max-x max-y)
(lambda (ink)
(if (fix-ink-in? ink layout area)
(begin
- (C-call "cairo_save" cr)
+ (cairo-save cr)
(fix-ink-draw-callback ink layout window cr area)
- (C-call "cairo_restore" cr))))
+ (cairo-restore cr))))
(fix-drawing-display-list drawing))
(%trace2 "; no drawing\n"))))
(vadjustment (fix-layout-vadjustment widget))
(hadjustment (fix-layout-hadjustment widget))
(value (floor->exact
- (C-call "gtk_adjustment_get_value" (gobject-alien adjustment)))))
+ (C-call "gtk_adjustment_get_value"
+ (gobject-alien adjustment)))))
(cond ((eq? adjustment vadjustment)
(%trace2 ";vadjustment to "value"\n")
(scroll widget (fix-rect-x window-extent) value))
(lambda (x y dx dy)
(let ((x (fix:- x (fix-rect-x view)))
(y (fix:- y (fix-rect-y view))))
- (C-call "cairo_move_to" cr (->flonum x) (->flonum y))
- (C-call "cairo_rel_line_to" cr (->flonum dx) (->flonum dy)))))
+ (cairo-move-to cr x y)
+ (cairo-rel-line-to cr dx dy))))
(set-line-options! cr ink)
(let ((color (get-option ink 'DASH-COLOR '())))
(if (not (null? color))
(begin
- (C-call "cairo_save" cr)
- (set-source-rgba cr color)
- (C-call "cairo_stroke_preserve" cr)
- (C-call "cairo_restore" cr))))
+ (cairo-save cr)
+ (cairo-set-source-color cr color)
+ (cairo-stroke-preserve cr)
+ (cairo-restore cr))))
(set-line-dashes! cr ink)
- (C-call "cairo_stroke" cr)))
-
-(define-integrable (set-source-rgba cr color)
- (C-call "cairo_set_source_rgba" cr
- (flo:vector-ref color 0)
- (flo:vector-ref color 1)
- (flo:vector-ref color 2)
- (flo:vector-ref color 3)))
+ (cairo-stroke cr)))
(define (set-line-options! cr ink)
(for-each
(let ((name (car entry))
(value (cdr entry)))
(case name
- ((COLOR) (set-source-rgba cr value))
+ ((COLOR) (cairo-set-source-color cr value))
;;((LINE-CAP) ...)
;;((LINE-JOIN) ...)
;;((LINE-MITER-LIMIT) ...)
- ((LINE-WIDTH) (C-call "cairo_set_line_width" cr value)))))
+ ((LINE-WIDTH) (cairo-set-line-width cr value)))))
(draw-ink-options ink)))
(define (set-line-dashes! cr ink)
(let ((entry (assq 'DASHES (draw-ink-options ink))))
(if entry
- (let* ((num (length (cdr entry)))
- (dashes (malloc (fix:* num (C-sizeof "double")) 'double))
- (scan (copy-alien dashes)))
- (for-each
- (lambda (len)
- (C->= scan "double" len)
- (alien-byte-increment! scan (C-sizeof "double")))
- (cdr entry))
- (C-call "cairo_set_dash" cr dashes num 0)
- (free dashes)))))
+ (cairo-set-dash cr (cdr entry)))))
(define-integrable (half-line-width ink)
(fix:max 1 (fix:1+ (floor->exact (quotient (get-option ink 'LINE-WIDTH 1.)
(lambda (x y width height)
(let ((x (fix:- x (fix-rect-x view)))
(y (fix:- y (fix-rect-y view))))
- (C-call "cairo_rectangle" cr
- (->flonum x) (->flonum y)
- (->flonum width) (->flonum height))
+ (cairo-rectangle cr x y width height)
(let ((fill (get-option ink 'FILL '())))
(if (not (null? fill))
(begin
- (C-call "cairo_save" cr)
+ (cairo-save cr)
(set-fill-options! cr ink)
- (C-call "cairo_fill_preserve" cr)
- (C-call "cairo_restore" cr))))
+ (cairo-fill-preserve cr)
+ (cairo-restore cr))))
(let ((outline (get-option ink 'OUTLINE '())))
(if (not (null? outline))
(begin
(set-outline-options! cr ink)
- (C-call "cairo_stroke" cr)))))))))
+ (cairo-stroke cr)))))))))
(define (set-fill-options! cr ink)
;; For filling ovals, rectangles...
(let ((name (car entry))
(value (cdr entry)))
(case name
- ((FILL) (set-source-rgba cr value)))))
+ ((FILL) (cairo-set-source-color cr value)))))
(draw-ink-options ink)))
(define (set-outline-options! cr ink)
(let ((name (car entry))
(value (cdr entry)))
(case name
- ((OUTLINE) (set-source-rgba cr value))
- ((LINE-WIDTH) (C-call "cairo_set_line_width" cr value))
+ ((OUTLINE) (cairo-set-source-color cr value))
+ ((LINE-WIDTH) (cairo-set-line-width cr value))
((DASHES) (set-line-dashes! cr ink)))))
(draw-ink-options ink)))
(if (not (null? vertices))
(let ((view-x (fix-rect-x view))
(view-y (fix-rect-y view)))
- (C-call "cairo_move_to" cr
- (->flonum (fix:- (caar vertices) view-x))
- (->flonum (fix:- (cdar vertices) view-y)))
+ (cairo-move-to cr
+ (fix:- (caar vertices) view-x)
+ (fix:- (cdar vertices) view-y))
(let loop ((verts (cdr vertices)))
(if (not (null? verts))
(begin
- (C-call "cairo_line_to" cr
- (->flonum (fix:- (caar verts) view-x))
- (->flonum (fix:- (cdar verts) view-y)))
+ (cairo-line-to cr
+ (fix:- (caar verts) view-x)
+ (fix:- (cdar verts) view-y))
(loop (cdr verts)))))
(let ((fill (get-option ink 'FILL '())))
(if (not (null? fill))
(begin
(set-fill-options! cr ink)
- (C-call "cairo_fill_preserve" cr))))
+ (cairo-fill-preserve cr))))
(let ((outline (get-option ink 'OUTLINE '())))
(if (not (null? outline))
(begin
(set-outline-options! cr ink)
- (C-call "cairo_stroke" cr))))))))
+ (cairo-stroke cr))))))))
(define (recache-polygon-extent! ink)
(let ((vertices (polygon-ink-vertices ink)))
(start. (arc-ink-%start-angle ink))
(end. (flo:+ (arc-ink-%start-angle ink)
(arc-ink-%sweep-angle ink))))
- (C-call "cairo_save" cr)
- (C-call "cairo_translate" cr
- (flo:+ x. (flo:/ width. 2.))
- (flo:+ y. (flo:/ height. 2.)))
- (C-call "cairo_scale" cr (flo:/ width. 2.) (flo:/ height. 2.))
- (C-call "cairo_arc" cr 0. 0. 1. start. end.)
- (C-call "cairo_restore" cr)
+ (cairo-save cr)
+ (cairo-translate cr
+ (flo:+ x. (flo:/ width. 2.))
+ (flo:+ y. (flo:/ height. 2.)))
+ (cairo-scale cr (flo:/ width. 2.) (flo:/ height. 2.))
+ (cairo-arc cr 0. 0. 1. start. end.)
+ (cairo-restore cr)
(let ((fill (get-option ink 'FILL '())))
(if (not (null? fill))
(begin
(set-fill-options! cr ink)
- (C-call "cairo_fill_preserve" cr))))
+ (cairo-fill-preserve cr))))
(let ((outline (get-option ink 'OUTLINE '())))
(if (not (null? outline))
(begin
(set-outline-options! cr ink)
- (C-call "cairo_stroke" cr)))))))))
+ (cairo-stroke cr)))))))))
(define (recache-arc-extent! ink)
(with-fix-rect-bounds
(let ((x (fix:- (fix-rect-x rect) (fix-rect-x view)))
(y (fix:- (fix-rect-y rect) (fix-rect-y view))))
(set-text-options! cr ink)
- (C-call "cairo_move_to" cr (->flonum x) (->flonum y))
- (C-call "pango_cairo_show_layout" cr (gobject-alien layout)))))))
+ (cairo-move-to cr x y)
+ (cairo-show-pango-layout cr layout))))))
(define (set-text-options! cr ink)
(for-each
(let ((name (car entry))
(value (cdr entry)))
(case name
- ((COLOR) (set-source-rgba cr value)))))
+ ((COLOR) (cairo-set-source-color cr value)))))
(draw-ink-options ink)))
(define (set-text-ink-position! ink x y)
(generic-fix-ink-move! ink dx dy))
(define (recache-text-extent! ink)
- (let ((layout (text-ink-pango-layout ink))
- (ink-extent (pango-rectangle))
- (logical-extent (pango-rectangle)))
- (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)))
+ (let ((layout (text-ink-pango-layout ink)))
+ (pango-layout-get-pixel-extents
+ layout
+ (lambda (width height)
+ (drawing-damage ink)
+ (set-fix-rect-size! (fix-ink-extent ink) width height)
+ (drawing-damage ink)))))
(define (text-ink-color ink)
(guarantee-text-ink ink 'text-ink-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)))
+ (and (text-ink-pango-layout ink)
+ (pango-layout-xy-to-index (text-ink-pango-layout ink)
+ (fix:- x (fix-rect-x (fix-ink-extent ink)))
+ (fix:- y (fix-rect-y (fix-ink-extent ink))))))
(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)))
+ (and (text-ink-pango-layout ink)
+ (pango-layout-index-to-pos (text-ink-pango-layout ink)
+ index receiver)))
(define (->pango-font-description spec operator)
(cond ((and (alien? spec) (eq? '|PangoFontDescription| (alien/ctype spec)))
(let ((x. (->flonum (fix:- (fix-rect-x extent) (fix-rect-x view))))
(y. (->flonum (fix:- (fix-rect-y extent) (fix-rect-y view)))))
(C-call "gdk_cairo_set_source_pixbuf" cr pixbuf x. y.)
- (C-call "cairo_paint" cr))))))
+ (cairo-paint cr))))))
(define-method fix-ink-move! ((ink <image-ink>) dx dy)
(generic-fix-ink-move! ink dx dy))
(let ((view (fix-layout-view widget))
(extent (fix-ink-extent ink))
(surface (surface-ink-surface ink)))
- (let ((x. (->flonum (fix:- (fix-rect-x extent) (fix-rect-x view))))
- (y. (->flonum (fix:- (fix-rect-y extent) (fix-rect-y view)))))
- (C-call "cairo_set_source_surface" cr surface x. y.)
- (C-call "cairo_paint" cr))))
+ (let ((x (fix:- (fix-rect-x extent) (fix-rect-x view)))
+ (y (fix:- (fix-rect-y extent) (fix-rect-y view))))
+ (cairo-set-source-surface cr surface x y)
+ (cairo-paint cr))))
(define (set-surface-ink-position! ink x y)
(set-fix-rect-position! (fix-ink-extent ink) x y))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2014 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.
+
+|#
+
+;;; GDK objects, procedures.
+;;; package: (gdk)
+
+(define (gdk-cairo-create gdkwindow)
+ (guarantee-gdk-window gdkwindow 'gdk-window-process-updates)
+ (let ((cairo (make-alien '|cairo_t|))
+ (copy (make-alien '|cairo_t|)))
+ (add-gc-cleanup cairo (make-cairo-cleanup copy))
+ (C-call "gdk_cairo_create" copy gdkwindow)
+ (copy-alien-address! cairo copy)
+ (check-cairo-status cairo)
+ cairo))
+
+(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-operator (guarantee-gdk-window object operator)
+ (if (not (and (alien? object) (eq? '|GdkWindow| (alien/ctype object))))
+ (error:wrong-type-argument object "a GdkWindow address" operator)))
+\f
+;;; GdkPixbufLoaders
+
+(define-class (<pixbuf-loader> (constructor ()))
+ (<gobject>)
+ (port define standard initial-value #f)
+ (thread define standard initial-value #f)
+ (size define standard initial-value #f)
+ (pixbuf define standard initial-value #f)
+ (error-message define standard initial-value #f)
+ (closed? define standard initial-value #f)
+ (size-hook define standard initial-value #f
+ modifier %set-pixbuf-loader-size-hook!)
+ (pixbuf-hook define standard initial-value #f
+ modifier %set-pixbuf-loader-pixbuf-hook!)
+ (update-hook define standard initial-value #f)
+ (close-hook define standard initial-value #f
+ modifier %set-pixbuf-loader-close-hook!))
+
+(define-class (<pixbuf> (constructor ()))
+ (<gobject>))
+
+(define-method initialize-instance ((pixbuf <pixbuf>))
+ (call-next-method pixbuf)
+ (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|))
+
+(define-method initialize-instance ((loader <pixbuf-loader>))
+ (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)
+ (g-signal-connect loader (C-callback "area_prepared")
+ pixbuf-loader-area-prepared)
+ (g-signal-connect loader (C-callback "area_updated")
+ 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)
+ (%trace "; pixbuf-loader-area-prepared "loader"\n")
+ (let* ((alien (gobject-alien loader))
+ (pixbuf (let ((p (pixbuf-loader-pixbuf loader)))
+ (if p
+ (error "Pixbuf loader already has a pixbuf:" loader)
+ (make-pixbuf))))
+ (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)))))
+
+(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 (load-pixbuf-from-port loader input-port)
+ (without-interrupts
+ (lambda ()
+ (if (pixbuf-loader-port loader)
+ (error "Pixbuf loader has already started:" loader))
+ (set-pixbuf-loader-port! loader input-port)
+ (let ((thread (create-pixbuf-loader-thread loader)))
+ (set-pixbuf-loader-thread! loader thread)
+ (detach-thread thread)))))
+
+(define (create-pixbuf-loader-thread loader)
+ (create-thread
+ #f (lambda ()
+ (%trace "; "loader" started in "(current-thread)"\n")
+ (let ((port (pixbuf-loader-port loader))
+ (alien (gobject-alien loader))
+ (gerror* (make-gerror-pointer))
+ (buff (allocate-external-string 4200)))
+ (C->= gerror* "* GError" 0)
+ (let ((buff-address (external-string-descriptor buff)))
+
+ (define (note-done)
+ (gerror-pointer-free gerror*)
+ (without-interrupts
+ (lambda ()
+ (set-pixbuf-loader-closed?! loader #t)
+ (close-input-port port)))
+ (%trace "; "loader" closed by "(current-thread)"\n")
+ (let ((proc (pixbuf-loader-close-hook loader)))
+ (if proc
+ (proc loader))))
+
+ (define (note-error)
+ (let* ((gerror (C-> gerror* "* GError"))
+ (message (or (and (not (alien-null? gerror))
+ (c-peek-cstring
+ (C-> gerror "GError message")))
+ "GError pointer not set.")))
+ (set-pixbuf-loader-error-message! loader message))
+ (note-done))
+
+ (let loop ()
+ (let ((n (input-port/read-string! port buff)))
+ (cond ((and (fix:zero? n) (eof-object? (peek-char port)))
+ (if (fix:zero? (C-call "gdk_pixbuf_loader_close"
+ alien gerror*))
+ (note-error)
+ (note-done)))
+ ((not (fix:zero?
+ (C-call "gdk_pixbuf_loader_write"
+ alien buff-address n gerror*)))
+ (loop))
+ (else
+ (note-error))))))))))
+
+(define (make-gerror-pointer)
+ (let ((alien (make-alien '(* |GError|)))
+ (copy (make-alien '(* |GError|))))
+ (add-gc-cleanup alien (make-gerror-pointer-cleanup copy))
+ (C-call "g_try_malloc0" copy (C-sizeof "* GError"))
+ (if (alien-null? copy)
+ (error "Could not create a GError pointer."))
+ (copy-alien-address! alien copy)
+ alien))
+
+(define (make-gerror-pointer-cleanup copy)
+ (named-lambda (cleanup-gerror-pointer)
+ (if (not (alien-null? copy))
+ (let ((gerror (make-alien '|GError|)))
+ (C-> copy "* GError" gerror)
+ (if (not (alien-null? gerror))
+ (C-call "g_error_free" gerror))
+ (C-call "g_free" copy)
+ (alien-null! copy)))))
+
+(define (gerror-pointer-free gerror*)
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? gerror*))
+ (let ((gerror (make-alien '|GError|)))
+ (C-> gerror* "* GError" gerror)
+ (if (not (alien-null? gerror))
+ (C-call "g_error_free" gerror))
+ (C-call "g_free" gerror*)
+ (alien-null! gerror*))))))
+
+(define (load-pixbuf-from-file loader filename)
+ (load-pixbuf-from-port
+ loader (open-binary-input-file (->namestring (->truename filename)))))
+
+(define (set-pixbuf-loader-size-hook! loader receiver)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-size-hook! loader receiver)
+ (let ((size (pixbuf-loader-size loader)))
+ (if size (receiver (car size) (cdr size)))))))
+
+(define (set-pixbuf-loader-pixbuf-hook! loader receiver)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-pixbuf-hook! loader receiver)
+ (let ((pixbuf (pixbuf-loader-pixbuf loader)))
+ (if pixbuf (receiver pixbuf))))))
+
+(define (set-pixbuf-loader-close-hook! loader thunk)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-close-hook! loader thunk)
+ (if (pixbuf-loader-closed? loader)
+ (thunk)))))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ ARGS ...)
+ (if %trace? (outf-error ARGS ...)))))
\ No newline at end of file
(ffi (->environment '(runtime ffi))))
(load "gtk-tests" new)
(load "hello" new)
- (let ((gcp (access gcp new))
- (gls (access gls new))
- (ls (access ls new))
- (await-closed-demos (access await-closed-demos new))
+ (let ((await-closed-demos (access await-closed-demos new))
(registered-callback-count (access registered-callback-count ffi))
(malloced-aliens (named-lambda (malloced-aliens)
(access malloced-aliens ffi))))
(error "Assertion failed:" form))
#t)
- (run-test
- 'gio-copy
- (let ((cwd (directory-pathname (current-load-pathname))))
- (named-lambda (gio-copy-test)
- (with-working-directory-pathname cwd
- (lambda ()
- (let ((file1 "../README.txt")
- (file2 "test-copy-1.txt"))
- (gcp file1 file2)
- (assert equal? (md5-file file2) (md5-file file1)
- `(GCP ,file1 ,file2))))))))
-
- (run-test
- 'gio-list
- (let ((cwd (directory-pathname (current-load-pathname))))
- (named-lambda (gio-list-test)
- (with-working-directory-pathname cwd
- (lambda ()
- (let ((native (sort (ls "../runtime/") string<?))
- (gio (sort (gls "../runtime/") string<?)))
- (assert equal? gio native
- '(GLS "../runtime/"))))))))
-
(run-test
'gtk-demos
(named-lambda (gtk-demos-test)
(define (draw-callback widget cr)
(%trace "; Draw "widget"\n")
+ (set-alien/ctype! cr '|cairo_t|)
(paint-event-window widget cr)
(paint-window widget cr)
#t)
(style (make-alien '|GtkStyleContext|))
(event-box (gtk-event-viewer-event-box widget)))
- (C-call "cairo_rectangle" cr
- (->flonum (-1+ (fix-rect-x event-box)))
- (->flonum (-1+ (fix-rect-y event-box)))
- (->flonum (+ 2 (fix-rect-width event-box)))
- (->flonum (+ 2 (fix-rect-height event-box))))
- (C-call "cairo_stroke" cr)
+ (cairo-rectangle cr
+ (-1+ (fix-rect-x event-box))
+ (-1+ (fix-rect-y event-box))
+ (+ 2 (fix-rect-width event-box))
+ (+ 2 (fix-rect-height event-box)))
+ (cairo-stroke cr)
(C-call "gtk_widget_get_style_context" style alien)
(let ((descrip-box (gtk-event-viewer-description-box widget)))
(let ((desc-bottom (fix-rect-max-y descrip-box))
(space 2)
- (layout (make-alien '|PangoLayout|)))
- (C-call "gtk_widget_create_pango_layout" layout alien 0)
- (C-call "cairo_rectangle" cr
- (->flonum (fix-rect-x descrip-box))
- (->flonum (fix-rect-y descrip-box))
- (->flonum (fix-rect-width descrip-box))
- (->flonum (fix-rect-height descrip-box)))
- (C-call "cairo_clip" cr)
+ (layout (gtk-widget-create-pango-layout widget)))
+ (cairo-rectangle cr
+ (fix-rect-x descrip-box)
+ (fix-rect-y descrip-box)
+ (fix-rect-width descrip-box)
+ (fix-rect-height descrip-box))
+ (cairo-clip cr)
(let loop ((y (fix-rect-y descrip-box))
(lines (gtk-event-viewer-buffer widget)))
(if (null? lines)
unspecific
- (let ((line (car lines))
- (iter (make-alien '|PangoLayoutIter|)))
- (C-call "pango_layout_set_text" layout line -1)
- (C-call "pango_layout_get_iter" iter layout)
- (let ((baseline
- (pangos->pixels
- (C-call "pango_layout_iter_get_baseline"
- iter))))
- (C-call "pango_layout_iter_free" iter)
- (C-call "cairo_move_to" cr 10. (->flonum y))
- (alien-null! iter)
+ (begin
+ (pango-layout-set-text layout (car lines))
+ (let ((baseline (pango-layout-get-baseline layout)))
+ (cairo-move-to cr 10. y)
(C-call "gtk_render_layout" style cr
- 10. (->flonum y) layout)
+ 10. (->flonum y) (gobject-alien layout))
(let ((new-y (fix:+ y (fix:+ baseline space))))
(if (fix:> new-y desc-bottom)
(begin
(set-cdr! lines '())
unspecific)
(loop new-y (cdr lines))))))))
- (C-call "g_object_unref" layout))))))
+ (gobject-unref! layout))))))
(define (paint-event-window widget cr)
(%trace2 ";(paint-event-window "widget" "cr")\n")
(let* ((event-window (gtk-event-viewer-event-window widget))
- (extent (pango-rectangle))
- (layout (make-alien '|PangoLayout|))
+ (layout (gtk-widget-create-pango-layout widget ""))
(title (string-append "Event Window (0x"
(alien/address-string event-window)")")))
- (C-call "pango_cairo_create_layout" layout cr)
- (C-call "pango_layout_set_text" layout title -1)
- (C-call "pango_layout_get_pixel_extents" layout extent 0)
- (C-call "cairo_move_to" cr
- ;;center
- (->flonum
- (quotient (- (fix-rect-width (gtk-event-viewer-event-box widget))
- (C-> extent "PangoRectangle width"))
- 2))
- 10.)
- (C-call "pango_cairo_show_layout" cr layout)
- (C-call "g_object_unref" layout)
- (free extent)
+ (pango-layout-set-text layout title)
+ (pango-layout-get-pixel-extents
+ layout
+ (lambda (width height)
+ (declare (ignore height))
+ (cairo-move-to cr
+ ;;center
+ (quotient (- (fix-rect-width
+ (gtk-event-viewer-event-box widget))
+ width)
+ 2)
+ 10.)))
+ (cairo-show-pango-layout cr layout)
+ (gobject-unref! layout)
unspecific))
(define (push-text ev lines)
(let ((a (gobject-alien ev))
(r (gtk-event-viewer-description-box ev)))
(C-call "gtk_widget_queue_draw_area"
- a (fix-rect-x r) (fix-rect-y r) (fix-rect-width r) (fix-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)
#| -*-Scheme-*-
-Copyright (C) 2013 Matthew Birkholz
+Copyright (C) 2013, 2014 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
(factor (->flonum (/ (min (-1+ width) (-1+ height)) 2))))
(if (not (flo:positive? factor))
(error "Invalid width x height:" width height))
- (C-call "cairo_save" cr)
- (C-call "cairo_scale" cr factor (flo:negate factor))
+ (cairo-save cr)
+ (cairo-scale cr factor (flo:negate factor))
(set-gtk-graphics-scale! graphics factor)
- (C-call "cairo_set_line_width" cr (flo:/ 1.0 factor))
+ (cairo-set-line-width cr (flo:/ 1.0 factor))
(cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
(cairo-matrix k 0. 0.
0. (flo:negate k) 0.)))
- (C-call "cairo_translate" cr 1.0 -1.0)
+ (cairo-translate cr 1.0 -1.0)
(let ((black (->color "black" 'make-gtk-graphics))
(white (->color "white" 'make-gtk-graphics)))
- (C-call "cairo_set_source_rgba" cr
- (color-red white) (color-green white) (color-blue white)
- (color-alpha white))
- (C-call "cairo_paint" cr)
- (C-call "cairo_set_source_rgba" cr
- (color-red black) (color-green black) (color-blue black)
- (color-alpha black))
+ (cairo-set-source-color cr white)
+ (cairo-paint cr)
+ (cairo-set-source-color cr black)
(set-gtk-graphics-bgcolor-name! graphics "white")
(set-gtk-graphics-bgcolor! graphics white)
(set-gtk-graphics-fgcolor-name! graphics "black")
(set-gtk-graphics-fgcolor! graphics black))
(set-gtk-graphics-context! graphics cr)))
-(define gtk-graphics/available? gtk-thread-running?)
+(define gtk-graphics/available? gtk-initialized?)
(define (gtk-graphics/open make-device #!optional width height no-window?)
(let ((width (if (default-object? width) 512 width))
(cr (gtk-graphics-context graphics)))
(if (zero? (- x-right x-left)) (error "Zero width coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
(if (zero? (- y-bottom y-top)) (error "Zero height coordinate limits:" 'x-left x-left 'y-bottom y-bottom 'x-right x-right 'y-top y-top))
- (C-call "cairo_restore" cr) ;back to device coords.
- (C-call "cairo_save" cr)
+ (cairo-restore cr) ;back to device coords.
+ (cairo-save cr)
(let ((x-factor (->flonum (/ (-1+ (fix-rect-width extent))
(- x-right x-left))))
(y-factor (->flonum (/ (-1+ (fix-rect-height extent))
(- y-bottom y-top)))))
- (C-call "cairo_scale" cr x-factor y-factor)
+ (cairo-scale cr x-factor y-factor)
(let ((factor (flo:min (flo:abs x-factor) (flo:abs y-factor))))
(set-gtk-graphics-scale! graphics factor)
- (C-call "cairo_set_line_width" cr (flo:/ 1.0 factor))
+ (cairo-set-line-width cr (flo:/ 1.0 factor))
(cairo-set-font-matrix cr (let ((k (flo:/ 10.0 factor)))
(cairo-matrix k 0. 0.
0. (flo:negate k) 0.)))))
- (C-call "cairo_translate" cr (->flonum (- x-left)) (->flonum (- y-top)))
+ (cairo-translate cr (- x-left) (- y-top))
(let ((fgcolor (gtk-graphics-fgcolor graphics)))
- (C-call "cairo_set_source_rgba" cr
- (color-red fgcolor) (color-green fgcolor) (color-blue fgcolor)
- (color-alpha fgcolor))))
+ (cairo-set-source-color cr fgcolor)))
(set-gtk-graphics-limits! graphics (list x-left y-bottom x-right y-top))))
(define (gtk-graphics/clear device)
(bgcolor-name (gtk-graphics-bgcolor-name graphics)))
(set-gtk-graphics-fgcolor! graphics bgcolor)
(set-gtk-graphics-fgcolor-name! graphics bgcolor-name)
- (C-call "cairo_set_source_rgba" cr
- (color-red bgcolor) (color-green bgcolor) (color-blue bgcolor)
- (color-alpha bgcolor))
- (C-call "cairo_reset_clip" cr)
- (C-call "cairo_paint" cr))))
+ (cairo-set-source-color cr bgcolor)
+ (cairo-reset-clip cr)
+ (cairo-paint cr))))
(define gtk-graphics-point-size
;; A flonum number of pixels.
(x (->flonum x))
(y (->flonum y))
(radius (/ 3.0 (gtk-graphics-scale device))))
- (C-call "cairo_arc" cr x y radius 0. 2pi)
- (C-call "cairo_stroke" cr))))
+ (cairo-arc cr x y radius 0. 2pi)
+ (cairo-stroke cr))))
(define (gtk-graphics/draw-line device x-start y-start x-end y-end)
(let ((graphics (graphics-device/descriptor device)))
(y (->flonum y-start)))
(let ((dx (flo:- (->flonum x-end) x))
(dy (flo:- (->flonum y-end) y)))
- (C-call "cairo_move_to" cr x y)
- (C-call "cairo_rel_line_to" cr dx dy)
- (C-call "cairo_stroke" cr)))))
+ (cairo-move-to cr x y)
+ (cairo-rel-line-to cr dx dy)
+ (cairo-stroke cr)))))
(define (gtk-graphics/draw-text device x y string)
(let ((graphics (graphics-device/descriptor device)))
(let ((cr (gtk-graphics-context graphics))
(x (->flonum x))
(y (->flonum y)))
- (C-call "cairo_move_to" cr x y)
- (C-call "cairo_show_text" cr string))))
+ (cairo-move-to cr x y)
+ (cairo-show-text cr string))))
(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
(x (->flonum x))
(y (->flonum y))
(radius (->flonum radius)))
- (C-call "cairo_arc" cr x y radius 0. 2pi)
- (C-call "cairo_stroke" cr))))
+ (cairo-arc cr x y radius 0. 2pi)
+ (cairo-stroke cr))))
(define (gtk-graphics/move-cursor device x y)
(let ((graphics (graphics-device/descriptor device)))
(let ((cr (gtk-graphics-context graphics))
(x (->flonum x))
(y (->flonum y)))
- (C-call "cairo_move_to" cr x y))))
+ (cairo-move-to cr x y))))
(define (gtk-graphics/drag-cursor device x y)
(let ((graphics (graphics-device/descriptor device)))
(let ((cr (gtk-graphics-context graphics))
(x (->flonum x))
(y (->flonum y)))
- (C-call "cairo_line_to" cr x y)
- (C-call "cairo_stroke" cr))))
+ (cairo-line-to cr x y)
+ (cairo-stroke cr))))
(define (gtk-graphics/set-drawing-mode device mode)
- (let ((graphics (graphics-device/descriptor device))
- (op
- (case mode
- ((0) (C-enum "CAIRO_OPERATOR_CLEAR")) ;GXclear 0
- ((1) (C-enum "CAIRO_OPERATOR_IN")) ;GXand src AND dst
- ((2) (C-enum "CAIRO_OPERATOR_OUT")) ;GXandReverse src AND NOT dst
- ((3) (C-enum "CAIRO_OPERATOR_SOURCE")) ;GXcopy src
- ((4) (C-enum "CAIRO_OPERATOR_DEST_OUT")) ;GXandInverted NOT src AND dst
- ((5) (C-enum "CAIRO_OPERATOR_DEST")) ;GXnoop dst
- ((6) (C-enum "CAIRO_OPERATOR_XOR")) ;GXxor src XOR dst
- ((7) (C-enum "CAIRO_OPERATOR_OVER")) ;GXor src OR dst
- ((8) (warn "unimplemented:" '|GXnor|) #f) ;GXnor NOT src AND NOT dst
- ((9) (warn "unimplemented:" '|GXequiv|) #f) ;GXequiv NOT src XOR dst
- ((10) (warn "unimplemented:" '|GXinvert|) #f) ;GXinvert NOT dst
- ((11) (warn "unimplemented:" '|GXorReverse|) #f) ;GXorReverse src OR NOT dst
- ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted NOT src
- ((13) (warn "unimplemented:" '|GXorInverted|) #f) ;GXorInverted NOT src OR dst
- ((14) (warn "unimplemented:" '|GXnand|) #f) ;GXnand NOT src OR NOT dst
- ((15) (C-enum "CAIRO_OPERATOR_SOURCE")) ;GXset 1
- (else (error:wrong-type-argument mode "a drawing mode"
- 'gtk-graphics/set-drawing-mode)))))
- (C-call "cairo_set_operator" (gtk-graphics-context graphics) op)))
+ (let ((operator
+ (case mode
+ ((0) 'CLEAR) ;GXclear 0
+ ((1) 'IN) ;GXand src AND dst
+ ((2) 'OUT) ;GXandReverse src AND NOT dst
+ ((3) 'SOURCE) ;GXcopy src
+ ((4) 'DEST-OUT) ;GXandInverted NOT src AND dst
+ ((5) 'DEST) ;GXnoop dst
+ ((6) 'XOR) ;GXxor src XOR dst
+ ((7) 'OVER) ;GXor src OR dst
+ ((8) (warn "unimplemented:" '|GXnor|) #f) ;GXnor NOT src AND NOT dst
+ ((9) (warn "unimplemented:" '|GXequiv|) #f) ;GXequiv NOT src XOR dst
+ ((10) (warn "unimplemented:" '|GXinvert|) #f) ;GXinvert NOT dst
+ ((11) (warn "unimplemented:" '|GXorReverse|) #f) ;GXorReverse src OR NOT dst
+ ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted NOT src
+ ((13) (warn "unimplemented:" '|GXorInverted|) #f) ;GXorInverted NOT src OR dst
+ ((14) (warn "unimplemented:" '|GXnand|) #f) ;GXnand NOT src OR NOT dst
+ ((15) 'SOURCE) ;GXset 1
+ (else (error:wrong-type-argument mode "a drawing mode"
+ 'gtk-graphics/set-drawing-mode)))))
+ (if operator
+ (cairo-set-operator
+ (gtk-graphics-context (graphics-device/descriptor device))
+ operator))))
(define (gtk-graphics/set-line-style device style)
(let ((graphics (graphics-device/descriptor device))
(else (error:wrong-type-argument style "a line style"
'gtk-graphics/set-line-style)))))
(let ((cr (gtk-graphics-context graphics))
- (count (length dashes))
- (array (malloc (* (length dashes) (C-sizeof "double")) 'double)))
- (let ((scan (copy-alien array)))
- (let loop ((dashes dashes))
- (if (pair? dashes)
- (let ((len (->flonum (car dashes)))
- (factor (flo:/ 16. (gtk-graphics-scale graphics))))
- (if (flo:< len 0.) (error "Negative length:" len))
- (C->= scan "double" (flo:* len factor))
- (alien-byte-increment! scan (C-sizeof "double"))
- (loop (cdr dashes)))))
- (C-call "cairo_set_dash" cr array count 0.)
- (free array)))))
+ (factor (flo:/ 16. (gtk-graphics-scale graphics))))
+ (cairo-set-dash cr (map (lambda (len) (flo:* len factor)) dashes)))))
(define (gtk-graphics/fill-polygon-list device points)
;; POINTS should be a list of flo:vectors each with a length greater than 1.
(p (car points)))
(define-integrable (x p) (flo:vector-ref p 0))
(define-integrable (y p) (flo:vector-ref p 1))
- (C-call "cairo_move_to" cr (x p) (y p))
+ (cairo-move-to cr (x p) (y p))
(for-each (lambda (p)
- (C-call "cairo_line_to" cr (x p) (y p)))
+ (cairo-line-to cr (x p) (y p)))
(cdr points))
- (C-call "cairo_close_path" cr)
- (C-call "cairo_fill" cr))))
+ (cairo-close-path cr)
+ (cairo-fill cr))))
(define (gtk-graphics/flush device)
(let ((graphics (graphics-device/descriptor device)))
(let ((new (->color name 'gtk-graphics/set-foreground-color)))
(set-gtk-graphics-fgcolor! graphics new)
(set-gtk-graphics-fgcolor-name! graphics name)
- (C-call "cairo_set_source_rgba" (gtk-graphics-context graphics)
- (color-red new) (color-green new) (color-blue new)
- (color-alpha new))))))
+ (cairo-set-source-color (gtk-graphics-context graphics) new)))))
(define (gtk-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
(let ((cr (gtk-graphics-context (graphics-device/descriptor device)))
(y (->flonum y-top)))
(let ((width (flo:- (->flonum x-right) x))
(height (flo:- (->flonum y-bottom) y)))
- (C-call "cairo_rectangle" cr x y width height)
- (C-call "cairo_clip" cr))))
+ (cairo-rectangle cr x y width height)
+ (cairo-clip cr))))
(define (gtk-graphics/reset-clip-rectangle device)
- (let ((cr (gtk-graphics-context (graphics-device/descriptor device))))
- (C-call "cairo_reset_clip" cr)))
+ (cairo-reset-clip (gtk-graphics-context (graphics-device/descriptor device))))
(define gtk-graphics-device-type)
;;;; Test procedures for the gtks.
\f
-;;; GIO tests.
-
-(define test-copy-integrity
- (let ((cwd (directory-pathname (current-load-pathname))))
- (named-lambda (test-copy-integrity)
- (with-working-directory-pathname cwd
- (lambda ()
- (let ((file1 "../README.txt")
- (file2 "test-copy-1.txt"))
- (gcp file1 file2)
- (assert-equal (md5-file file2) (md5-file file1))))))))
-
-(define test-child-enumeration
- (let ((cwd (directory-pathname (current-load-pathname))))
- (named-lambda (test-child-enumeration)
- (with-working-directory-pathname cwd
- (lambda ()
- (let ((native (sort (ls "../runtime/") string<?))
- (gio (sort (gls "../runtime/") string<?)))
- (assert-equal gio native)))))))
-
-(define (gcp src dst)
- (let ((gsrc (open-input-gfile src))
- (gdst (open-output-gfile dst)))
- (let loop ()
- (let ((line (read-line gsrc)))
- (if (eof-object? line)
- (begin
- ;; Close the streams OR NOT, e.g. to test GCing of
- ;; abandoned (quiet) ports. Testing GCing of a port
- ;; with an operation pending would be... useful, and
- ;; tricky.
- (close-input-port gsrc)
- (close-output-port gdst))
- (begin
- (write-string line gdst) (newline gdst)
- (loop)))))))
-
-(define (gcat uri)
- (let ((gstream (open-input-gfile uri)))
- (let loop ()
- (let ((line (read-line gstream)))
- (if (eof-object? line)
- (begin
- ;; Close the gstream OR NOT, e.g. to test GCing of
- ;; abandoned (quiet) ports. Testing GCing of a port
- ;; with an operation pending would be... useful, and
- ;; tricky.
- (close-input-port gstream))
- (begin
- (write-string line) (newline)
- (loop)))))))
-
-(define (ls pathname)
- (let ((names (map file-namestring
- (directory-read (->simple-namestring pathname)))))
- (sort (delete! ".." (delete! "." names)) string<?)))
-
-(define (gls uri)
- (sort (gdirectory-read uri) string<?))
-
-(define ->simple-namestring
- (access ->simple-namestring (->environment '(gtk gio))))
-\f
-;;; Gtk tests.
-
(define (await-closed-demos)
(gtk-time-slice-window! #t)
(hello)
;;;; C declarations for gtk-shim.so.
\f
-(include "Includes/glib")
+;(include "Includes/glib")
(include "Includes/glib-object")
-(include "Includes/gio/gio")
+;(include "Includes/gio/gio")
(include "Includes/gdk-pixbuf")
(include "Includes/gdkkeysyms")
(include "Includes/gtk")
-(include "Includes/pango")
-(include "Includes/cairo")
+;(include "Includes/pango")
+;(include "Includes/cairo")
;;(include "Includes/cairo-xlib") Needs definitions for Drawable, Display...
-(include "Includes/pangocairo")
-
-;;; gio.scm
-
-(extern gpointer
- g_try_malloc0
- (n_bytes gsize))
-
-(callback void
- async_ready
- (source (* GObject))
- (res (* GAsyncResult))
- (ID gpointer))
-
-(callback void
- ask_password
- (op (* GMountOperation))
- (message (* gchar))
- (default_user (* gchar))
- (default_domain (* gchar))
- (flags GAskPasswordFlags)
- (ID gpointer))
-
-(callback void
- ask_question
- (op (* GMountOperation))
- (message (* gchar))
- (choices GStrv)
- (ID gpointer))
-
-(callback void
- show_processes
- (op (* GMountOperation))
- (message (* gchar))
- (processes (* GArray))
- (choices GStrv)
- (ID gpointer))
+;(include "Includes/pangocairo")
;;; gtkio.c
-(extern gboolean start_gtk (argc_loc (* int)) (argv_loc (* (* (* char)))))
-(extern void stop_gtk)
-(extern void run_gtk (registry ulong) (time double))
-(extern void yield_gtk)
+(extern gboolean gtk_init_check (argc (* int)) (argv (* (* (* char)))))
(extern gboolean gtk_time_slice_window_p)
(extern void gtk_time_slice_window (open_p gboolean))
-(extern gboolean gtk_select_trace_p)
-(extern void gtk_select_trace (trace_p gboolean))
;;; scmwidget.c
(hadjustment (* GtkAdjustment))
(vadjustment (* GtkAdjustment)))
-(extern void g_free ;glib-2.8.6/glib/gmem.h
- (mem gpointer))
-
(extern void gtk_grab_add ;gtk+-2.24.4/gtk/gtkmain.h
(widget (* GtkWidget)))
(global-definitions runtime/)
(global-definitions ffi/)
(global-definitions sos/)
+(global-definitions glib/)
+(global-definitions pango/)
+(global-definitions cairo/)
(define-package (gtk)
- (parent ())
+ (parent (glib))
(files "gtk")
;;(depends-on "gtk-const.bin")
)
-(define-package (gtk gobject)
+(define-package (gtk gdk)
(parent (gtk))
- (files "gobject")
- ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi")
+ (files "gdk")
+ ;;(depends-on "gtk-const.bin")
+ (import (cairo)
+ make-cairo-cleanup check-cairo-status)
(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
+ gdk-cairo-create
+ gdk-window-process-updates
<pixbuf-loader> make-pixbuf-loader
load-pixbuf-from-port load-pixbuf-from-file
pixbuf-loader-size-hook set-pixbuf-loader-size-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 gio)
- (parent (gtk))
- (files "gio")
- ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi")
- (import (runtime)
- ucode-primitive)
- (import (runtime ffi)
- %set-alien/address!)
- (import (runtime generic-i/o-port)
- make-gsource
- make-gsink)
- (import (gtk main)
- maybe-yield-gtk)
- (export ()
- open-input-gfile
- open-output-gfile
- gdirectory-read)
- (export (gtk)
- <g-stream>
- <g-input-stream>
- g-input-stream-read
- g-input-stream-skip
- g-input-stream-close
- <g-output-stream>
- g-output-stream-write
- g-output-stream-flush
- g-output-stream-close
- <gfile-input-stream>
- gfile-read
- <gfile-output-stream>
- gfile-append-to
- gfile-create
- gfile-replace
- <gfile-info>
- gfile-query-info
- gfile-info-list-attributes
- gfile-info-get-attribute-status
- gfile-info-get-attribute-value
- <gfile-enumerator>
- gfile-enumerate-children
- gfile-enumerator-next-files
- gfile-enumerator-close
- <gfile>
- make-gfile))
-
-(define-package (gtk pango)
- (parent (gtk))
- (files "pango")
- ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi")
- (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-set-markup
- 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-font-description-copy
- 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 cairo)
- (parent (gtk))
- (files "cairo")
- (import (gtk fix-layout)
- ->color)
- (export (gtk)
- cairo-image-surface-create
- cairo-surface-destroy
- cairo-surface-write-to-png
- cairo-surface-flush
- cairo-pattern-create-linear
- cairo-pattern-create-radial
- cairo-pattern-destroy
- cairo-pattern-add-color-stop
- cairo-create
- gdk-cairo-create
- cairo-destroy
- cairo-translate
- cairo-scale
- cairo-set-source-color
- cairo-set-source
- cairo-clip-extents
- cairo-move-to
- cairo-new-sub-path
- cairo-arc
- cairo-paint
- cairo-fill
- cairo-stroke
- cairo-set-font-matrix
- cairo-matrix))
+ <pixbuf>))
(define-package (gtk gtk-widget)
(parent (gtk))
gtk-paned-get-child1 gtk-paned-get-child2
gtk-paned-get-position gtk-paned-set-position
<gtk-paned-view> gtk-paned-view? gtk-paned-view-new)
- (import (gtk pango) make-pango-layout guarantee-pango-font-description))
+ (import (pango) make-pango-layout guarantee-pango-font-description))
(define-package (gtk widget)
(parent (gtk))
(import (ffi)
find-c-includes
c-enum-constant-values)
- (import (gtk pango)
+ (import (pango)
make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
(import (gtk gtk-widget)
set-gtk-widget-destroy-callback!
ucode-primitive)
(import (runtime subprocess)
hook/subprocess-wait nonblocking/subprocess-wait)
- (import (gtk thread)
- create-gtk-thread exit-gtk-thread)
+ (import (gtk gtk-widget)
+ toplevel-windows)
(export ()
+ gtk-initialized?
gtk-time-slice-window?
- gtk-time-slice-window!
- gtk-select-trace?
- gtk-select-trace!))
-
-(define-package (gtk thread)
- (parent (runtime thread))
- (files "thread")
- ;;(depends-on "main")
- (export ()
- stop-gtk-thread
- gtk-thread-running?)
- (import (gtk gobject)
- run-gc-cleanups)
- (import (gtk main)
- run-gtk)
- (import (runtime primitive-io)
- select-registry-handle))
+ gtk-time-slice-window!))
(define-package (gtk event-viewer)
(parent (gtk))
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)
+ (import (pango)
pango-rectangle pangos->pixels)
(export ()
make-gtk-event-viewer-demo))
(define-package (gtk fix-layout demo)
(parent (gtk fix-layout))
(files "fix-demo")
- (import (gtk cairo)
+ (import (cairo)
cairo-identity-matrix cairo-matrix-scale! cairo-matrix-translate!
cairo-point x y cairo-transform! guarantee-flonum)
(import (gtk fix-layout)
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!)
- (import (gtk cairo)
+ (import (cairo)
cairo-point x y set-x! set-y! cairo-transform!
cairo-rotation-matrix cairo-matrix-scale! cairo-matrix-translate!)
(export (swat)
\input texinfo @c -*-Texinfo-*-
@comment %**start of header
@setfilename mit-scheme-gtk
-@set VERSION 0.3
-@settitle Gtk @value{VERSION}
+@set VERSION 0.5
+@settitle MIT/GNU Scheme Gtk Plugin @value{VERSION}
@comment %**end of header
@ifhtml
@end ifnothtml
@copying
-This manual documents @acronym{Gtk} @value{VERSION}.
+This manual documents MIT/GNU Scheme's @acronym{Gtk} plugin @value{VERSION}.
-Copyright @copyright{} 2008, 2009, 2010, 2011, 2012, 2013 Matthew Birkholz
+Copyright @copyright{} 2008, 2009, 2010, 2011, 2012, 2013, 2014
+Matthew Birkholz
@quotation
Permission is granted to copy, distribute and/or modify this document
@dircategory Programming Languages
@direntry
* MIT/GNU Scheme Gtk: (mit-scheme-gtk).
- GNOME Interface
+ GNOME toolkit plugin.
@end direntry
@titlepage
-@title The Gtk Reference Manual
+@title The MIT/GNU Scheme Gtk Plugin Manual
@subtitle Schemely access (@value{VERSION}) to the GNOME toolkits
@subtitle for MIT/GNU Scheme version 9.1
@author by Matt Birkholz (@email{birkholz@@alum.mit.edu})
@ifnottex
@node Top, Introduction, (dir), (dir)
-@top Gtk Interface
+@top Gtk Plugin
@insertcopying
@end ifnottex
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
+extensive.
+Very little of the libraries' APIs 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.
@unnumberedsec Hello, World!
the Gtk interface.
@menu
-* GObject::
-* GIO::
* Pixbuf Loader::
-* Pango Layout::
-* Cairo Context::
-* Cairo Surface::
-* Cairo Pattern::
* Gtk Adjustment::
* Gtk Widget::
* Gtk Container::
* Debugging Facilities::
@end menu
-@node GObject, GIO, API Reference, API Reference
-@section GObject
-
-An instance of @code{<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, or perhaps just without-toolkit).
-Connecting a second callback disconnects the
-first.
-
-@anchor{pinned-objects}
-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
-also pinned and the garbage collector will never 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 binding through which the instance is reachable.
-
-@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
-@code{#t} while @var{gobject} is alive, @code{#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:
-
-@example
- (g-signal-connect window (C-callback "delete_event") delete-callback)
-@end example
-
-Note that @var{delete-callback} should reference @var{window} via
-parameter @emph{only}. @xref{pinned-objects}.
-@end deffn
-
-@deffn Procedure g-signal-disconnect gobject name
-@var{name} should be a string, e.g.:
-@example
- (g-signal-disconnect window "delete_event")
-@end example
-@end deffn
-
-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}.
-
-@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 GIO, Pixbuf Loader, GObject, API Reference
-@section GIO
-
-The basic interface to the GIO library is three procedures taking a
-URI argument and returning either a Scheme port or a list of strings.
-The URI can specify file, http and sftp protocols (and perhaps more,
-depending on support in the GIO library). If an SFTP URI requires a
-password, Scheme's @code{call-with-pass-phrase} procedure is called.
-If the ports are GCed or the stack unwound, pending operations are
-cancelled. Re-winding the stack is an error.
-
-@deffn Procedure open-input-gfile uri
-Returns an input port that reads from @var{uri}.
-@end deffn
-
-@deffn Procedure open-output-gfile uri
-Returns an output port that writes a new file replacing @var{uri}.
-@end deffn
-
-@deffn Procedure gdirectory-read uri
-Returns a list of strings --- the names of the ``children'' of
-@var{uri}, a directory resource.
-@end deffn
-
-A more direct interface to GIO's GFile operations is provided by the
-following 8 classes and 18 operations.
-
-@verbatim
- <gfile>
- make-gfile
- <gfile-info>
- gfile-query-info
- gfile-info-list-attributes
- gfile-info-get-attribute-status
- gfile-info-get-attribute-value
- <gfile-enumerator>
- gfile-enumerate-children
- gfile-enumerator-next-files
- gfile-enumerator-close
- <g-stream>
- <g-input-stream>
- g-input-stream-read
- g-input-stream-skip
- g-input-stream-close
- <gfile-input-stream>
- gfile-read
- <g-output-stream>
- g-output-stream-write
- g-output-stream-flush
- g-output-stream-close
- <gfile-output-stream>
- gfile-append-to
- gfile-create
- gfile-replace
-@end verbatim
-
-@deffn Class <gfile>
-Represents a @code{GFile} toolkit object.
-@end deffn
-
-@deffn Procedure make-gfile uri
-Constructs a gfile for the given @var{uri}. This operation never
-fails, but the returned object might not support any I/O if @var{uri}
-is malformed or if the uri type is not supported.
-@end deffn
-
-@deffn Class <gfile-info>
-Represents a @code{GFileInfo} toolkit object containing key-value
-attributes (such as the type or size of a gfile).
-@end deffn
-
-@deffn Procedure gfile-query-info gfile attributes follow-symlinks?
-Gets the requested information about @var{gfile}. The result is a
-gfile-info instance.
-
-@var{Attributes} should be a string specifying the file attributes to
-be gathered. It is not an error if it's not possible to read a
-particular requested attribute from a file --- it just won't be set.
-@var{Attributes} should be a comma-separated list of attributes or
-attribute wildcards. The wildcard @code{*} means all attributes, and
-a wildcard like @code{standard::*} means all attributes in the
-standard namespace. An example attribute query is
-@code{standard::*,owner::user}.
-
-Normally information about the target of a symlink
-is returned, rather than information about the symlink itself. However
-if @var{follow-symlinks?} is @code{#f}, information about the
-symlink itself will be returned. If the target does not exist,
-information about the symlink itself will be returned.
-@end deffn
-
-There are many gfile attributes. Most have boolean or integer values.
-Some are enum constants. For example the @code{standard::type}
-attribute's value is a GFileType member, e.g. @code{(C-enum
-"G_FILE_TYPE_UNKNOWN")}. For a complete list of GFileType members and
-other GIO constants, see your @file{gioenums.h} header file.
-
-Here are the 76 keys listed in the @file{gfileinfo.h} header:
-@code{standard::type},
-@code{standard::is-hidden},
-@code{standard::is-backup},
-@code{standard::is-symlink},
-@code{standard::is-virtual},
-@code{standard::name},
-@code{standard::display-name},
-@code{standard::edit-name},
-@code{standard::copy-name},
-@code{standard::description},
-@code{standard::icon},
-@code{standard::content-type},
-@code{standard::fast-content-type},
-@code{standard::size},
-@code{standard::allocated-size},
-@code{standard::symlink-target},
-@code{standard::target-uri},
-@code{standard::sort-order},
-@code{etag::value},
-@code{id::file},
-@code{id::filesystem},
-@code{access::can-read},
-@code{access::can-write},
-@code{access::can-execute},
-@code{access::can-delete},
-@code{access::can-trash},
-@code{access::can-rename},
-@code{mountable::can-mount},
-@code{mountable::can-unmount},
-@code{mountable::can-eject},
-@code{mountable::unix-device},
-@code{mountable::unix-device-file},
-@code{mountable::hal-udi},
-@code{mountable::can-start},
-@code{mountable::can-start-degraded},
-@code{mountable::can-stop},
-@code{mountable::start-stop-type},
-@code{mountable::can-poll},
-@code{mountable::is-media-check-automatic},
-@code{time::modified},
-@code{time::modified-usec},
-@code{time::access},
-@code{time::access-usec},
-@code{time::changed},
-@code{time::changed-usec},
-@code{time::created},
-@code{time::created-usec},
-@code{unix::device},
-@code{unix::inode},
-@code{unix::mode},
-@code{unix::nlink},
-@code{unix::uid},
-@code{unix::gid},
-@code{unix::rdev},
-@code{unix::block-size},
-@code{unix::blocks},
-@code{unix::is-mountpoint},
-@code{dos::is-archive},
-@code{dos::is-system},
-@code{owner::user},
-@code{owner::user-real},
-@code{owner::group},
-@code{thumbnail::path},
-@code{thumbnail::failed},
-@code{preview::icon},
-@code{filesystem::size},
-@code{filesystem::free},
-@code{filesystem::used},
-@code{filesystem::type},
-@code{filesystem::readonly},
-@code{filesystem::use-preview},
-@code{gvfs::backend},
-@code{selinux::context},
-@code{trash::item-count},
-@code{trash::orig-path}, or
-@code{trash::deletion-date}.
-
-@deffn Procedure gfile-info-list-attributes ginfo namespace
-Lists the gfile-info attribute keys.
-@var{Namespace} should be e.g. @code{standard} or @code{*}.
-@end deffn
-
-@deffn Procedure gfile-info-get-attribute-status ginfo key
-Returns @code{set} if the @code{key} attribute in @code{ginfo} has
-been set. Returns @code{unset} if not. Returns @code{error-setting}
-if there was an error collecting the value.
-@end deffn
-
-@deffn Procedure gfile-info-get-attribute-value ginfo key
-Returns a boolean, integer, string or list of strings depending on the
-value of @var{key} in @var{ginfo}.
-@end deffn
-
-@deffn Class <gfile-enumerator>
-Represents a @code{GFileEnumerator}.
-@end deffn
-
-@deffn Procedure gfile-enumerate-children gfile attributes follow-symlinks?
-Gets the requested information about the files in @var{gfile} --- a
-directory. The result is a gfile-enumerator that produces a gfile-info
-for each file in the directory. If @var{gfile} is not a directory, an
-error is signaled.
-
-@var{Attributes} should be a string specifying the file attributes to
-be gathered. It is not an error if it's not possible to read a
-particular requested attribute from a file --- it just won't be set.
-@var{Attributes} should be a comma-separated list of attributes or
-attribute wildcards. The wildcard @code{*} means all attributes, and
-a wildcard like @code{standard::*} means all attributes in the
-standard namespace. An example attribute query is
-@code{standard::*,owner::user}.
-@end deffn
-
-@deffn Procedure gfile-enumerator-next-files genum n
-Gets up to @var{n} more gfile-infos from @var{genum}.
-@end deffn
-
-@deffn Procedure gfile-enumerator-close genum
-Closes @var{genum}.
-@end deffn
-
-@deffn Class <g-stream>
-Abstract superclass of GIO streams.
-@end deffn
-
-@deffn Class <g-input-stream>
-A subclass of g-stream.
-@end deffn
-
-@deffn Procedure g-input-stream-read gstream buffer start end
-Returns the number of bytes read from @var{gstream} and
-written into @var{buffer}.
-@end deffn
-
-@deffn Procedure g-input-stream-skip gstream count
-Returns the number of bytes read from @var{gstream} and discarded.
-@end deffn
-
-@deffn Procedure g-input-stream-close gstream
-Closes @var{gstream}.
-@end deffn
-
-@deffn Class <gfile-input-stream>
-A subclass of g-input-stream representing input from a file.
-@end deffn
-
-@deffn Procedure gfile-read gfile
-Returns a gfile-input-stream opened for reading from @var{gfile}.
-@end deffn
-
-@deffn Class <g-output-stream>
-A subclass of g-stream.
-@end deffn
-
-@deffn Procedure g-output-stream-write gstream buffer start end
-Returns the number of bytes written to @var{gstream}. Will return 0
-only if @var{start} equals @var{end}.
-@end deffn
-
-@deffn Procedure g-output-stream-flush gstream
-Forces a write of all user-space buffered data for @var{gstream}.
-@end deffn
-
-@deffn Procedure g-output-stream-close gstream
-Closes @var{gstream}.
-@end deffn
-
-@deffn Class <gfile-output-stream>
-A subclass of g-output-stream representing output to a file.
-@end deffn
-
-@deffn Procedure gfile-replace gfile etag backup? . flags
-Returns a gfile-output-stream that overwrites @var{gfile}, possibly
-creating a backup copy of the file first. If the file doesn't exist,
-it will be created.
-
-This will try to replace the file in the safest way possible so that
-any errors during the writing will not affect an already existing copy
-of the file. For instance, for local files it may write to a temporary
-file and then atomically rename over the destination when the stream
-is closed.
-
-By default files are generally created readable by everyone, but if
-you include the symbol @code{private} in @var{flags} the file will be
-made readable only to the current user, to the level that is supported
-on the target filesystem.
-
-@var{Etag} should be zero or false, or an alien. If @var{etag} is an
-alien, it is compared to the current entity tag of the file, and if
-they differ an error is signaled. This generally means that the file
-has been changed since you last read it. You can get the etag for a
-gfile from the @code{etag::value} attribute in
-its gfile-info. You can get the gfile-info for a gfile-input-stream
-with @code{gfile-input-stream-query-info}. The etag for a
-gfile-output-stream is available from
-@code{gfile-output-stream-get-etag}.
-
-@var{Backup?} should be @code{#f} unless you require a backup of
-an existing file to be made. If a backup cannot be made, an error
-will be signaled. If you want to replace the file anyway, call
-again with @var{backup?} @code{#f}.
-@end deffn
-
-@deffn Procedure gfile-append-to gfile . flags
-Returns a gfile-output-stream that appends to @var{gfile}. If the file
-doesn't already exist it is created.
-
-By default files are created readable by everyone, but if you include
-the symbol @code{private} in @var{flags} the file will be made
-readable only to the current user, to the level that is supported on
-the target filesystem.
-@end deffn
-
-@deffn Procedure gfile-create gfile . flags
-Returns a gfile-output-stream that writes to @var{gfile}. If the file
-already exists an error is signaled.
-
-By default files are created readable by everyone, but if you include
-the symbol @code{private} in @var{flags} the file will be made
-readable only to the current user, to the level that is supported on
-the target filesystem.
-@end deffn
-
-
-@node Pixbuf Loader, Pango Layout, GIO, API Reference
+@node Pixbuf Loader, Gtk Adjustment, API Reference, API Reference
@section Pixbuf Loader
A pixbuf loader encapsulates the loading of a pixbuf. The
@code{#f} or a string describing any error encountered during the loading.
@end deffn
-@node Pango Layout, Cairo Context, 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-set-markup layout markup
-Sets @var{layout}'s text to @var{markup}, a simplified XML string.
-
-@var{Markup} is XML with the following simplifications.
-
-@itemize @bullet
-@item
-Only UTF-8 encoding is allowed.
-@item
-No user-defined entities.
-@item
-Processing instructions, comments and the doctype declaration are
-parsed but not interpreted in any way.
-@item
-No DTD nor validation.
-@end itemize
-
-The markup format does support:
-
-@itemize @bullet
-@item
-Elements
-@item
-Attributes
-@item
-5 standard entities: @code{& < > " '}
-@item
-Character references
-@item
-Sections marked as CDATA
-@end itemize
-
-Valid elements are:
-
-@table @code
-@item b
-Bold
-@item big
-Makes font relatively larger, equivalent to @code{<span size="larger">}.
-@item i
-Italic
-@item s
-Strikethrough
-@item sub
-Subscript
-@item sup
-Superscript
-@item small
-Makes font relatively smaller. Equivalent to @code{<span size="smaller">}.
-@item tt
-Monospace font
-@item u
-Underline
-@item span
-General form with many attributes listed below.
-@end table
-
-Valid attributes for the span element are:
-
-@table @code
-
-@item font, font_desc
-A font description string acceptable to
-@bref{pango-font-description-from-string} (e.g. @code{Sans Italic
-12}). Note that any other span attributes will override this
-description. If you have @code{font="Sans Italic"} and also
-@code{style="normal"}, you will get Sans normal, not italic.
-
-@item font_family, face
-A font family name.
-
-@item font_size, size
-Font size in 1024ths of a point, or one of the absolute sizes
-@code{xx-small}, @code{x-small}, @code{small}, @code{medium},
-@code{large}, @code{x-large}, @code{xx-large}, or one of the relative
-sizes @code{smaller} or @code{larger}. If you want to specify a
-absolute size, it is usually easier to take advantage of the ability
-to specify a partial font description using @code{font}; you can use
-@code{font="12.5"} rather than @code{size="12800"}.
-
-@item font_style, style
-One of @code{normal}, @code{oblique}, @code{italic}.
-
-@item font_weight, weight
-One of @code{ultralight}, @code{light}, @code{normal}, @code{bold},
-@code{ultrabold}, @code{heavy}, or a numeric weight.
-
-@item font_variant, variant
-One of @code{normal} or @code{smallcaps}.
-
-@item font_stretch, stretch
-One of @code{ultracondensed}, @code{extracondensed}, @code{condensed},
-@code{semicondensed}, @code{normal}, @code{semiexpanded},
-@code{expanded}, @code{extraexpanded}, @code{ultraexpanded}.
-
-@item foreground, fgcolor, color
-An RGB color specification such as @code{#00FF00} or a color name such
-as @code{red}.
-
-@item background, bgcolor
-An RGB color specification such as @code{#00FF00} or a color name such
-as @code{red}.
-
-@item underline
-One of @code{none}, @code{single}, @code{double}, @code{low},
-@code{error}.
-
-@item underline_color
-The color of underlines; an RGB color specification such as
-@code{#00FF00} or a color name such as @code{red}.
-
-@item rise
-Vertical displacement, in 10000ths of an em. Can be negative for
-subscript, positive for superscript.
-
-@item strikethrough
-@code{true} or @code{false} whether to strike through the text.
-
-@item strikethrough_color
-The color of strikethrough lines; an RGB color specification such as
-@code{#00FF00} or a color name such as @code{red}
-
-@item fallback
-@code{True} or @code{false} whether to enable fallback. If disabled,
-then characters will only be used from the closest matching font on
-the system. No fallback will be done to other fonts on the system that
-might contain the characters in the text. Fallback is enabled by
-default. Most applications should not disable fallback.
-
-@item lang
-A language code (e.g. @code{en} for english), indicating the text
-language.
-
-@item letter_spacing
-Inter-letter spacing in 1024ths of a point.
-
-@item gravity
-One of @code{south}, @code{east}, @code{north}, @code{west}, @code{auto}.
-
-@item gravity_hint
-One of @code{natural}, @code{strong}, @code{line}.
-@end table
-
-@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}.
-
-@var{String} can have three whitespace separated parts:
-@code{family-list style-options size}.
-
-@code{Family-list} can be a comma separated list of families optionally
-terminated by a comma.
-
-@code{Style-options} can be a whitespace separated list of
-words where each word describes one of style, variant, weight,
-stretch, or gravity.
-
-@code{Size} can be a decimal number (size in points) or an absolute
-size followed by the unit modifier @code{px}.
-
-Any one of these parts may be absent. If @code{family-list} is absent,
-then the family name field of the resulting font description will be
-empty. If @code{style-options} is missing, then all style options
-will be set to default values. If @code{size} is missing, the size in
-the resulting font description will be set to 0.
-@end deffn
-
-@deffn Procedure pango-font-description-to-string font
-A string that would parse as @var{font}, a PangoFontDescription alien.
-@end deffn
-
-@deffn Procedure pango-font-description-copy font
-A copy of @var{font}, a new 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 Cairo Context, Cairo Surface, Pango Layout, API Reference
-@section Cairo Context
-
-This simple wrapper for @code{cairo_t} objects ensures that the
-toolkit object is de-referenced when the Scheme object is garbage
-collected. The Scheme object is an alien of type @code{cairo_t}.
-
-@deffn Procedure gdk-cairo-create window
-Creates a cairo context targeting @var{window}.
-@end deffn
-
-@deffn Procedure cairo-destroy cairo
-De-references a @var{cairo} context object. Further operations on
-@var{cairo} will produce an error.
-@end deffn
-
-@deffn Procedure cairo-create surface
-Creates a new cairo context with all graphics state parameters set to
-default values and with @var{surface} as the target surface. The
-context will reference the surface so @bref{cairo-surface-destroy} can
-be called on it if the surface will no longer be used directly.
-@end deffn
-
-@deffn Procedure cairo-set-source-color cairo color
-Sets the source pattern within @var{cairo} to @var{color} which will
-then be used for future drawing operations. The default source
-pattern is opaque black.
-@xref{colors}.
-@end deffn
-
-@deffn Procedure cairo-set-source cairo pattern
-Sets the source pattern within @var{cairo} to @var{pattern} which will
-then be used for future drawing operations. The default source is
-solid, opaque black.
-@end deffn
-
-@deffn Procedure cairo-translate cairo dx dy
-Modifies the current transformation matrix of @var{cairo} by
-translating the user-space origin to (dx, dy).
-@end deffn
-
-@deffn Procedure cairo-scale cairo sx sy
-Modifies the current transformation matrix of @var{cairo} by scaling
-the X and Y user-space axes by @var{sx} and @var{sy} respectively.
-@end deffn
-
-@anchor{cairo-move-to}
-@deffn Procedure cairo-move-to cairo x y
-Begin a new sub-path. After this call @var{cairo}'s current point
-will be (@var{x}, @var{y}).
-@end deffn
-
-@anchor{cairo-new-sub-path}
-@deffn Procedure cairo-new-sub-path cairo
-Begins a new sub-path. Note that @var{cairo}'s existing path is not
-affected. After this call there will be no current point.
-
-In many cases, this call is not needed since new sub-paths are
-frequently started with @bref{cairo-move-to}.
-
-A call to @bref{cairo-new-sub-path} is particularly useful when
-beginning a new sub-path with one of the @bref{cairo-arc} calls. This
-makes things easier as it is no longer necessary to manually compute
-the arc's initial coordinates for a call to @bref{cairo-move-to}.
-@end deffn
-
-@anchor{cairo-arc}
-@deffn Procedure cairo-arc cairo x y radius start end
-Adds a circular arc to the current path. The arc is centered at
-(@var{x}, @var{y}), has @var{radius}, begins at @var{start} and
-proceeds in the direction of increasing angles to @var{end}. If
-@var{end} is less than @var{start} it will be progressively increased
-by 2pi until it is greater than @var{start}.
-
-If there is a current point, an initial line segment will be added to
-the path to connect the current point to the beginning of the arc. If
-this initial line is undesired, it can be avoided by calling
-@bref{cairo-new-sub-path} before calling @code{cairo-arc}.
-
-@var{Start} and @var{end} should be given in radians. An angle of 0.0
-is in the direction of the positive X axis (in user space). An angle
-of pi/2 radians (90 degrees) is in the direction of the positive Y
-axis (in user space). With the default transformation matrix, angles
-increase in a clockwise direction.
-@end deffn
-
-@deffn Procedure cairo-paint cairo
-Paints the current source everywhere within the current clip region.
-@end deffn
-
-@deffn Procedure cairo-stroke cairo
-Strokes @var{cairo}'s current path according to the
-current line width, line join, line cap, and dash settings. The
-current path is then cleared.
-@end deffn
-
-@deffn Procedure cairo-fill cairo
-Fills @var{cairo}'s current path according to the current fill rule.
-Each sub-path is implicitly closed before being filled. The current
-path is then cleared.
-@end deffn
-
-@deffn Procedure cairo-clip-extents cairo receiver
-Calls @var{receiver} with the user-space bounding box of the area
-inside @var{cairo}'s current clip. @var{Receiver} will be called with
-four flonums: the left, top, right and bottom bounds of the clip.
-@end deffn
-
-@deffn Procedure cairo-set-font-matrix cairo matrix
-Sets @var{cairo}'s current font matrix to @var{matrix}, which gives a
-transformation from the design space of the font (in this space, the
-em-square is 1 unit by 1 unit) to user space. @var{Matrix} should be
-created using @bref{cairo-matrix}.
-@end deffn
-
-@anchor{cairo-matrix}
-@deffn Procedure cairo-matrix xx yx x0 xy yy y0
-Creates a Cairo transformation matrix. A point @code{(x,y)} is
-transformed by this matrix into @code{(xx * x + xy * y + x0, yx * x +
-yy * y + y0)}.
-@end deffn
-
-@node Cairo Surface, Cairo Pattern, Cairo Context, API Reference
-@section Cairo Surface
-
-This simple wrapper for @code{cairo_surface_t} objects ensures that the
-toolkit object is de-referenced when the Scheme object is garbage
-collected. The Scheme object is an alien of type
-@code{cairo_surface_t}.
-
-@deffn Procedure cairo-image-surface-create width height
-Creates a Cairo image surface @var{width}x@var{height} pixels.
-@end deffn
-
-@anchor{cairo-surface-write-to-png}
-@deffn Procedure cairo-surface-write-to-png surface filename
-Writes @var{surface} to a new file @var{filename} as a PNG image.
-@end deffn
-
-@anchor{cairo-surface-flush}
-@deffn Procedure cairo-surface-flush surface
-Does any pending drawing for @var{surface}. Also restores any
-temporary modifications Cairo has made to the surface's state.
-@end deffn
-
-@anchor{cairo-surface-destroy}
-@deffn Procedure cairo-surface-destroy surface
-De-references a cairo @var{surface} object. Further operations on
-@var{surface} will produce an error.
-@end deffn
-
-@node Cairo Pattern, Gtk Adjustment, Cairo Surface, API Reference
-@section Cairo Pattern
-
-This simple wrapper for @code{cairo_pattern_t} objects ensures that the
-toolkit object is de-referenced when the Scheme object is garbage
-collected. The Scheme object is an alien of type
-@code{cairo_pattern_t}.
-
-@deffn Procedure cairo-pattern-create-radial x0 y0 radius0 x1 y1 radius1
-Creates a new radial gradient pattern from the circle defined by
-(@var{x0}, @var{y0}, @var{radius0}) to a second circle defined by
-(@var{x1}, @var{y1}, @var{radius1}). Before using the gradient
-pattern, a number of color stops should be defined using
-@bref{cairo-pattern-add-color-stop}.
-@end deffn
-
-@deffn Procedure cairo-pattern-create-linear x0 y0 x1 y1
-Creates a new linear gradient pattern along the line from (@var{x0},
-@var{y0}) to (@var{x1}, @var{y1}). Before using the gradient pattern,
-a number of color stops should be defined using
-@bref{cairo-pattern-add-color-stop}.
-@end deffn
-
-@anchor{cairo-pattern-add-color-stop}
-@deffn Procedure cairo-pattern-add-color-stop pattern offset color
-Adds a color stop to a gradient @var{pattern}. @var{Offset} specifies
-the location along the gradient's control vector. @var{Color} should
-be an RGBA color. @xref{colors}. If two (or more) stops are
-specified with identical offset values, they will be sorted according
-to the order in which the stops are added. Stops added earlier will
-compare less than stops added later. This can be useful for reliably
-making sharp color transitions instead of the typical blend.
-@end deffn
-
-@deffn Procedure cairo-pattern-destroy pattern
-De-references a cairo @var{pattern} object. Further operations on
-@var{pattern} will produce an error.
-@end deffn
-
-@node Gtk Adjustment, Gtk Widget, Cairo Pattern, API Reference
+@node Gtk Adjustment, Gtk Widget, Pixbuf Loader, API Reference
@section Gtk Adjustment
@deffn Class <gtk-adjustment>
@node Gdk Functions, Debugging Facilities, Fix Layout, API Reference
@section Gdk Functions
+@deffn Procedure gdk-cairo-create window
+Creates a cairo context targeting @var{window}.
+@end deffn
+
@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
@var{keyval}.
@end deffn
-@node Debugging Facilities, , Gdk Functions, API Reference
+@node Debugging Facilities, API Reference, Gdk Functions, API Reference
@section Debugging Facilities
-@deffn Procedure stop-gtk-thread
-A convenient procedure to call in an emergency.
-@end deffn
-
-@deffn Procedure gtk-thread-running?
-A convenient procedure to determine whether the toolkit is dead.
-@end deffn
-
@deffn Procedure gtk-time-slice-window?
@code{#t} if the time slice window is open, else @code{#f}.
@end deffn
If @var{open?} is @code{#f}, the time slice window is closed, else it is opened.
@end deffn
-@deffn Procedure gtk-select-trace?
-@code{#t} if Scheme's GSource is being traced, else @code{#f}.
-@end deffn
-
-@deffn Procedure gtk-select-trace! trace?
-If @var{trace?} is @code{#t}, turns on tracing of Scheme's GSource.
-@end deffn
-
@node Installation, Implementation Notes, API Reference, Top
@chapter Installation
-The Gtk system comes as a source snapshot or as a portable C
-distribution.
-
-@section Source Snapshot
-
-If you downloaded the source snapshot, unpack it and change to its
-@file{src/} subdirectory. Build and install it in @file{$HOME}
-with the following commands.
+Unpack the source and build in the usual way, but do not call
+@code{./configure} with a @code{--prefix} argument. This plugin will
+be installed in the system library path of the machine run by the
+@code{mit-scheme} command. You can override this command name by
+setting @code{MITSCHEME_EXE}. You can override the system library
+path of any machine by passing it the @code{--library} option on the
+commandline, or the @code{MITSCHEME_LIBRARY_PATH} variable in the
+environment.
@example
- ./configure --prefix=$HOME
+ tar xzf gtk-0.5.tar.gz
+ cd gtk-0.5
+ ./configure
make
+ make check
make install
+ make install-info
+ make install-html
+ make install-pdf
@end example
-Note that you must have a binary distribution of MIT Scheme already
-installed. MIT Scheme is used to build itself.
-
-To test before installing, use the following command.
-
-@example
- echo "(load-option 'Gtk)" | microcode/scheme --library lib
-@end example
-
-@section Portable C Distribution
-
-If you downloaded the portable C distribution, you do not need MIT
-Scheme already installed. Unpack the distribution and change to its
-@file{src/} subdirectory, then use the following commands to build and
-install it.
-
-@example
- etc/make-liarc.sh --prefix=$HOME
- make install
-@end example
-
-It should be as simple as that. If not, please feel free to contact
-the author.
-
@node Implementation Notes, GNU Free Documentation License, Installation, Top
@chapter Implementation Notes
*/
-/* SchemeSource -- the custom GSource that runs Scheme in an idle task. */
+/* A slice hook that updates a GtkWindow with the slice count and
+ channels in the select registry. */
#include <mit-scheme.h>
#include <gtk/gtk.h>
-#include <glib.h>
-#include <math.h>
+/* #include <glib.h> */
+/* #include <math.h> */
#include <stdlib.h>
-/* Presumed externs/const of the Gtk-ready machine. */
-extern double OS_real_time_clock (void);
-extern int OS_process_any_status_change (void);
-extern int OS_select_registry_length (unsigned long registry);
-#define SELECT_MODE_READ 1
-#define SELECT_MODE_WRITE 2
-extern void OS_select_registry_entry (unsigned long registry,
- int i, int *fd, unsigned int *mode);
-extern void OS_syserr_names (unsigned long *, const char ***);
-extern void Interpret (int pop_return_p);
-extern void alienate_float_environment (void);
-extern void foreach_async_signal (void(*func)(int signo));
-extern void abort_to_c (void);
-extern int interrupts_p (void);
-
-static void init_signal_handling (void);
-
-struct _SchemeSource
-{
- GSource source;
-
- /* The list of GPollFDs that have been added to the main_context. */
- GSList * gpollfds;
-
- /* When to give up waiting. */
- double time_limit;
-
- /* TRUE when Scheme has a runnable thread. Set to FALSE at the
- start of run_gtk. Set to TRUE by a callback that has made a
- Scheme thread runnable. */
- gboolean runnable;
-};
-typedef struct _SchemeSource SchemeSource;
-
-static gboolean scheme_source_prepare (GSource * source, gint * timeout);
-static gboolean scheme_source_check (GSource * source);
-static int pending_io (SchemeSource * source);
-static gboolean scheme_source_dispatch (GSource * source, GSourceFunc callback, gpointer user_data);
-static void install_scheme_source (void);
-static void destroy_scheme_source (void);
-static void clear_registry (SchemeSource * source);
-static void set_registry (SchemeSource * source, GSList * new, double time);
-
-static SchemeSource * scheme_source = NULL;
-static gboolean tracing_gtk_select = 0;
-static void trace (const char *format, ...);
-static GSList * gtk_registry (unsigned long registry);
-
-static int slice_counter = 0;
static GtkWidget * slice_window = NULL;
static GtkWidget * slice_label;
static GtkWidget * status_label;
static void open_slice_window (void);
static void close_slice_window (void);
static gboolean slice_window_delete_event (GtkWidget *window, GdkEvent *event, gpointer *data);
-static gchar * gpollfds_string (GSList * gpollfds);
-
-void
-trace (const char * format, ...)
-{
- va_list args;
- va_start (args, format);
- if (tracing_gtk_select)
- {
- vfprintf (stderr, format, args);
- fflush (stderr);
- }
- va_end (args);
-}
-
-static gboolean
-scheme_source_prepare (GSource * source, gint * timeout)
-{
- /* Return TRUE when ready to dispatch (without a poll).
-
- Return FALSE and set `timeout' to do a poll/check before
- dispatching. */
-
- SchemeSource * src = (SchemeSource *)source;
-
- if (src->runnable
- || interrupts_p ()
- || OS_process_any_status_change ())
- {
- trace (";scheme_source_prepare: ready (%s)\n",
- src->runnable ? "thread"
- : interrupts_p () ? "interrupt"
- : "subprocess");
- *timeout = 0;
- return (TRUE);
- }
- if (src->time_limit == -1.0)
- {
- trace (";scheme_source_prepare: waiting\n");
- *timeout = -1;
- return (FALSE);
- }
- if (src->time_limit == 0.0)
- {
- trace (";scheme_source_prepare: polling\n");
- *timeout = 0;
- return (FALSE);
- }
- {
- double dtime = OS_real_time_clock ();
- gint timeo = ceil (src->time_limit - dtime);
-
- if (timeo <= 0)
- {
- trace (";scheme_source_prepare: ready (timeout)\n");
- *timeout = 0;
- return (TRUE);
- }
-
- trace (";scheme_source_prepare: polling for %dmsec\n", timeo);
- *timeout = timeo;
- return (FALSE);
- }
-}
-
-static gboolean
-scheme_source_check (GSource * source)
-{
- /* Return TRUE when ready to dispatch (after the poll). */
-
- SchemeSource * src = (SchemeSource *)source;
-
- if (src->time_limit == 0.0
- || src->runnable
- || interrupts_p ()
- || OS_process_any_status_change ()
- || pending_io (src))
- {
- trace (";scheme_source_check: ready (%s)\n",
- src->runnable ? "thread"
- : interrupts_p () ? "interrupt"
- : OS_process_any_status_change () ? "subprocess"
- : src->time_limit == 0.0 ? "" : "i/o");
- return (TRUE);
- }
- if (src->time_limit == -1.0)
- {
- trace (";scheme_source_check: waiting forever\n");
- return (FALSE);
- }
- {
- double dtime = OS_real_time_clock ();
- gint timeo = ceil (src->time_limit - dtime);
-
- if (timeo <= 0)
- {
- trace (";scheme_source_check: ready (timeout)\n");
- return (TRUE);
- }
-
- trace (";scheme_source_check: waiting %dmsec\n", timeo);
- return (FALSE);
- }
-}
-
-static int
-pending_io (SchemeSource * src)
-{
- GSList * scan;
-
- if (tracing_gtk_select)
- {
- scan = src->gpollfds;
- while (scan != NULL)
- {
- GPollFD * gfd = scan->data;
- if (gfd->revents != 0)
- {
- fprintf (stderr, ";scheme_source_check: i/o ready on %d\n",
- gfd->fd);
- }
- scan = scan->next;
- }
- }
-
- scan = src->gpollfds;
- while (scan != NULL)
- {
- GPollFD * gfd = scan->data;
- if (gfd->revents != 0)
- return (TRUE);
- scan = scan->next;
- }
- return (FALSE);
-}
-
-static gboolean
-do_scheme (GSource *source)
-{
- slice_counter += 1;
- trace (";scheme_source_dispatch: running time slice %d\n", slice_counter);
-
- Interpret (1);
- alienate_float_environment ();
-
- trace (";scheme_source_dispatch: finished time slice %d\n", slice_counter);
- return (TRUE); /* Not a once-only. */
-}
-
-static gboolean
-scheme_source_dispatch (GSource * source,
- GSourceFunc callback, gpointer user_data)
-{
- /* Executes our "idle" task. Ignore the callback and user_data
- arguments. Must return TRUE to stay on the list of event
- sources. */
-
- gboolean ret = FALSE;
-
- if (!g_source_is_destroyed (source))
- ret = do_scheme (source);
-
- return ret;
-}
-
-GSourceFuncs scheme_source_funcs =
-{
- scheme_source_prepare,
- scheme_source_check,
- scheme_source_dispatch,
- NULL,
- NULL,
- NULL
-};
-
-static void
-install_scheme_source (void)
-{
- scheme_source = (SchemeSource *)
- g_source_new (&scheme_source_funcs, sizeof (SchemeSource));
- scheme_source->gpollfds = NULL;
- scheme_source->time_limit = 0.0;
- scheme_source->runnable = FALSE;
- g_source_set_priority ((GSource *) scheme_source, G_PRIORITY_LOW);
- g_source_attach ((GSource *) scheme_source, NULL);
-}
-
-static void
-destroy_scheme_source (void)
-{
- clear_registry (scheme_source);
- g_source_destroy ((GSource *) scheme_source);
- scheme_source = NULL;
-}
-
-static void
-clear_registry (SchemeSource * source)
-{
- GSList * gpollfds = source->gpollfds;
- if (gpollfds != NULL)
- {
- GMainContext * context = g_source_get_context ((GSource *)source);
- GSList * scan = gpollfds;
- while (scan != NULL)
- {
- GPollFD * gfd = scan->data;
- g_main_context_remove_poll (context, gfd);
- g_free (gfd);
- scan->data = NULL;
- scan = scan->next;
- }
- g_slist_free (gpollfds);
- }
- source->gpollfds = NULL;
-}
-
-static void
-set_registry (SchemeSource * source, GSList * new, double time)
-{
- /* Set the source's current gpollfds to match NEW. Warns if the
- registry is already set. */
-
- if (source->gpollfds != NULL)
- clear_registry (source);
-
- source->time_limit = time;
- source->runnable = FALSE;
- source->gpollfds = new;
- {
- GMainContext * context = g_source_get_context ((GSource *)source);
- while (new != NULL)
- {
- GPollFD * gfd = new->data;
- /* G_PRIORITY_LOW ensures that window resizes can happen even
- when Scheme is spinning, thus allowing the time-slice
- window to grow with its count. */
- g_main_context_add_poll (context, gfd, G_PRIORITY_LOW);
- new = new->next;
- }
- }
-}
-\f
-
-/* Invoking gtk_main. */
-
-extern SCM Scm_continue_start_gtk (void);
-extern SCM Scm_continue_stop_gtk (void);
-extern int cstack_depth;
-
-gboolean
-start_gtk (int *argc, char ***argv)
-{
- /* Runs gtk_main with scheme_source attached. Returns TRUE when
- successful. Returns FALSE when gtk_init_check failed, or
- gtk_main is already running. */
-
- gboolean initted = FALSE;
-
- if (scheme_source != NULL)
- return (initted);
-
- init_signal_handling ();
-
- if (gtk_init_check (argc, argv)) {
- initted = TRUE;
- CalloutTrampIn tramp = &Scm_continue_start_gtk;
- /* Prep the machine for re-entry via scheme_source->dispatch(),
- which should continue with the seemingly aborted application of
- C-CALL-CONTINUE, which should call Scm_continue_start_gtk().
- That function expects one gboolean in the top CSTACK frame. */
- callout_unseal (tramp);
- CSTACK_PUSH (gboolean, initted);
- CSTACK_PUSH (int, cstack_depth);
- CSTACK_PUSH (CalloutTrampIn, tramp);
-
- install_scheme_source ();
- gtk_main ();
- destroy_scheme_source ();
- }
- return initted;
-}
+extern void (*slice_hook)(void);
+extern int slice_counter;
+extern gchar * current_gpollfds_string (void);
void
-stop_gtk (void)
+gtk_slice_hook (void)
{
- /* Returns TRUE when successful. */
-
- if (scheme_source == NULL)
- return;
- gtk_main_quit ();
- /* NOTREACHED */
-}
-
-void
-run_gtk (unsigned long registry, double time)
-{
- /* Return to the toolkit with the scheme_source set up to dispatch
- to Scheme again when I/O is ready, or a certain TIME has passed.
- If TIME has already passed, the I/O registry is ignored and
- Scheme is ready to run again immediately. If I/O is empty, the
- simulated poll should not re-enter Scheme until TIME. */
-
- set_registry (scheme_source,
- gtk_registry (registry),
- time);
- if (tracing_gtk_select)
- {
- GSList * gpollfds = scheme_source->gpollfds;
- gchar * fdstr = gpollfds_string (gpollfds);
- fprintf (stderr, ";run_gtk%s%s until %.1f\n",
- gpollfds == NULL ? "" : " waiting on", fdstr, time);
- fflush (stderr);
- if (fdstr[0] != '\0')
- g_free (fdstr);
- }
-
/* Update the time-slice window before "sleeping". */
if (slice_window != NULL)
{
text = g_strdup_printf ("Scheme time-slice: %d", slice_counter);
gtk_label_set_text (GTK_LABEL (slice_label), text);
g_free (text);
- fdstr = gpollfds_string (scheme_source->gpollfds);
+ fdstr = current_gpollfds_string ();
text = g_strdup_printf ("Channels:%s", fdstr);
if (fdstr[0] != '\0')
g_free (fdstr);
/* Force expose event delivery, so that animations continue to move
even when Scheme is not "idle". */
gdk_window_process_all_updates ();
-
- /* The c-call primitive has arranged for c-call-continue to run (and
- thus Scm_run_gtk_continue) when Scheme continues. */
- abort_to_c ();
- /*NOTREACHED*/
-}
-
-void
-yield_gtk (void)
-{
- scheme_source->runnable = TRUE;
- trace (";yield_gtk: runnable at %.1f\n", OS_real_time_clock ());
-}
-\f
-/* Gtk Select Registries -- GSLists of GPollFDs. */
-
-/* SELECT_MODE_ -> GIOCondition */
-#define DECODE_MODE(mode) \
-(((((mode) & SELECT_MODE_READ) != 0) ? G_IO_IN : 0) \
- | ((((mode) & SELECT_MODE_WRITE) != 0) ? G_IO_OUT : 0))
-
-/* GIOCondition -> SELECT_MODE_ */
-#define ENCODE_MODE(revents) \
-(((((revents) & G_IO_IN) != 0) ? SELECT_MODE_READ : 0) \
- | ((((revents) & G_IO_OUT) != 0) ? SELECT_MODE_WRITE : 0) \
- | ((((revents) & G_IO_ERR) != 0) ? SELECT_MODE_ERROR : 0) \
- | ((((revents) & G_IO_HUP) != 0) ? SELECT_MODE_HUP : 0))
-
-static GSList *
-gtk_registry (unsigned long registry)
-{
- /* Construct Gtk's version of a select_registry_t. */
-
- int len = OS_select_registry_length (registry);
- int i = 0;
- GSList * list = NULL;
-
- while (i < len)
- {
- int fd;
- unsigned int mode;
- GPollFD * item = g_malloc (sizeof (GPollFD));
- OS_select_registry_entry (registry, i, (&fd), (&mode));
- item->fd = fd;
- item->events = DECODE_MODE (mode) | G_IO_ERR | G_IO_HUP;
- item->revents = 0;
- list = g_slist_prepend (list, item);
- i += 1;
- }
- return (list);
-}
-
-static gchar *
-gpollfds_string (GSList * gpollfds)
-{
- /* Construct a string describing the fds and r/w flags in GPOLLFDS,
- e.g. " 0(r)" */
-
- gchar * string = "";
- GSList * scan = gpollfds;
- while (scan != NULL)
- {
- GPollFD * gfd = scan->data;
- int mode = (gfd->events) & (~(G_IO_HUP|G_IO_ERR));
- gchar * next = g_strdup_printf ("%s %d(%s)", string, gfd->fd,
- (mode == (G_IO_IN|G_IO_OUT) ? "rw"
- : mode == G_IO_IN ? "r"
- : mode == G_IO_OUT ? "w" : "?"));
- if (string[0] != '\0')
- g_free (string);
- string = next;
- scan = scan->next;
- }
- return (string);
}
static void
GDK_WINDOW_TYPE_HINT_UTILITY);
gtk_widget_show_all (slice_window);
gtk_window_parse_geometry (GTK_WINDOW (slice_window), "-0-0");
+ slice_hook = >k_slice_hook;
}
static void
close_slice_window (void)
{
+ slice_hook = NULL;
gtk_widget_destroy (GTK_WIDGET (slice_window));
slice_window = NULL;
gtk_widget_destroy (GTK_WIDGET (status_label));
open_slice_window ();
}
}
-
-gboolean
-gtk_select_trace_p (void)
-{
- return (tracing_gtk_select);
-}
-
-void
-gtk_select_trace (gboolean trace_p)
-{
- tracing_gtk_select = trace_p;
-}
-\f
-/* signal_forwarder
-
- This signal handler can run in any thread because it forwards the
- signal to the scheme_thread. When the handler (subsequently) finds
- itself running in the scheme_thread, it invokes the original
- handler. */
-
-#include <signal.h>
-#include <pthread.h>
-static const char * errno_name (int err);
-static void complain (const char *format, ...);
-
-static pthread_t scheme_thread;
-static struct handler_record * old_handlers = NULL;
-struct handler_record
-{
- int signo;
- void (*handler)(int, siginfo_t *, void *);
- struct handler_record *next;
-};
-
-void
-signal_forwarder (int signo, siginfo_t *siginfo, void *ptr)
-{
- pthread_t self;
-
- self = pthread_self ();
- if (self == scheme_thread)
- {
- struct handler_record * scan;
-
- scan = old_handlers;
- while (scan != NULL)
- {
- if (scan->signo == signo)
- {
- (scan->handler)(signo, siginfo, ptr);
- return;
- }
- scan = scan->next;
- }
- complain (";signal_forwarder: no handler for signo %d\n", signo);
- }
- else
- {
- int err;
-
- err = pthread_kill (scheme_thread, signo);
- if (err != 0)
- {
- complain (";signal_forwarder: pthread_kill failed: %s\n",
- errno_name (err));
- sleep (1);
- }
- }
-}
-
-static void
-init_signal_forwarder (int signo)
-{
- int err;
- struct handler_record *hrec;
- struct sigaction act;
-
- err = sigaction (signo, 0, (&act));
- if (err != 0)
- {
- complain ("init_signal_forwarder: sigaction access failed\n");
- return;
- }
-
- if (((act.sa_flags & SA_SIGINFO) == 0)
- && ((act.sa_handler == SIG_DFL)
- || (act.sa_handler == SIG_IGN)))
- return;
-
- if ((act.sa_flags & SA_SIGINFO) == 0)
- {
- complain ("init_signal_forwarder: no SA_SIGINFO\n");
- return;
- }
-
- hrec = malloc (sizeof (struct handler_record));
- if (hrec == NULL)
- {
- complain ("init_signal_forwarder: malloc failed\n");
- return;
- }
- hrec->signo = signo;
- hrec->handler = act.sa_sigaction;
- hrec->next = old_handlers;
- act.sa_sigaction = &signal_forwarder;
- err = sigaction (signo, &act, 0);
- if (err != 0)
- complain ("init_signal_forwarder: sigaction modify failed\n");
- old_handlers = hrec;
-}
-
-static void
-init_signal_handling (void)
-{
- scheme_thread = pthread_self ();
- foreach_async_signal (&init_signal_forwarder);
-}
-
-static const char *
-errno_name (int err)
-{
- unsigned long length;
- const char ** names;
- OS_syserr_names (&length, &names);
- if (err < length)
- return names[err];
- else
- return "unknown errno";
-}
-
-static void
-complain (const char *format, ...)
-{
- va_list args;
- va_start (args, format);
- vfprintf (stderr, format, args);
- fflush (stderr);
- va_end (args);
-}
#| -*-Scheme-*-
-Copyright (C) 2008, 2009, 2010, 2011 Matthew Birkholz
+Copyright (C) 2008, 2009, 2010, 2011, 2014 Matthew Birkholz
This file is part of MIT/GNU Scheme.
|#
-;;;; Main Loop Hack
+;;;; Initialize per $DISPLAY.
;;; package: (gtk main)
+(define initialized?)
+
+(define (gtk-initialized?)
+ initialized?)
+
(define (gtk-start)
;; Called from gtk/make.scm, from a (load-option 'Gtk).
(set! hook/subprocess-wait nonblocking/subprocess-wait)
- (start-gtk ((ucode-primitive scheme-program-name 0)) *unused-command-line*))
+ (init-gtk ((ucode-primitive scheme-program-name 0)) *unused-command-line*))
(define (initialize-package!)
+ (reset-gtk!)
+ (add-event-receiver! event:after-restore reset-gtk!)
(let ((program-name ((ucode-primitive scheme-program-name 0))))
(let ((processor hook/process-command-line))
(set! hook/process-command-line
(processor
(let ((val (ignore-errors
(lambda ()
- (start-gtk program-name (vector->list line))))))
+ (init-gtk program-name (vector->list line))))))
(if (condition? val)
(begin
(warn val)
line)
(list->vector val)))))))))
-(define (start-gtk name args)
+(define (reset-gtk!)
+ (for-each (lambda (w)
+ (alien-null! (gobject-alien w)))
+ toplevel-windows)
+ (set! toplevel-windows '())
+ (set! initialized? #f))
+
+(define (init-gtk name args)
(let ((path (system-library-pathname "gtk-shim.so")))
(if (not (file-loadable? path)) (error "Gtk shim not loadable."))
(if (let ((s (get-environment-variable "DISPLAY")))
(and (string? s) (not (string-null? s))))
- (start-gtk* name args)
+ (init-gtk* name args)
(warn "DISPLAY not set"))))
-(define (start-gtk* name args)
- ;; Call start_gtk. Warns if gtk_init_check returns 0.
- ;; Returns a list of unused ARGS.
+(define (init-gtk* name args)
+ ;; Call gtk_init_check. Warn if it returns 0. Return a list of
+ ;; unused ARGS.
(let ((arg-count (guarantee-list-of-type->length
args string? "list of commandline arguments (strings)"
- 'START-GTK))
+ 'INIT-GTK))
(vars-size (+ (C-sizeof "int") ;gtk_init_check return var
(C-sizeof "* * char")))) ;gtk_init_check return var
- (guarantee-string name 'START-GTK)
+ (guarantee-string name 'INIT-GTK)
(let* ((words (cons name args))
(vector-size
(* (C-sizeof "* char") (+ 1 arg-count)))
words)
(C->= count-var "int" (+ 1 arg-count))
(C->= vector-var "* * char" vector)
- (if (fix:zero? (C-call "start_gtk" count-var vector-var))
- (warn "Could not start Gtk.")
+ (if (fix:zero? (C-call "gtk_init_check" count-var vector-var))
+ (warn "Could not initialize Gtk.")
(let ((new-argc (C-> count-var "int")))
(C-> vector-var "* * char" vector-scan)
(let ((new-args
(cons (c-peek-cstringp! vector-scan) args))
(reverse! args)))))
(free bytes)
- (create-gtk-thread)
+ (set! initialized? #t)
(cdr new-args)))))))
-(define-integrable (run-gtk select-registry-handle time)
- (C-call "run_gtk" select-registry-handle time))
-
-(define (maybe-yield-gtk)
- ;; Used by callbacks that may have made threads runnable.
- (if (other-running-threads?)
- (C-call "yield_gtk")))
-
-(define (stop-gtk)
- ;; Sortof does the opposite of gtk-start.
- (without-interrupts
- (lambda ()
- (exit-gtk-thread)
- (C-call "stop_gtk"))))
-
(define (gtk-time-slice-window?)
(C-call "gtk_time_slice_window_p"))
(define (gtk-time-slice-window! open?)
(C-call "gtk_time_slice_window" (if open? 1 0)))
-(define (gtk-select-trace?)
- (C-call "gtk_select_trace_p"))
-
-(define (gtk-select-trace! on?)
- (C-call "gtk_select_trace" (if on? 1 0)))
-
(initialize-package!)
\ No newline at end of file
Load the Gtk option. |#
(load-option 'SUBPROCESS) ; Hacked in main.scm.
-(load-option 'SOS)
+(load-option 'CAIRO)
(load-option 'FFI) ; Referenced in gtk.pkg.
(with-loader-base-uri (system-library-uri "gtk/")
(lambda ()
--- /dev/null
+#| -*-Scheme-*-
+
+ Just the glib declarations needed by the pango shim. |#
+
+(typedef gint int)
+(typedef guint16 ushort)
+(typedef gboolean gint)
+(typedef gpointer (* void))
+
+(extern void g_free
+ (mem gpointer))
+
+(extern void g_object_unref (object gpointer))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+pango-1.0/pango/pango-attributes.h |#
+
+(include "glib")
+
+(typedef PangoColor
+ (struct _PangoColor))
+
+(struct _PangoColor
+ (red guint16)
+ (green guint16)
+ (blue guint16))
+
+(extern gboolean pango_color_parse
+ (color (* PangoColor))
+ (spec (* (const char))))
\ No newline at end of file
pango-1.0/pango/pango.h |#
-;(include "pango-attributes")
+(include "pango-attributes")
;(include "pango-break")
(include "pango-context")
;(include "pango-coverage")
--- /dev/null
+# Copyright (C) 2014 Matthew Birkholz
+#
+# This file is part of an extension to 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.
+
+MITSCHEME_EXE = mit-scheme
+exe = '$(MITSCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+prefix = @prefix@
+datarootdir = @datarootdir@
+infodir = @infodir@
+
+all: pango-shim.so pango-types.bin pango-const.bin
+ echo '(load "compile")' | $(exe)
+ @if [ -s pango-unx.crf ]; then \
+ echo "pango-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check:
+ ( echo '(begin'; \
+ echo ' (load "check")'; \
+ echo ' (load "check-doc"))' ) | $(exe)
+
+doc: mit-scheme-pango.info
+doc: mit-scheme-pango.html
+
+mit-scheme-pango.info: pango.texinfo
+ makeinfo --no-split --output=$@ $^
+
+mit-scheme-pango.html: pango.texinfo
+ makeinfo --html --no-split --output=$@ $^
+
+.PHONY: all check doc
+
+install:
+ ( echo '(begin'; \
+ echo ' (install-shim "$(DESTDIR)" "pango")'; \
+ echo ' (install-load-option "$(DESTDIR)" "pango"))' ) \
+ | $(exe) -- *.com *.bci *.pkd make.scm
+
+install-info: mit-scheme-pango.info
+ install $< $(DESTDIR)$(infodir)/
+ install-info $< $(DESTDIR)$(infodir)/dir
+
+install-html: mit-scheme-pango.html
+ echo "(install-html \"$(DESTDIR)\" \"GNOME interface\")" | $(exe) -- $<
+
+.PHONY: install install-info install-html
+
+clean:
+ rm -f pango-const.scm pango-const pango-const.c pango-shim.c
+ rm -f pango-*.crf pango-*.fre pango-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f mit-scheme-pango.html mit-scheme-pango.info
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+tags:
+ etags *.h \
+ `echo *.c | sed 's/ pango-const.c//; s/ pango-shim.c//'` \
+ `echo *.scm | sed 's/ pango-const.scm//'` \
+ -r '/^([^iI].*/' Includes/*.cdecl
+
+.PHONY: clean distclean maintainer-clean tags
+
+pango-shim.so: pango-shim.o
+ echo "(link-shim)" | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
+ `pkg-config --libs pango`
+
+pango-shim.o: pango-shim.c
+ echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
+ `pkg-config --cflags pango` -c $<
+
+pango-shim.c pango-const.c pango-types.bin: pango.cdecl
+ echo '(generate-shim "pango" "#include <pango/pango.h>")' | $(exe)
+
+pango-const.bin: pango-const.scm
+ echo '(sf "pango-const")' | $(exe)
+
+pango-const.scm: pango-const
+ ./pango-const
+
+pango-const: pango-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+pango-const.o: pango-const.c
+ $(CC) $(CPPFLAGS) $(CFLAGS) `pkg-config --cflags pango` -c $<
--- /dev/null
+The Pango text layout wrapper.
+
+To build:
+
+ ./configure [--with-pango=directory]...
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path, and re-writes the optiondb.scm
+found there. You can override the default command name "mit-scheme"
+(and thus the system library path) by setting MITSCHEME_EXE.
+
+For more information see the accompanying user / reference manual.
--- /dev/null
+#| -*-Scheme-*-
+
+ Check that every binding exported to () has a
+ corresponding @deffn in pango.texinfo. |#
+
+(load-option 'cref)
+(define read-package-model)
+(define pmodel/packages)
+(define package/name)
+(define package/bindings)
+(define package/links)
+(define link/source)
+(define link/destination)
+(define binding/package)
+(define binding/name)
+(let ((cref (->environment '(cross-reference))))
+ (set! read-package-model (access read-package-model cref))
+ (set! pmodel/packages (access pmodel/packages cref))
+ (set! package/name (access package/name cref))
+ (set! package/bindings (access package/bindings cref))
+ (set! package/links (access package/links cref))
+ (set! link/source (access link/source cref))
+ (set! link/destination (access link/destination cref))
+ (set! binding/package (access binding/package cref))
+ (set! binding/name (access binding/name cref)))
+
+(define (deffn-name line)
+ (let ((regs (re-string-match
+ (string-append "@deffnx?"
+ " \\(Class\\|Procedure\\|{Generic Procedure}\\)"
+ " \\([-A-Za-z0-9<>?!+./:]+\\)")
+ line)))
+ (if regs
+ (intern (re-match-extract line regs 2))
+ (error "Could not find binding name:" line))))
+
+(define (texinfo-deffns lines)
+ (let ((len (vector-length lines)))
+ (let loop ((i 0) (deffns '()))
+ (if (fix:< i len)
+ (let ((line (vector-ref lines i)))
+ (loop (fix:1+ i)
+ (if (string-prefix? "@deffn" line)
+ (cons (deffn-name line) deffns)
+ deffns)))
+ deffns))))
+
+(define (read-lines port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ '()
+ (cons line (loop))))))
+
+(define (pmodel/find-package pmodel package-name)
+ (find-matching-item (pmodel/packages pmodel)
+ (lambda (p) (equal? package-name (package/name p)))))
+
+(define (pmodel/global-exports pmodel)
+ (define (global-exports package)
+ (append-map! (lambda (link)
+ (if (eq? '() (package/name
+ (binding/package
+ (link/destination link))))
+ (list (binding/name (link/destination link)))
+ '()))
+ (package/links package)))
+ (append-map! global-exports (pmodel/packages pmodel)))
+
+(define (pmodel/package-bindings pmodel package-name)
+ (let ((package (pmodel/find-package pmodel package-name)))
+ (if package
+ (map binding/name (package/bindings package))
+ (error "No such package:" package-name))))
+
+(define (duplicates listset)
+ (let loop ((items listset) (duplicates '()))
+ (cond ((null? items)
+ (reverse! duplicates))
+ ((memq (car items) (cdr items))
+ (if (memq (car items) duplicates)
+ (loop (cdr items) duplicates)
+ (loop (cdr items) (cons (car items) duplicates))))
+ (else
+ (loop (cdr items) duplicates)))))
+
+(define (minus set1 set2)
+ (let loop ((items set1) (difference '()))
+ (cond ((null? items)
+ difference)
+ ((memq (car items) set2)
+ (loop (cdr items) difference))
+ (else
+ (loop (cdr items) (cons (car items) difference))))))
+
+(define (check)
+ (let* ((texinfo (list->vector (call-with-input-file "pango.texinfo"
+ read-lines)))
+ (deffns (texinfo-deffns texinfo))
+ (dups (duplicates deffns))
+ (pmodel (read-package-model "pango" microcode-id/operating-system))
+ (bindings (pmodel/global-exports pmodel))
+ (missing (minus bindings deffns))
+ (extras (minus deffns bindings)))
+ (if (not (null? dups))
+ (for-each (lambda (name) (warn "multiple-descriptions:" name)) dups))
+ (if (not (null? extras))
+ (for-each (lambda (name) (warn "not bound:" name)) extras))
+ (if (not (null? missing))
+ (for-each (lambda (name) (warn "not documented:" name)) missing))))
+
+(check)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the pango wrapper.
+
+(let ((env (->environment '(runtime pathname)))
+ (dirname (directory-pathname (current-load-pathname))))
+ (set! (access library-directory-path env)
+ (cons dirname (access library-directory-path env)))
+ (set! *initial-options-file* (merge-pathnames "pango-optiondb" dirname)))
+
+(load-option 'PANGO)
+(load "pango-check" (->environment '(PANGO)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+
+|#
+
+;;;; Compile the Pango wrapper.
+
+(load-option 'CREF)
+(load-option 'GLIB)
+(load-option 'FFI)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (with-system-library-directories
+ '("./")
+ (lambda ()
+ (if (name->package '(PANGO))
+ (error "The Pango package already exists.")
+ (let ((package-set (package-set-pathname "pango")))
+ (if (not (file-modification-time<? "pango.pkg" package-set))
+ (cref/generate-trivial-constructor "pango"))
+ (construct-packages-from-file (fasload package-set))))
+
+ (compile-file "pango" '("pango-const.bin") (->environment '(pango)))
+
+ (cref/generate-constructors "pango" 'ALL)))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme Pango interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-pango])
+AC_CONFIG_SRCDIR([pango.pkg])
+
+AC_COPYRIGHT(
+[Copyright (C) 2014 Matthew Birkholz
+
+This file is part of an extension to 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.
+])
+
+AH_TOP([/*
+
+Copyright (C) 2014 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.
+
+*/])
+
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+
+if ! pkg-config --exists pango 2>/dev/null; then
+ AC_MSG_ERROR([Pango not found.])
+fi
+
+AC_SUBST([CFLAGS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_SUBST([LIBS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+#| -*-Scheme-*-
+
+Load the Pango option. |#
+
+(load-option 'GLIB)
+(with-loader-base-uri (system-library-uri "pango/")
+ (lambda ()
+ (load-package-set "pango")))
+(add-subsystem-identification! "Pango" '(0 5))
\ No newline at end of file
--- /dev/null
+(warn "No Pango plugin tests!")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test optiondb, includes the installed system's optiondb.
+
+(define-load-option 'PANGO
+ (let ((pathname
+ (merge-pathnames "make"
+ (directory-pathname (current-load-pathname)))))
+ (named-lambda (pango-option-loader)
+ (load pathname))))
+
+(further-load-options
+ (merge-pathnames "optiondb"
+ (last (access library-directory-path
+ (->environment '(runtime pathname))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012 Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for pango-shim.so.
+\f
+(include "Includes/pango")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Pango System Packaging |#
+
+(global-definitions runtime/)
+(global-definitions sos/)
+(global-definitions glib/)
+
+(define-package (pango)
+ (parent (glib))
+ (files "pango")
+ ;;(depends-on "../glib/glib.ext")
+ (export ()
+ pango-color-parse
+ <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-set-markup
+ pango-layout-get-pixel-extents
+ pango-layout-index-to-pos
+ pango-layout-xy-to-index
+ pango-layout-get-baseline
+ pango-font-description-from-string
+ pango-font-description-to-string
+ pango-font-description-free
+ pango-font-description-copy
+ 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))
\ No newline at end of file
;;;; Pango interface.
;;; package: (gtk pango)
+(C-include "pango")
+
+(define (pango-color-parse spec)
+ (guarantee-string spec 'pango-color-parse)
+ (let ((rgb (malloc (C-sizeof "PangoColor") '|PangoColor|)))
+ (if (zero? (C-call "pango_color_parse" rgb spec))
+ (error:wrong-type-argument spec "a color spec" 'pango-color-parse)
+ (let ((color (make-color)))
+
+ (define-integrable (scale int)
+ (flo:/ (->flonum int)
+ (->flonum (shift-left 1 (* 8 (C-sizeof "guint16"))))))
+
+ (set-color-red! color (scale (C-> rgb "PangoColor red")))
+ (set-color-green! color (scale (C-> rgb "PangoColor green")))
+ (set-color-blue! color (scale (C-> rgb "PangoColor blue")))
+ (set-color-alpha! color 1.)
+ (free rgb)
+ color))))
+
(define-class (<pango-layout> (constructor ()))
(<gobject>))
(define (pango-layout-get-pixel-extents layout receiver)
(guarantee-pango-layout layout 'pango-layout-set-text)
(guarantee-procedure-of-arity receiver 2 'pango-layout-set-text)
- (let ((ink-extent (pango-rectangle))
+ (let (;(ink-extent (pango-rectangle))
(logical-extent (pango-rectangle)))
(C-call "pango_layout_get_pixel_extents"
- (gobject-alien layout) ink-extent logical-extent)
+ (gobject-alien layout)
+ 0 ;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)
+ (let ((width (C-> logical-extent "PangoRectangle width"))
+ (height (C-> logical-extent "PangoRectangle height")))
+ ;(free ink-extent)
(free logical-extent)
(receiver width height))))
(define (pango-layout-index-to-pos layout index receiver)
+ (guarantee-pango-layout layout 'pango-layout-index-to-pos)
+ (guarantee-procedure-of-arity receiver 4 'pango-layout-index-to-pos)
(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 (pango-layout-xy-to-index layout x y)
+ (guarantee-pango-layout layout 'pango-layout-xy-to-index)
+ (let ((index-alien (malloc (C-sizeof "int") 'int)))
+ (if (fix:= 0 (C-call "pango_layout_xy_to_index"
+ (gobject-alien layout)
+ (pixels->pangos x) (pixels->pangos y)
+ index-alien 0))
+ (begin
+ (free index-alien)
+ #f)
+ (let ((index (C-> index-alien "int")))
+ (free index-alien)
+ index))))
+
+(define (pango-layout-get-baseline layout)
+ (guarantee-pango-layout layout 'pango-layout-get-baseline)
+ (let ((iter (make-alien '|PangoLayoutIter|))
+ (copy (make-alien '|PangoLayoutIter|)))
+ (add-gc-cleanup iter (make-pango-layout-iter-cleanup copy))
+ (C-call "pango_layout_get_iter" copy (gobject-alien layout))
+ (if (alien-null? copy)
+ (begin
+ (punt-gc-cleanup iter)
+ #f)
+ (begin
+ (copy-alien-address! iter copy)
+ (let ((baseline
+ (pangos->pixels
+ (C-call "pango_layout_iter_get_baseline" iter))))
+ (pango-layout-iter-free iter)
+ baseline)))))
+
+(define (make-pango-layout-iter-cleanup alien)
+ (named-lambda (pango-layout-iter-cleanup)
+ ;;without-interrupts
+ (if (not (alien-null? alien))
+ (begin
+ (C-call "pango_layout_iter_free" alien)
+ (alien-null! alien)))))
+
+(define (pango-layout-iter-free iter)
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? iter))
+ (begin
+ (C-call "pango_layout_iter_free" iter)
+ (alien-null! iter)
+ (punt-gc-cleanup iter))))))
\f
;;; PangoFontDescription
(without-interrupts
(lambda ()
(if (not (alien-null? font))
- (let ((cleanup (punt-gc-cleanup font)))
- (if cleanup (cleanup))
- (alien-null! font))))))
+ (begin
+ (C-call "pango_font_description_free" font)
+ (alien-null! font)
+ (punt-gc-cleanup font))))))
(define (pango-font-description-to-string font)
(guarantee-pango-font-description font 'pango-font-description-to-string)
(without-interrupts
(lambda ()
(if (not (alien-null? metrics))
- (let ((cleanup (punt-gc-cleanup metrics)))
- (if cleanup (cleanup))
- (alien-null! metrics))))))
+ (begin
+ (C-call "pango_font_metrics_unref" metrics)
+ (alien-null! metrics)
+ (punt-gc-cleanup metrics))))))
(define (pango-font-metrics-get-ascent metrics)
(guarantee-live-pango-font-metrics metrics 'pango-font-metrics-get-ascent)
\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)))
--- /dev/null
+\input texinfo @c -*-Texinfo-*-
+@comment %**start of header
+@setfilename mit-scheme-pango
+@set VERSION 0.5
+@settitle MIT/GNU Scheme Pango Plugin @value{VERSION}
+@comment %**end of header
+
+@ifhtml
+@macro bref {name}
+@ref{\name\,,@code{\name\}}
+@end macro
+@end ifhtml
+@ifinfo
+@macro bref {name}
+\name\
+@end macro
+@end ifinfo
+@ifnothtml
+@ifnotinfo
+@macro bref {name}
+@code{\name\}
+@end macro
+@end ifnotinfo
+@end ifnothtml
+
+@copying
+This manual documents MIT/GNU Scheme's @acronym{Pango} plugin @value{VERSION}.
+
+Copyright @copyright{} 2014 Matthew Birkholz
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.2 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
+and with the Back-Cover Texts as in (a) below. A copy of the
+license is included in the section entitled ``GNU Free Documentation
+License.''
+
+(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
+this GNU Manual, like GNU software. Copies published by the Free
+Software Foundation raise funds for GNU development.''
+@end quotation
+@end copying
+
+@dircategory Programming Languages
+@direntry
+* MIT/GNU Scheme Pango: (mit-scheme-pango).
+ Pango text layout plugin.
+@end direntry
+
+@titlepage
+@title The MIT/GNU Scheme Pango Plugin Manual
+@subtitle Schemely access (@value{VERSION}) to the GNOME toolkits
+@subtitle for MIT/GNU Scheme version 9.1
+@author by Matt Birkholz (@email{birkholz@@alum.mit.edu})
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@ifnottex
+@node Top, Introduction, (dir), (dir)
+@top Pango Plugin
+
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction::
+* API Reference::
+* Installation::
+* GNU Free Documentation License::
+@end menu
+
+@node Introduction, API Reference, Top, Top
+@chapter Introduction
+
+The Pango system is a collection of Scheme data types and procedures
+providing a Schemely interface to the Pango text layout library.
+Very little of the library's 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.
+
+@node API Reference, Installation, Introduction, Top
+@chapter API Reference
+
+All of the Pango system's public bindings are exported to the global
+environment and are described here.
+
+PangoLayouts are GObjects and so are represented by instances of a new
+subclass of @code{<gobject>}: @code{<pango-layout>}s. Other Pango
+objects are represented by simple aliens. In either case when a
+plugin procedure returns an object that must be freed, it arranges to
+do so automatically, after the representative 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 is set in @var{layout}'s context.
+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-set-markup layout markup
+Sets @var{layout}'s text to @var{markup}, a simplified XML string.
+
+@var{Markup} is XML with the following simplifications.
+
+@itemize @bullet
+@item
+Only UTF-8 encoding is allowed.
+@item
+No user-defined entities.
+@item
+Processing instructions, comments and the doctype declaration are
+parsed but not interpreted in any way.
+@item
+No DTD nor validation.
+@end itemize
+
+The markup format does support:
+
+@itemize @bullet
+@item
+Elements
+@item
+Attributes
+@item
+5 standard entities: @code{& < > " '}
+@item
+Character references
+@item
+Sections marked as CDATA
+@end itemize
+
+Valid elements are:
+
+@table @code
+@item b
+Bold
+@item big
+Makes font relatively larger, equivalent to @code{<span size="larger">}.
+@item i
+Italic
+@item s
+Strikethrough
+@item sub
+Subscript
+@item sup
+Superscript
+@item small
+Makes font relatively smaller. Equivalent to @code{<span size="smaller">}.
+@item tt
+Monospace font
+@item u
+Underline
+@item span
+General form with many attributes listed below.
+@end table
+
+Valid attributes for the span element are:
+
+@table @code
+
+@item font, font_desc
+A font description string acceptable to
+@bref{pango-font-description-from-string} (e.g. @code{Sans Italic
+12}). Note that any other span attributes will override this
+description. If you have @code{font="Sans Italic"} and also
+@code{style="normal"}, you will get Sans normal, not italic.
+
+@item font_family, face
+A font family name.
+
+@item font_size, size
+Font size in 1024ths of a point, or one of the absolute sizes
+@code{xx-small}, @code{x-small}, @code{small}, @code{medium},
+@code{large}, @code{x-large}, @code{xx-large}, or one of the relative
+sizes @code{smaller} or @code{larger}. If you want to specify a
+absolute size, it is usually easier to take advantage of the ability
+to specify a partial font description using @code{font}; you can use
+@code{font="12.5"} rather than @code{size="12800"}.
+
+@item font_style, style
+One of @code{normal}, @code{oblique}, @code{italic}.
+
+@item font_weight, weight
+One of @code{ultralight}, @code{light}, @code{normal}, @code{bold},
+@code{ultrabold}, @code{heavy}, or a numeric weight.
+
+@item font_variant, variant
+One of @code{normal} or @code{smallcaps}.
+
+@item font_stretch, stretch
+One of @code{ultracondensed}, @code{extracondensed}, @code{condensed},
+@code{semicondensed}, @code{normal}, @code{semiexpanded},
+@code{expanded}, @code{extraexpanded}, @code{ultraexpanded}.
+
+@item foreground, fgcolor, color
+An RGB color specification such as @code{#00FF00} or a color name such
+as @code{red}.
+
+@item background, bgcolor
+An RGB color specification such as @code{#00FF00} or a color name such
+as @code{red}.
+
+@item underline
+One of @code{none}, @code{single}, @code{double}, @code{low},
+@code{error}.
+
+@item underline_color
+The color of underlines; an RGB color specification such as
+@code{#00FF00} or a color name such as @code{red}.
+
+@item rise
+Vertical displacement, in 10000ths of an em. Can be negative for
+subscript, positive for superscript.
+
+@item strikethrough
+@code{true} or @code{false} whether to strike through the text.
+
+@item strikethrough_color
+The color of strikethrough lines; an RGB color specification such as
+@code{#00FF00} or a color name such as @code{red}
+
+@item fallback
+@code{True} or @code{false} whether to enable fallback. If disabled,
+then characters will only be used from the closest matching font on
+the system. No fallback will be done to other fonts on the system that
+might contain the characters in the text. Fallback is enabled by
+default. Most applications should not disable fallback.
+
+@item lang
+A language code (e.g. @code{en} for english), indicating the text
+language.
+
+@item letter_spacing
+Inter-letter spacing in 1024ths of a point.
+
+@item gravity
+One of @code{south}, @code{east}, @code{north}, @code{west}, @code{auto}.
+
+@item gravity_hint
+One of @code{natural}, @code{strong}, @code{line}.
+@end table
+
+@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}.
+
+@var{String} can have three whitespace separated parts:
+@code{family-list style-options size}.
+
+@code{Family-list} can be a comma separated list of families optionally
+terminated by a comma.
+
+@code{Style-options} can be a whitespace separated list of
+words where each word describes one of style, variant, weight,
+stretch, or gravity.
+
+@code{Size} can be a decimal number (size in points) or an absolute
+size followed by the unit modifier @code{px}.
+
+Any one of these parts may be absent. If @code{family-list} is absent,
+then the family name field of the resulting font description will be
+empty. If @code{style-options} is missing, then all style options
+will be set to default values. If @code{size} is missing, the size in
+the resulting font description will be set to 0.
+@end deffn
+
+@deffn Procedure pango-font-description-to-string font
+A string that would parse as @var{font}, a PangoFontDescription alien.
+@end deffn
+
+@deffn Procedure pango-font-description-copy font
+A copy of @var{font}, a new 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
+
+@deffn Procedure pango-color-parse string
+Parses @var{string} and returns a floating-vector containing four
+flonums between 0. and 1. inclusive: the red, green, blue and alpha
+components. @var{String} can be a standard color name (per the
+Cascading Style Sheetse standard) or 1-4 hex digits specifying the
+intensity of the red, green and blue components: @code{"#RGB"} or
+@code{"#RRGGBB"} or @code{"#RRRGGGBBB"} or @code{"#RRRRGGGGBBBB"}.
+@end deffn
+
+@node Installation, GNU Free Documentation License, API Reference, Top
+@chapter Installation
+
+Unpack the source and build in the usual way, but do not call
+@code{./configure} with a @code{--prefix} argument. This plugin will
+be installed in the system library path of the machine run by the
+@code{mit-scheme} command. You can override this command name by
+setting @code{MITSCHEME_EXE}. You can override the system library
+path of any machine by passing it the @code{--library} option on the
+commandline, or the @code{MITSCHEME_LIBRARY_PATH} variable in the
+environment.
+
+@example
+ tar xzf mit-scheme-glib-0.5.tar.gz
+ cd gtk-0.5
+ ./configure
+ make
+ make check
+ make install
+ make install-info
+ make install-html
+ make install-pdf
+@end example
+
+@node GNU Free Documentation License, , Installation, Top
+@appendix GNU Free Documentation License
+
+@center Version 1.2, November 2002
+
+@display
+Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc.
+51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The ``Document'', below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as ``you''. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject. (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+@sc{ascii} without markup, Texinfo input format, La@TeX{} input
+format, @acronym{SGML} or @acronym{XML} using a publicly available
+@acronym{DTD}, and standard-conforming simple @acronym{HTML},
+PostScript or @acronym{PDF} designed for human modification. Examples
+of transparent image formats include @acronym{PNG}, @acronym{XCF} and
+@acronym{JPG}. Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, @acronym{SGML} or
+@acronym{XML} for which the @acronym{DTD} and/or processing tools are
+not generally available, and the machine-generated @acronym{HTML},
+PostScript or @acronym{PDF} produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''. You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warrany Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License. Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License. However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+@end enumerate
+
+@page
+@appendixsec ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+ Copyright (C) @var{year} @var{your name}.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.2
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+ A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with...Texts.'' line with this:
+
+@smallexample
+@group
+ with the Invariant Sections being @var{list their titles}, with
+ the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+ being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@bye
projects / mit-scheme.git / commitdiff