From: Matt Birkholz Date: Sun, 25 May 2014 16:47:18 +0000 (-0700) Subject: gtk: Move GLib, Pango and Cairo code to separate systems. X-Git-Tag: mit-scheme-pucked-9.2.12~407 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f5681ab4214586ce513ef1597c865f9696752408;p=mit-scheme.git gtk: Move GLib, Pango and Cairo code to separate systems. This separation allows the GIO interface (and Pango and Cairo) to work without a DISPLAY. The new (glib) package calls g_main_loop_run with Scheme attached as a GSource. Thus gtk-thread is now glib-thread, and stop-gtk-thread is now stop-glib-thread. The Cairo system depends on Pango and thus GLib only because Cairo seems useless without Pango. Thus there is no need for a Pango-Cairo system. The Gtk system just calls gtk_init_check, not gtk_main. This appears sufficient to get DISPLAY attached to the already running GMainLoop. Gtk-thread-running? is now gtk-initialized?. --- diff --git a/src/cairo/Makefile.in b/src/cairo/Makefile.in new file mode 100644 index 000000000..b41e36401 --- /dev/null +++ b/src/cairo/Makefile.in @@ -0,0 +1,110 @@ +# 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 ")' | $(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 $< diff --git a/src/cairo/README b/src/cairo/README new file mode 100644 index 000000000..f0c2bdc5a --- /dev/null +++ b/src/cairo/README @@ -0,0 +1,13 @@ +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. diff --git a/src/cairo/cairo-check.scm b/src/cairo/cairo-check.scm new file mode 100644 index 000000000..2d29bbaea --- /dev/null +++ b/src/cairo/cairo-check.scm @@ -0,0 +1 @@ +(warn "No Cairo plugin tests!") \ No newline at end of file diff --git a/src/cairo/cairo-optiondb.scm b/src/cairo/cairo-optiondb.scm new file mode 100644 index 000000000..672717a0e --- /dev/null +++ b/src/cairo/cairo-optiondb.scm @@ -0,0 +1,15 @@ +#| -*-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 diff --git a/src/gtk/Includes/cairo.cdecl b/src/cairo/cairo.cdecl similarity index 82% rename from src/gtk/Includes/cairo.cdecl rename to src/cairo/cairo.cdecl index 316c517dc..1bde747dd 100644 --- a/src/gtk/Includes/cairo.cdecl +++ b/src/cairo/cairo.cdecl @@ -1,7 +1,28 @@ #| -*-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. + (typedef cairo_matrix_t (struct _cairo_matrix (xx double) (yx double) @@ -190,4 +211,10 @@ cairo/cairo.h |# (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)) + +;;;; 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 diff --git a/src/cairo/cairo.pkg b/src/cairo/cairo.pkg new file mode 100644 index 000000000..794ed1e81 --- /dev/null +++ b/src/cairo/cairo.pkg @@ -0,0 +1,73 @@ +#| -*-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 diff --git a/src/gtk/cairo.scm b/src/cairo/cairo.scm similarity index 69% rename from src/gtk/cairo.scm rename to src/cairo/cairo.scm index 920c49cbc..b1909ffd6 100644 --- a/src/gtk/cairo.scm +++ b/src/cairo/cairo.scm @@ -1,6 +1,6 @@ #| -*-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. @@ -24,6 +24,8 @@ USA. ;;;; 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|))) @@ -131,6 +133,13 @@ USA. (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)))) (define (cairo-create surface) (guarantee-cairo-surface surface 'cairo-create) @@ -142,15 +151,6 @@ USA. (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 @@ -182,12 +182,20 @@ USA. 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) @@ -201,6 +209,19 @@ USA. (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)) @@ -213,20 +234,105 @@ USA. (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)) @@ -235,10 +341,18 @@ USA. (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) diff --git a/src/cairo/cairo.texinfo b/src/cairo/cairo.texinfo new file mode 100644 index 000000000..cae564f94 --- /dev/null +++ b/src/cairo/cairo.texinfo @@ -0,0 +1,772 @@ +\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 diff --git a/src/cairo/check-doc.scm b/src/cairo/check-doc.scm new file mode 100644 index 000000000..e14edef2f --- /dev/null +++ b/src/cairo/check-doc.scm @@ -0,0 +1,112 @@ +#| -*-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 diff --git a/src/cairo/check.scm b/src/cairo/check.scm new file mode 100644 index 000000000..585ddf46f --- /dev/null +++ b/src/cairo/check.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/cairo/compile.scm b/src/cairo/compile.scm new file mode 100644 index 000000000..ff9347231 --- /dev/null +++ b/src/cairo/compile.scm @@ -0,0 +1,44 @@ +#| -*-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-timeenvironment '(cairo))) + + (cref/generate-constructors "cairo" 'ALL))))) \ No newline at end of file diff --git a/src/cairo/configure.ac b/src/cairo/configure.ac new file mode 100644 index 000000000..ffb5206f7 --- /dev/null +++ b/src/cairo/configure.ac @@ -0,0 +1,64 @@ +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 diff --git a/src/cairo/make.scm b/src/cairo/make.scm new file mode 100644 index 000000000..f3dbadcaf --- /dev/null +++ b/src/cairo/make.scm @@ -0,0 +1,9 @@ +#| -*-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 diff --git a/src/gtk/Includes/gio/gcancellable.cdecl b/src/glib/Includes/gio/gcancellable.cdecl similarity index 100% rename from src/gtk/Includes/gio/gcancellable.cdecl rename to src/glib/Includes/gio/gcancellable.cdecl diff --git a/src/gtk/Includes/gio/gfile.cdecl b/src/glib/Includes/gio/gfile.cdecl similarity index 100% rename from src/gtk/Includes/gio/gfile.cdecl rename to src/glib/Includes/gio/gfile.cdecl diff --git a/src/gtk/Includes/gio/gfileenumerator.cdecl b/src/glib/Includes/gio/gfileenumerator.cdecl similarity index 100% rename from src/gtk/Includes/gio/gfileenumerator.cdecl rename to src/glib/Includes/gio/gfileenumerator.cdecl diff --git a/src/gtk/Includes/gio/gfileinfo.cdecl b/src/glib/Includes/gio/gfileinfo.cdecl similarity index 100% rename from src/gtk/Includes/gio/gfileinfo.cdecl rename to src/glib/Includes/gio/gfileinfo.cdecl diff --git a/src/gtk/Includes/gio/ginputstream.cdecl b/src/glib/Includes/gio/ginputstream.cdecl similarity index 100% rename from src/gtk/Includes/gio/ginputstream.cdecl rename to src/glib/Includes/gio/ginputstream.cdecl diff --git a/src/gtk/Includes/gio/gio.cdecl b/src/glib/Includes/gio/gio.cdecl similarity index 100% rename from src/gtk/Includes/gio/gio.cdecl rename to src/glib/Includes/gio/gio.cdecl diff --git a/src/gtk/Includes/gio/gioenums.cdecl b/src/glib/Includes/gio/gioenums.cdecl similarity index 100% rename from src/gtk/Includes/gio/gioenums.cdecl rename to src/glib/Includes/gio/gioenums.cdecl diff --git a/src/gtk/Includes/gio/giotypes.cdecl b/src/glib/Includes/gio/giotypes.cdecl similarity index 100% rename from src/gtk/Includes/gio/giotypes.cdecl rename to src/glib/Includes/gio/giotypes.cdecl diff --git a/src/gtk/Includes/gio/gmountoperation.cdecl b/src/glib/Includes/gio/gmountoperation.cdecl similarity index 100% rename from src/gtk/Includes/gio/gmountoperation.cdecl rename to src/glib/Includes/gio/gmountoperation.cdecl diff --git a/src/gtk/Includes/gio/goutputstream.cdecl b/src/glib/Includes/gio/goutputstream.cdecl similarity index 100% rename from src/gtk/Includes/gio/goutputstream.cdecl rename to src/glib/Includes/gio/goutputstream.cdecl diff --git a/src/glib/Includes/glib-object.cdecl b/src/glib/Includes/glib-object.cdecl new file mode 100644 index 000000000..554508f9c --- /dev/null +++ b/src/glib/Includes/glib-object.cdecl @@ -0,0 +1,20 @@ +#| -*-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 diff --git a/src/glib/Includes/glib.cdecl b/src/glib/Includes/glib.cdecl new file mode 100644 index 000000000..24ecb79f1 --- /dev/null +++ b/src/glib/Includes/glib.cdecl @@ -0,0 +1,63 @@ +#| -*-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 diff --git a/src/gtk/Includes/glib/gerror.cdecl b/src/glib/Includes/glib/gerror.cdecl similarity index 100% rename from src/gtk/Includes/glib/gerror.cdecl rename to src/glib/Includes/glib/gerror.cdecl diff --git a/src/gtk/Includes/glib/glist.cdecl b/src/glib/Includes/glib/glist.cdecl similarity index 100% rename from src/gtk/Includes/glib/glist.cdecl rename to src/glib/Includes/glib/glist.cdecl diff --git a/src/gtk/Includes/glib/gquark.cdecl b/src/glib/Includes/glib/gquark.cdecl similarity index 100% rename from src/gtk/Includes/glib/gquark.cdecl rename to src/glib/Includes/glib/gquark.cdecl diff --git a/src/gtk/Includes/glib/gtypes.cdecl b/src/glib/Includes/glib/gtypes.cdecl similarity index 100% rename from src/gtk/Includes/glib/gtypes.cdecl rename to src/glib/Includes/glib/gtypes.cdecl diff --git a/src/gtk/Includes/glib/gvariant.cdecl b/src/glib/Includes/glib/gvariant.cdecl similarity index 100% rename from src/gtk/Includes/glib/gvariant.cdecl rename to src/glib/Includes/glib/gvariant.cdecl diff --git a/src/gtk/Includes/gobject/gboxed.cdecl b/src/glib/Includes/gobject/gboxed.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gboxed.cdecl rename to src/glib/Includes/gobject/gboxed.cdecl diff --git a/src/gtk/Includes/gobject/genums.cdecl b/src/glib/Includes/gobject/genums.cdecl similarity index 100% rename from src/gtk/Includes/gobject/genums.cdecl rename to src/glib/Includes/gobject/genums.cdecl diff --git a/src/gtk/Includes/gobject/gobject.cdecl b/src/glib/Includes/gobject/gobject.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gobject.cdecl rename to src/glib/Includes/gobject/gobject.cdecl diff --git a/src/gtk/Includes/gobject/gparam.cdecl b/src/glib/Includes/gobject/gparam.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gparam.cdecl rename to src/glib/Includes/gobject/gparam.cdecl diff --git a/src/gtk/Includes/gobject/gparamspecs.cdecl b/src/glib/Includes/gobject/gparamspecs.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gparamspecs.cdecl rename to src/glib/Includes/gobject/gparamspecs.cdecl diff --git a/src/gtk/Includes/gobject/gsignal.cdecl b/src/glib/Includes/gobject/gsignal.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gsignal.cdecl rename to src/glib/Includes/gobject/gsignal.cdecl diff --git a/src/gtk/Includes/gobject/gtype.cdecl b/src/glib/Includes/gobject/gtype.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gtype.cdecl rename to src/glib/Includes/gobject/gtype.cdecl diff --git a/src/gtk/Includes/gobject/gvalue.cdecl b/src/glib/Includes/gobject/gvalue.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gvalue.cdecl rename to src/glib/Includes/gobject/gvalue.cdecl diff --git a/src/gtk/Includes/gobject/gvaluetypes.cdecl b/src/glib/Includes/gobject/gvaluetypes.cdecl similarity index 100% rename from src/gtk/Includes/gobject/gvaluetypes.cdecl rename to src/glib/Includes/gobject/gvaluetypes.cdecl diff --git a/src/glib/Makefile.in b/src/glib/Makefile.in new file mode 100644 index 000000000..c8b71b6b4 --- /dev/null +++ b/src/glib/Makefile.in @@ -0,0 +1,114 @@ +# 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 $< diff --git a/src/glib/README b/src/glib/README new file mode 100644 index 000000000..9ce83dba5 --- /dev/null +++ b/src/glib/README @@ -0,0 +1,14 @@ +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. diff --git a/src/glib/check-doc.scm b/src/glib/check-doc.scm new file mode 100644 index 000000000..1d85495d0 --- /dev/null +++ b/src/glib/check-doc.scm @@ -0,0 +1,113 @@ +#| -*-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 diff --git a/src/glib/check.scm b/src/glib/check.scm new file mode 100644 index 000000000..643e838a6 --- /dev/null +++ b/src/glib/check.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/glib/compile.scm b/src/glib/compile.scm new file mode 100644 index 000000000..e63aef3f2 --- /dev/null +++ b/src/glib/compile.scm @@ -0,0 +1,56 @@ +#| -*-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-timeenvironment '(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 diff --git a/src/glib/configure.ac b/src/glib/configure.ac new file mode 100644 index 000000000..8c97b3f86 --- /dev/null +++ b/src/glib/configure.ac @@ -0,0 +1,64 @@ +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 diff --git a/src/gtk/gio.scm b/src/glib/gio.scm similarity index 99% rename from src/gtk/gio.scm rename to src/glib/gio.scm index e718aab29..82dbae12e 100644 --- a/src/gtk/gio.scm +++ b/src/glib/gio.scm @@ -22,7 +22,9 @@ USA. |# ;;;; GIO Objects -;;; package: (gtk gio) +;;; package: (glib gio) + +(C-include "glib") (define (open-input-gfile uri) (let* ((uri* (->uri* uri 'open-input-gfile)) @@ -319,7 +321,7 @@ USA. ;; 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)) diff --git a/src/glib/glib-check.scm b/src/glib/glib-check.scm new file mode 100644 index 000000000..3a29a6be1 --- /dev/null +++ b/src/glib/glib-check.scm @@ -0,0 +1,74 @@ +#| -*-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/") stringenvironment '(runtime pathname)))))) \ No newline at end of file diff --git a/src/glib/glib-shim.h b/src/glib/glib-shim.h new file mode 100644 index 000000000..640c60162 --- /dev/null +++ b/src/glib/glib-shim.h @@ -0,0 +1,39 @@ +/* -*-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 +#include +#include +#include + +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); diff --git a/src/glib/glib-tests.scm b/src/glib/glib-tests.scm new file mode 100644 index 000000000..e576ec1df --- /dev/null +++ b/src/glib/glib-tests.scm @@ -0,0 +1,88 @@ +#| -*-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. + +;;; 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/") stringsimple-namestring pathname))))) + (sort (delete! ".." (delete! "." names)) stringsimple-namestring + (access ->simple-namestring (->environment '(gio)))) \ No newline at end of file diff --git a/src/gtk/thread.scm b/src/glib/glib-thread.scm similarity index 62% rename from src/gtk/thread.scm rename to src/glib/glib-thread.scm index 77138797b..cc7c14b3d 100644 --- a/src/gtk/thread.scm +++ b/src/glib/glib-thread.scm @@ -1,6 +1,6 @@ #| -*-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. @@ -22,12 +22,12 @@ USA. |# ;;;; 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! @@ -36,28 +36,22 @@ USA. ;;; 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)))) @@ -76,26 +70,26 @@ USA. (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) diff --git a/src/glib/glib.cdecl b/src/glib/glib.cdecl new file mode 100644 index 000000000..ad5bf8f26 --- /dev/null +++ b/src/glib/glib.cdecl @@ -0,0 +1,76 @@ +#| -*-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. + +(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 diff --git a/src/glib/glib.pkg b/src/glib/glib.pkg new file mode 100644 index 000000000..19d154cf9 --- /dev/null +++ b/src/glib/glib.pkg @@ -0,0 +1,123 @@ +#| -*-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-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-input-stream-read + g-input-stream-skip + g-input-stream-close + + g-output-stream-write + g-output-stream-flush + g-output-stream-close + + gfile-read + + gfile-append-to + gfile-create + gfile-replace + + gfile-query-info + gfile-info-list-attributes + gfile-info-get-attribute-status + gfile-info-get-attribute-value + + gfile-enumerate-children + gfile-enumerator-next-files + gfile-enumerator-close + + 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 diff --git a/src/glib/glib.scm b/src/glib/glib.scm new file mode 100644 index 000000000..f9a13c48e --- /dev/null +++ b/src/glib/glib.scm @@ -0,0 +1,108 @@ +#| -*-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)) + +(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 diff --git a/src/glib/glib.texinfo b/src/glib/glib.texinfo new file mode 100644 index 000000000..1b51c88c1 --- /dev/null +++ b/src/glib/glib.texinfo @@ -0,0 +1,1095 @@ +\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{} 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{} +@deffn Class +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 + + make-gfile + + gfile-query-info + gfile-info-list-attributes + gfile-info-get-attribute-status + gfile-info-get-attribute-value + + gfile-enumerate-children + gfile-enumerator-next-files + gfile-enumerator-close + + + g-input-stream-read + g-input-stream-skip + g-input-stream-close + + gfile-read + + g-output-stream-write + g-output-stream-flush + g-output-stream-close + + gfile-append-to + gfile-create + gfile-replace +@end verbatim + +@deffn Class +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 +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 +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 +Abstract superclass of GIO streams. +@end deffn + +@deffn Class +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 +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 +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 +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 diff --git a/src/glib/glibio.c b/src/glib/glibio.c new file mode 100644 index 000000000..9d3d29c91 --- /dev/null +++ b/src/glib/glibio.c @@ -0,0 +1,619 @@ +/* -*-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 +#include +#include +#include +#include +#include + +/* 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; + } + } +} + + +/* 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 ()); +} + +/* 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; +} + +/* 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 +#include +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); +} diff --git a/src/gtk/gobject.scm b/src/glib/gobject.scm similarity index 74% rename from src/gtk/gobject.scm rename to src/glib/gobject.scm index 24a4adbc8..85dde6699 100644 --- a/src/gtk/gobject.scm +++ b/src/glib/gobject.scm @@ -1,6 +1,6 @@ #| -*-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. @@ -22,7 +22,9 @@ USA. |# ;;;; GObjects -;;; package: (gtk gobject) +;;; package: (glib gobject) + +(C-include "glib") (define-class () @@ -470,159 +472,6 @@ USA. (set! gquark-from-string-cache (make-string-hash-table)) (set! gquark-to-string-cache (make-eqv-hash-table)) unspecific) - -;;; GdkPixbufLoaders - -(define-class ( (constructor ())) - () - (port define standard initial-value #f) - (thread define standard initial-value #f) - (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 ( (constructor ())) - ()) - -(define-method initialize-instance ((pixbuf )) - (call-next-method pixbuf) - (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|)) - -(define-method initialize-instance ((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))))) - -(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!) diff --git a/src/glib/make.scm b/src/glib/make.scm new file mode 100644 index 000000000..215b59af3 --- /dev/null +++ b/src/glib/make.scm @@ -0,0 +1,10 @@ +#| -*-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 diff --git a/src/glib/test-copy-1.txt b/src/glib/test-copy-1.txt new file mode 100644 index 000000000..1ec888fbd --- /dev/null +++ b/src/glib/test-copy-1.txt @@ -0,0 +1,235 @@ +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. + +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). + +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. + +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. + +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. + diff --git a/src/gtk/Includes/gdkcairo.cdecl b/src/gtk/Includes/gdkcairo.cdecl index 97af7df27..c8afedb52 100644 --- a/src/gtk/Includes/gdkcairo.cdecl +++ b/src/gtk/Includes/gdkcairo.cdecl @@ -2,7 +2,7 @@ gdk/gdkcairo.h |# -(include "pangocairo") +;(include "pangocairo") (extern (* cairo_t) gdk_cairo_create (window (* GdkWindow))) diff --git a/src/gtk/Includes/gdktypes.cdecl b/src/gtk/Includes/gdktypes.cdecl index ab0e40a67..58539ca61 100644 --- a/src/gtk/Includes/gdktypes.cdecl +++ b/src/gtk/Includes/gdktypes.cdecl @@ -5,6 +5,12 @@ gdk/gdktypes.h |# (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))) diff --git a/src/gtk/Includes/glib-object.cdecl b/src/gtk/Includes/glib-object.cdecl index 554508f9c..75f526b3f 100644 --- a/src/gtk/Includes/glib-object.cdecl +++ b/src/gtk/Includes/glib-object.cdecl @@ -6,15 +6,29 @@ glib-2.0/glib-object.h |# ;(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 diff --git a/src/gtk/Includes/glib.cdecl b/src/gtk/Includes/glib.cdecl index 24ecb79f1..17b4ab49a 100644 --- a/src/gtk/Includes/glib.cdecl +++ b/src/gtk/Includes/glib.cdecl @@ -1,63 +1,42 @@ #| -*-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 diff --git a/src/gtk/Includes/pangocairo.cdecl b/src/gtk/Includes/pangocairo.cdecl deleted file mode 100644 index 6b65202c6..000000000 --- a/src/gtk/Includes/pangocairo.cdecl +++ /dev/null @@ -1,15 +0,0 @@ -#| -*-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))) diff --git a/src/gtk/Makefile.in b/src/gtk/Makefile.in index 49aee47cd..4930d886c 100644 --- a/src/gtk/Makefile.in +++ b/src/gtk/Makefile.in @@ -17,8 +17,8 @@ # 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@ @@ -106,8 +106,7 @@ gtk-shim.o: gtk-shim.c gtk-shim.h 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 diff --git a/src/gtk/check.scm b/src/gtk/check.scm index 20fb55326..6522aab60 100644 --- a/src/gtk/check.scm +++ b/src/gtk/check.scm @@ -9,6 +9,6 @@ (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 diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index 7e8e55ff2..627ae50a7 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -24,7 +24,7 @@ USA. ;;;; 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 () @@ -47,17 +47,13 @@ USA. ;; 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))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 5b1f0a8f8..65fac2cc4 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -395,6 +395,7 @@ USA. (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) @@ -413,9 +414,9 @@ USA. (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")))) @@ -598,7 +599,8 @@ USA. (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)) @@ -938,25 +940,18 @@ USA. (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 @@ -964,26 +959,17 @@ USA. (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.) @@ -1119,21 +1105,19 @@ USA. (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... @@ -1142,7 +1126,7 @@ USA. (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) @@ -1151,8 +1135,8 @@ USA. (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))) @@ -1245,26 +1229,26 @@ USA. (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))) @@ -1377,23 +1361,23 @@ USA. (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 @@ -1513,8 +1497,8 @@ USA. (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 @@ -1522,7 +1506,7 @@ USA. (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) @@ -1542,19 +1526,13 @@ USA. (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) @@ -1569,37 +1547,15 @@ USA. (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))) @@ -1737,7 +1693,7 @@ USA. (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 ) dx dy) (generic-fix-ink-move! ink dx dy)) @@ -1769,10 +1725,10 @@ USA. (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)) diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm new file mode 100644 index 000000000..102628752 --- /dev/null +++ b/src/gtk/gdk.scm @@ -0,0 +1,223 @@ +#| -*-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))) + +;;; GdkPixbufLoaders + +(define-class ( (constructor ())) + () + (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 ( (constructor ())) + ()) + +(define-method initialize-instance ((pixbuf )) + (call-next-method pixbuf) + (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|)) + +(define-method initialize-instance ((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 diff --git a/src/gtk/gtk-check.scm b/src/gtk/gtk-check.scm index 8dffd93c4..6048872c1 100644 --- a/src/gtk/gtk-check.scm +++ b/src/gtk/gtk-check.scm @@ -27,10 +27,7 @@ USA. (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)))) @@ -52,29 +49,6 @@ USA. (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/") stringflonum (-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) @@ -230,59 +231,51 @@ USA. (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) @@ -291,7 +284,8 @@ USA. (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))))) (define (event-to-text GdkEvent) diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm index 0f0197869..c73735009 100644 --- a/src/gtk/gtk-graphics.scm +++ b/src/gtk/gtk-graphics.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2013 Matthew Birkholz +Copyright (C) 2013, 2014 Matthew Birkholz This file is part of an extension to MIT/GNU Scheme. @@ -45,30 +45,26 @@ USA. (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)) @@ -135,24 +131,22 @@ USA. (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) @@ -162,11 +156,9 @@ USA. (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. @@ -178,8 +170,8 @@ USA. (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))) @@ -188,17 +180,17 @@ USA. (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.))) @@ -208,47 +200,49 @@ USA. (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)) @@ -265,19 +259,8 @@ USA. (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. @@ -286,12 +269,12 @@ USA. (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))) @@ -311,9 +294,7 @@ USA. (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))) @@ -321,12 +302,11 @@ USA. (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) diff --git a/src/gtk/gtk-tests.scm b/src/gtk/gtk-tests.scm index 5b2692b01..ddeca48ac 100644 --- a/src/gtk/gtk-tests.scm +++ b/src/gtk/gtk-tests.scm @@ -23,72 +23,6 @@ USA. ;;;; Test procedures for the gtks. -;;; 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/") stringsimple-namestring pathname))))) - (sort (delete! ".." (delete! "." names)) stringsimple-namestring - (access ->simple-namestring (->environment '(gtk gio)))) - -;;; Gtk tests. - (define (await-closed-demos) (gtk-time-slice-window! #t) (hello) diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl index daa3da39c..cc401edcf 100644 --- a/src/gtk/gtk.cdecl +++ b/src/gtk/gtk.cdecl @@ -23,63 +23,22 @@ USA. ;;;; C declarations for gtk-shim.so. -(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 @@ -108,9 +67,6 @@ USA. (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))) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 6aefbd893..ce3a358c4 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -26,24 +26,25 @@ USA. (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-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 make-pixbuf-loader load-pixbuf-from-port load-pixbuf-from-file pixbuf-loader-size-hook set-pixbuf-loader-size-hook! @@ -51,111 +52,7 @@ USA. 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 - - 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-input-stream-read - g-input-stream-skip - g-input-stream-close - - g-output-stream-write - g-output-stream-flush - g-output-stream-close - - gfile-read - - gfile-append-to - gfile-create - gfile-replace - - gfile-query-info - gfile-info-list-attributes - gfile-info-get-attribute-status - gfile-info-get-attribute-value - - gfile-enumerate-children - gfile-enumerator-next-files - gfile-enumerator-close - - make-gfile)) - -(define-package (gtk pango) - (parent (gtk)) - (files "pango") - ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") - (export (gtk) - - 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)) + )) (define-package (gtk gtk-widget) (parent (gtk)) @@ -240,7 +137,7 @@ USA. gtk-paned-get-child1 gtk-paned-get-child2 gtk-paned-get-position gtk-paned-set-position 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)) @@ -260,7 +157,7 @@ USA. (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! @@ -364,27 +261,12 @@ USA. 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)) @@ -395,7 +277,7 @@ USA. 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)) @@ -422,7 +304,7 @@ USA. (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) @@ -445,7 +327,7 @@ USA. 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) diff --git a/src/gtk/gtk.texinfo b/src/gtk/gtk.texinfo index d270cc14f..1446dd9c0 100644 --- a/src/gtk/gtk.texinfo +++ b/src/gtk/gtk.texinfo @@ -1,8 +1,8 @@ \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 @@ -24,9 +24,10 @@ @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 @@ -46,11 +47,11 @@ Software Foundation raise funds for GNU development.'' @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}) @@ -61,7 +62,7 @@ Software Foundation raise funds for GNU development.'' @ifnottex @node Top, Introduction, (dir), (dir) -@top Gtk Interface +@top Gtk Plugin @insertcopying @end ifnottex @@ -82,11 +83,12 @@ The Gtk system is a collection of Scheme data types and procedures 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! @@ -293,13 +295,7 @@ This appendix lists all of the procedures and data types that make up the Gtk interface. @menu -* GObject:: -* GIO:: * Pixbuf Loader:: -* Pango Layout:: -* Cairo Context:: -* Cairo Surface:: -* Cairo Pattern:: * Gtk Adjustment:: * Gtk Widget:: * Gtk Container:: @@ -317,427 +313,7 @@ the Gtk interface. * Debugging Facilities:: @end menu -@node GObject, GIO, API Reference, API Reference -@section GObject - -An instance of @code{} 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{} -@deffn Class -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 - - make-gfile - - gfile-query-info - gfile-info-list-attributes - gfile-info-get-attribute-status - gfile-info-get-attribute-value - - gfile-enumerate-children - gfile-enumerator-next-files - gfile-enumerator-close - - - g-input-stream-read - g-input-stream-skip - g-input-stream-close - - gfile-read - - g-output-stream-write - g-output-stream-flush - g-output-stream-close - - gfile-append-to - gfile-create - gfile-replace -@end verbatim - -@deffn Class -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 -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 -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 -Abstract superclass of GIO streams. -@end deffn - -@deffn Class -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 -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 -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 -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 @@ -826,472 +402,7 @@ immediately. @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 -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{}. -@item i -Italic -@item s -Strikethrough -@item sub -Subscript -@item sup -Superscript -@item small -Makes font relatively smaller. Equivalent to @code{}. -@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 @@ -2912,6 +2023,10 @@ procedure does nothing. @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 @@ -2933,17 +2048,9 @@ The key name (character or symbol) associated with the Gdk @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 @@ -2952,56 +2059,30 @@ A convenient procedure to determine whether the toolkit is dead. 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 diff --git a/src/gtk/gtkio.c b/src/gtk/gtkio.c index 8ce801cdb..db660cf35 100644 --- a/src/gtk/gtkio.c +++ b/src/gtk/gtkio.c @@ -21,386 +21,29 @@ USA. */ -/* 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 #include -#include -#include +/* #include */ +/* #include */ #include -/* 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; - } - } -} - - -/* 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) { @@ -409,7 +52,7 @@ run_gtk (unsigned long registry, double time) 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); @@ -420,80 +63,6 @@ run_gtk (unsigned long registry, double time) /* 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 ()); -} - -/* 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 @@ -517,11 +86,13 @@ open_slice_window (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)); @@ -561,142 +132,3 @@ gtk_time_slice_window (gboolean open_p) 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; -} - -/* 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 -#include -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); -} diff --git a/src/gtk/main.scm b/src/gtk/main.scm index b42998894..59ca873b7 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -1,6 +1,6 @@ #| -*-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. @@ -21,15 +21,22 @@ USA. |# -;;;; 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 @@ -37,30 +44,37 @@ USA. (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))) @@ -81,8 +95,8 @@ USA. 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 @@ -92,34 +106,13 @@ USA. (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 diff --git a/src/gtk/make.scm b/src/gtk/make.scm index 40ecef296..b1d01e8fe 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -3,7 +3,7 @@ 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 () diff --git a/src/pango/Includes/glib.cdecl b/src/pango/Includes/glib.cdecl new file mode 100644 index 000000000..60603d61e --- /dev/null +++ b/src/pango/Includes/glib.cdecl @@ -0,0 +1,13 @@ +#| -*-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 diff --git a/src/pango/Includes/pango-attributes.cdecl b/src/pango/Includes/pango-attributes.cdecl new file mode 100644 index 000000000..255ad4da3 --- /dev/null +++ b/src/pango/Includes/pango-attributes.cdecl @@ -0,0 +1,17 @@ +#| -*-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 diff --git a/src/gtk/Includes/pango-context.cdecl b/src/pango/Includes/pango-context.cdecl similarity index 100% rename from src/gtk/Includes/pango-context.cdecl rename to src/pango/Includes/pango-context.cdecl diff --git a/src/gtk/Includes/pango-font.cdecl b/src/pango/Includes/pango-font.cdecl similarity index 100% rename from src/gtk/Includes/pango-font.cdecl rename to src/pango/Includes/pango-font.cdecl diff --git a/src/gtk/Includes/pango-layout.cdecl b/src/pango/Includes/pango-layout.cdecl similarity index 100% rename from src/gtk/Includes/pango-layout.cdecl rename to src/pango/Includes/pango-layout.cdecl diff --git a/src/gtk/Includes/pango-types.cdecl b/src/pango/Includes/pango-types.cdecl similarity index 100% rename from src/gtk/Includes/pango-types.cdecl rename to src/pango/Includes/pango-types.cdecl diff --git a/src/gtk/Includes/pango.cdecl b/src/pango/Includes/pango.cdecl similarity index 90% rename from src/gtk/Includes/pango.cdecl rename to src/pango/Includes/pango.cdecl index 8444eb442..a2a7e0f2e 100644 --- a/src/gtk/Includes/pango.cdecl +++ b/src/pango/Includes/pango.cdecl @@ -2,7 +2,7 @@ pango-1.0/pango/pango.h |# -;(include "pango-attributes") +(include "pango-attributes") ;(include "pango-break") (include "pango-context") ;(include "pango-coverage") diff --git a/src/pango/Makefile.in b/src/pango/Makefile.in new file mode 100644 index 000000000..f0c90d037 --- /dev/null +++ b/src/pango/Makefile.in @@ -0,0 +1,110 @@ +# 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 ")' | $(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 $< diff --git a/src/pango/README b/src/pango/README new file mode 100644 index 000000000..53420f97d --- /dev/null +++ b/src/pango/README @@ -0,0 +1,13 @@ +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. diff --git a/src/pango/check-doc.scm b/src/pango/check-doc.scm new file mode 100644 index 000000000..0b789b38f --- /dev/null +++ b/src/pango/check-doc.scm @@ -0,0 +1,112 @@ +#| -*-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 diff --git a/src/pango/check.scm b/src/pango/check.scm new file mode 100644 index 000000000..ba5268213 --- /dev/null +++ b/src/pango/check.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/pango/compile.scm b/src/pango/compile.scm new file mode 100644 index 000000000..07b423f24 --- /dev/null +++ b/src/pango/compile.scm @@ -0,0 +1,43 @@ +#| -*-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-timeenvironment '(pango))) + + (cref/generate-constructors "pango" 'ALL))))) \ No newline at end of file diff --git a/src/pango/configure.ac b/src/pango/configure.ac new file mode 100644 index 000000000..423233c2d --- /dev/null +++ b/src/pango/configure.ac @@ -0,0 +1,64 @@ +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 diff --git a/src/pango/make.scm b/src/pango/make.scm new file mode 100644 index 000000000..7b86c41f4 --- /dev/null +++ b/src/pango/make.scm @@ -0,0 +1,9 @@ +#| -*-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 diff --git a/src/pango/pango-check.scm b/src/pango/pango-check.scm new file mode 100644 index 000000000..78ce752c7 --- /dev/null +++ b/src/pango/pango-check.scm @@ -0,0 +1 @@ +(warn "No Pango plugin tests!") \ No newline at end of file diff --git a/src/pango/pango-optiondb.scm b/src/pango/pango-optiondb.scm new file mode 100644 index 000000000..3298a02ea --- /dev/null +++ b/src/pango/pango-optiondb.scm @@ -0,0 +1,15 @@ +#| -*-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 diff --git a/src/pango/pango.cdecl b/src/pango/pango.cdecl new file mode 100644 index 000000000..59a9b71af --- /dev/null +++ b/src/pango/pango.cdecl @@ -0,0 +1,26 @@ +#| -*-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. + +(include "Includes/pango") \ No newline at end of file diff --git a/src/pango/pango.pkg b/src/pango/pango.pkg new file mode 100644 index 000000000..df26ec392 --- /dev/null +++ b/src/pango/pango.pkg @@ -0,0 +1,37 @@ +#| -*-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-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 diff --git a/src/gtk/pango.scm b/src/pango/pango.scm similarity index 80% rename from src/gtk/pango.scm rename to src/pango/pango.scm index fd10b967c..4f2ab5b68 100644 --- a/src/gtk/pango.scm +++ b/src/pango/pango.scm @@ -24,6 +24,26 @@ USA. ;;;; 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 ( (constructor ())) ()) @@ -70,18 +90,22 @@ USA. (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"))) @@ -90,6 +114,55 @@ USA. (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)))))) ;;; PangoFontDescription @@ -121,9 +194,10 @@ USA. (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) @@ -210,9 +284,10 @@ USA. (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) @@ -255,9 +330,6 @@ USA. ;;; 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))) diff --git a/src/pango/pango.texinfo b/src/pango/pango.texinfo new file mode 100644 index 000000000..6cf2b4ca1 --- /dev/null +++ b/src/pango/pango.texinfo @@ -0,0 +1,848 @@ +\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{}: @code{}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 +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{}. +@item i +Italic +@item s +Strikethrough +@item sub +Subscript +@item sup +Superscript +@item small +Makes font relatively smaller. Equivalent to @code{}. +@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