From: Matt Birkholz Date: Thu, 24 Jun 2010 18:26:26 +0000 (-0700) Subject: For Edwin: gtk-widget-font, scm-layout-scroll-step, etc. X-Git-Tag: 20101221-Gtk~4 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cfbd775aa7f252e362eb7c6efb3f3c6dc87f45d6;p=mit-scheme.git For Edwin: gtk-widget-font, scm-layout-scroll-step, etc. * doc/gtk/gtk.texinfo: Followed the example of ffi.texinfo. Added VERSION. Changed name from "Users'" to "Reference" Manual. Clarified how to run the examples. * src/Makefile.in: Use @FFIS@ to init FFIS, allowing gtk to be built conditionally. Install lib/conses.png only when the Gtk interface is built. * src/Setup.sh: The lib/lib/prgtkio.so symlink is no longer needed. * src/configure.ac: Added support for a --with-gtk option, to conditionally include Gtk. Added --enable-debugging, needed in microcode/achost.ac. * src/gtk/.gitignore: Make git ignore the gtk-shim build byproducts. * src/gtk/Includes/, src/gtk/gtk.cdecl: Added and deleted various declarations. * src/gtk/demo.scm: Renamed the event handler "demo-event-handler". Added a call to gtk-widget-grab-focus. * src/gtk/ed-ffi.scm: Added pango.scm. * src/gtk/gobject.scm: Added punt-gc-cleanup, for alien objects that can be explicitly destroyed as well as GCed. Allow for C-enum values that do not fit in a fixnum. Treat them as integers. * src/gtk/gtk-object.scm: Defined and used gtk-object-flags, despite their being deprecated. Added peek-gtk-adjustment, for debugging. Added gtk-widget-queue-draw, -get-pango-context, -create-pango-layout, -set-size-request. Added gtk-widget-font, -bg-color, -fg-color, -base-color, and -text-color, and their setters, mostly from scm-layout.scm. Added gtk-scrolled-window-set-policy and -set-placement. Replace guarantee-gtk-window with check-gtk-window. Use error:wrong-type-argument in the check-TYPE procedures. Fixed the C types peeked by gtk-window-get-default-size. * src/gtk/gtk.pkg: Added several new exports, and a new (gtk pango) package. Moved color and font support from (gtk layout) to (gtk gtk-object). * src/gtk/gtk.scm: Added rect-union!. Use integer operators on pixel coordinates and sizes. Moved most of the Pango code to the new pango.scm file. * src/gtk/gtk.sf: Suppress option loading noise. Syntax each file in its respective package, as its dependencies require. * src/gtk/hello.scm: Quiet warnings. Punt call to error; keeping it simple. This code appears in the manual. * src/gtk/main.scm: Punt private copy of ucode-primitive syntax transformer. * src/gtk/pango.scm: New, implementing as a . * src/gtk/scm-layout.scm: Created a second, "detailed" trace level. Allow logical device coordinates and sizes to be integers, not just fixnums. Added set-scm-layout-scroll-step! and scm-layout-realized?. Init on-screen-area to an un(der)defined rect. Adjust scrollbars only when realized and necessary. Moved the color support to gtk-object.scm. None of it depends on scm-layout anymore -- just gtk-widget. Re-worked the _get_modifier_style,modify,_modify_style abstraction to accommodate set-rcstyle-font!. Combined common scrolling code from set-scm-layout-scroll-pos!, scm-layout-adjustment-value-changed. Allow drawing-add-item! to splice in an item just under/before another, given item. Keep drawn-item changes (damage old area, move, damage new area) thread-atomic, else another thread can interfere. * src/gtk/thread.scm (kill-gtk-thread): Send ONE thread event, and clear gtk-thread first. * src/microcode/configure.ac: Put prgtkio.so on MODULE_TARGETS, not _BASES. The latter does too much. --- diff --git a/doc/gtk/gtk.texinfo b/doc/gtk/gtk.texinfo index 241be68a2..2fd3a6306 100644 --- a/doc/gtk/gtk.texinfo +++ b/doc/gtk/gtk.texinfo @@ -1,11 +1,12 @@ \input texinfo @c -*-Texinfo-*- @comment %**start of header @setfilename mit-scheme-gtk -@settitle Gtk Users' Manual +@set VERSION 0.1 +@settitle Gtk @value{VERSION} @comment %**end of header @copying -The users' manual for a Gtk interface for MIT/GNU Scheme. +This manual documents @acronym{Gtk} @value{VERSION}. Copyright @copyright{} 2008, 2009, 2010 Matthew Birkholz @@ -26,13 +27,13 @@ Software Foundation raise funds for GNU development.'' @dircategory Programming Languages @direntry -* Gtk Users': (mit-scheme-gtk). MIT/GNU Scheme GNOME toolkit +* Gtk Interface: (mit-scheme-gtk). MIT/GNU Scheme GNOME Interface @end direntry @titlepage -@title The Gtk Users' Manual -@subtitle for Schemely access to the GNOME toolkit -@subtitle for MIT/GNU Scheme version 7.7.90+ +@title The Gtk Reference Manual +@subtitle Schemely access (@value{VERSION}) to the GNOME toolkits +@subtitle for MIT/GNU Scheme version 9.0.1+ @author by Matt Birkholz (@email{birkholz@@alum.mit.edu}) @page @vskip 0pt plus 1filll @@ -41,7 +42,7 @@ Software Foundation raise funds for GNU development.'' @ifnottex @node Top, Introduction, (dir), (dir) -@top Gtk Users' Manual +@top Gtk Interface @insertcopying @end ifnottex @@ -51,7 +52,7 @@ Software Foundation raise funds for GNU development.'' * Hello World:: Not your primitive ``Hello, world!'' example. * Gtk-Event-Viewer:: A simple Scheme widget. GtkEv translated into Scheme/FFI. * Scm-Layout:: A Scheme canvas widget. -* GNU Free Documentation License:: +* GNU Free Documentation License:: @end menu @@ -87,10 +88,10 @@ wrappings. The existing wrappers are the best examples of what needs to be done. They are written in Scheme/FFI --- Scheme extended with the accompanying FFI. @ifnothtml -@xref{Top,, Introduction, mit-scheme-ffi, FFI Users' Manual}. +@xref{Top,, Introduction, mit-scheme-ffi, The FFI Reference Manual}. @end ifnothtml @ifhtml -See the @uref{../FFI/mit-scheme-ffi.html,, FFI Users' Manual}. +See the @uref{../FFI/mit-scheme-ffi.html,, The FFI Reference Manual}. @end ifhtml @unnumberedsec Procedures @@ -118,7 +119,7 @@ The @code{gtk-label-get-text} wrapper procedure hides these details. Using such wrappings, the primitive ``Hello, world!'' example in the FFI system @ifnothtml -(@pxref{Top,, Hello World, mit-scheme-ffi, FFI Users' Manual}) +(@pxref{Top,, Hello World, mit-scheme-ffi, The FFI Reference Manual}) @end ifnothtml @ifhtml (@uref{mit-scheme-ffi.html#Hello%20World,, here}) @@ -234,9 +235,8 @@ the first or second expression below. @node Hello World, Gtk-Event-Viewer, Introduction, Top @chapter Hello World -To run the example ``Hello, World!'' program, enter the following -command lines in the @file{src/gtk} directory of the source -distribution. +To run the example ``Hello, World!'' program, execute the following +command lines in the @file{src/gtk} directory of your build tree. @smallexample ../microcode/scheme --library ../lib @@ -262,7 +262,8 @@ running within callouts. For example, while calling out to @code{gdk_window_show_all}, the toolkit calls the Scheme widget's realize method, which calls out again to @code{gdk_window_new}. -Enter these 3 lines to create this widget. +To see this widget, execute the following command lines in the +@file{src/gtk} directory of your build tree. @smallexample ../microcode/scheme --library ../lib @@ -304,7 +305,8 @@ There are just a few specializations of @code{} so far: A demo of two @code{} widgets displaying one canvas is provided. The canvas contains text, horizontal and vertical lines, and an image. It also contains animated boxes that blink and follow -the mouse. Enter these 3 lines to create this widget. +the mouse. To see these widgets in action, execute the following +command lines in the @file{src/gtk} directory of your build tree. @smallexample ../microcode/scheme --library ../lib diff --git a/src/Makefile.in b/src/Makefile.in index 7ff6700c5..ce3aba870 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -62,7 +62,7 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/microcode/mkinstalldirs LIARC_BOOT_BUNDLES = compiler cref sf star-parser LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml $(FFIS) -FFIS = gtk +FFIS = @FFIS@ SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES) @@ -204,7 +204,8 @@ install-auxdir-top: $(mkinstalldirs) $(DESTDIR)$(AUXDIR) $(INSTALL_DATA) $(top_srcdir)/etc/optiondb.scm $(DESTDIR)$(AUXDIR)/. $(INSTALL_DATA) lib/*.com $(DESTDIR)$(AUXDIR)/. - $(INSTALL_DATA) lib/*.png $(DESTDIR)$(AUXDIR)/. + if [ -e lib/conses.png ]; then \ + $(INSTALL_DATA) lib/conses.png $(DESTDIR)$(AUXDIR)/.; fi .PHONY: all all-native all-liarc all-svm macosx-app .PHONY: compile-microcode build-bands diff --git a/src/Setup.sh b/src/Setup.sh index 97ce73615..16143a8c9 100755 --- a/src/Setup.sh +++ b/src/Setup.sh @@ -86,7 +86,6 @@ maybe_link lib/optiondb.scm ../etc/optiondb.scm maybe_link lib/runtime ../runtime maybe_link lib/mit-scheme.h ../microcode/pruxffi.h maybe_link lib/ffi ../ffi -maybe_link lib/lib/prgtkio.so ../../microcode/prgtkio.so maybe_link lib/gtk ../gtk maybe_link config.sub microcode/config.sub maybe_link config.guess microcode/config.guess diff --git a/src/configure.ac b/src/configure.ac index 340922a7f..77b168cfd 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -38,6 +38,16 @@ AC_ARG_ENABLE([host-scheme-test], [Test for working scheme on build host [[no]]])) : ${enable_host_scheme_test=no} +AC_ARG_ENABLE([debugging], + AS_HELP_STRING([--enable-debugging], + [Compile with debugging support [[no]]])) +: ${enable_debugging='no'} + +AC_ARG_WITH([gtk], + AS_HELP_STRING([--with-gtk], + [Support the GNOME Toolkits if available [[yes]]])) +: ${with_gtk='yes'} + AC_CANONICAL_HOST MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}]) @@ -92,7 +102,28 @@ directory, which is usually \`/usr/local/lib/mit-scheme-${mit_scheme_native_code AC_MSG_RESULT([yes]) fi +AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) +if test "${with_gtk}" = yes; then + AC_MSG_CHECKING([for gtk]) + if test "${PKG_CONFIG}" != yes; then + AC_MSG_RESULT([no, no pkg-config]) + with_gtk=no + elif ! "${MIT_SCHEME_EXE}" --eval "(load-option'FFI)" \ + --batch-mode /dev/null 2>&1; then + AC_MSG_RESULT([no, no FFI]) + with_gtk=no + else + if pkg-config --exists gtk+-2.0; then + AC_MSG_RESULT([yes]) + FFIS=gtk + else + AC_MSG_RESULT([no, ! pkg-config --exists gtk+2.0]) + fi + fi +fi + AC_SUBST([ALL_TARGET]) +AC_SUBST([FFIS]) AC_SUBST([INSTALL_COM]) AC_SUBST([INSTALL_LIARC_BUNDLES]) AC_SUBST([MIT_SCHEME_EXE]) @@ -129,7 +160,6 @@ compiler/Makefile cref/Makefile edwin/Makefile ffi/Makefile -gtk/Makefile imail/Makefile runtime/Makefile sf/Makefile @@ -140,6 +170,9 @@ win32/Makefile xdoc/Makefile xml/Makefile ]) +if test "${with_gtk}" = yes; then + AC_CONFIG_FILES([gtk/Makefile]) +fi AC_OUTPUT if test x"${mit_scheme_native_code}" = xc; then @@ -150,8 +183,9 @@ if test x"${mit_scheme_native_code}" = xc; then for BN in star-parser; do (cd lib; rm -f ${BN}; ${LN_S} ../${BN} .) done - for BUNDLE in 6001 compiler cref edwin ffi gtk imail sf sos ssp \ - star-parser xdoc xml; do + BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml" + if test x"${with_gtk}" = xyes; then BUNDLES="$BUNDLES gtk"; fi + for BUNDLE in $BUNDLES; do SO=${BUNDLE}.so (cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .) done diff --git a/src/gtk/.gitignore b/src/gtk/.gitignore new file mode 100644 index 000000000..88d07585f --- /dev/null +++ b/src/gtk/.gitignore @@ -0,0 +1,6 @@ +gtk-const +gtk-const.c +gtk-const.scm +gtk-shim.c +gtk-shim.so +scmwidget.c diff --git a/src/gtk/Includes/gdkevents.cdecl b/src/gtk/Includes/gdkevents.cdecl index 6a2c627f9..db532eb60 100644 --- a/src/gtk/Includes/gdkevents.cdecl +++ b/src/gtk/Includes/gdkevents.cdecl @@ -88,7 +88,9 @@ gtk-2.0/gdk/gdkevents.h |# (GDK_SCROLL) (GDK_WINDOW_STATE) (GDK_SETTING) - (GDK_OWNER_CHANGE))) + (GDK_OWNER_CHANGE) + (GDK_GRAB_BROKEN) + (GDK_DAMAGE))) (typedef GdkEventMask (enum diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl index 70439ab76..d3ea4f3b8 100644 --- a/src/gtk/Includes/gtkwidget.cdecl +++ b/src/gtk/Includes/gtkwidget.cdecl @@ -292,6 +292,9 @@ gtk-2.0/gtk/gtkwidget.h |# (extern void gtk_widget_show_all (widget (* GtkWidget))) +(extern void gtk_widget_queue_draw + (widget (* GtkWidget))) + (extern void gtk_widget_queue_draw_area (widget (* GtkWidget)) (x gint) @@ -308,6 +311,11 @@ gtk-2.0/gtk/gtkwidget.h |# (extern void gtk_widget_error_bell (widget (* GtkWidget))) +(extern void gtk_widget_set_size_request + (widget (* GtkWidget)) + (width gint) + (height gint)) + (extern (* GdkColormap) gtk_widget_get_colormap (widget (* GtkWidget))) (extern (* GdkVisual) gtk_widget_get_visual @@ -349,10 +357,6 @@ gtk-2.0/gtk/gtkwidget.h |# (state GtkStateType) (color (* (const GdkColor)))) -(extern void gtk_widget_modify_font - (widget (* GtkWidget)) - (font_desc (* PangoFontDescription))) - (extern (* PangoContext) gtk_widget_get_pango_context (widget (* GtkWidget))) diff --git a/src/gtk/Includes/pango-context.cdecl b/src/gtk/Includes/pango-context.cdecl index d9614cc9b..c7697aecf 100644 --- a/src/gtk/Includes/pango-context.cdecl +++ b/src/gtk/Includes/pango-context.cdecl @@ -33,10 +33,14 @@ pango-1.0/pango/pango-context.h |# (desc (const (* PangoFontDescription))) (language (* PangoLanguage))) -;(extern void -; pango_context_set_font_description -; (context (* PangoContext)) -; (desc (const (* PangoFontDescription)))) +(extern (* PangoFontDescription) + pango_context_get_font_description + (context (* PangoContext))) + +(extern void + pango_context_set_font_description + (context (* PangoContext)) + (desc (const (* PangoFontDescription)))) (extern (* PangoLanguage) pango_context_get_language diff --git a/src/gtk/Includes/pango-font.cdecl b/src/gtk/Includes/pango-font.cdecl index 0bf1bf4dc..9406818ec 100644 --- a/src/gtk/Includes/pango-font.cdecl +++ b/src/gtk/Includes/pango-font.cdecl @@ -67,13 +67,17 @@ pango-1.0/pango/pango-font.h |# pango_font_description_from_string (str (* (const char)))) +(extern (* char) + pango_font_description_to_string + (desc (* (const PangoFontDescription)))) + (extern void pango_font_metrics_unref (metrics (* PangoFontMetrics))) (extern int pango_font_metrics_get_ascent (metrics (* PangoFontMetrics))) (extern int pango_font_metrics_get_descent (metrics (* PangoFontMetrics))) -;(extern int pango_font_metrics_get_approximate_char_width (metrics (* PangoFontMetrics))) -(extern int pango_font_metrics_get_approximate_digit_width (metrics (* PangoFontMetrics))) +(extern int pango_font_metrics_get_approximate_char_width (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_approximate_digit_width (metrics (* PangoFontMetrics))) ;(extern int pango_font_metrics_get_underline_position (metrics (* PangoFontMetrics))) -;(extern int pango_font_metrics_get_unerline_thickness (metrics (* PangoFontMetrics))) +;(extern int pango_font_metrics_get_underline_thickness (metrics (* PangoFontMetrics))) ;(extern int pango_font_metrics_get_strikethrough_position (metrics (* PangoFontMetrics))) ;(extern int pango_font_metrics_get_strikethrough_thickness (metrics (* PangoFontMetrics))) diff --git a/src/gtk/Includes/pango-layout.cdecl b/src/gtk/Includes/pango-layout.cdecl index cb622cd94..c98d2c026 100644 --- a/src/gtk/Includes/pango-layout.cdecl +++ b/src/gtk/Includes/pango-layout.cdecl @@ -7,36 +7,55 @@ pango-1.0/pango/pango-layout.h |# ;(include "pango-glyph-item") ;(include "pango-tabs") +(extern (* PangoLayout) pango_layout_new + (context (* PangoContext))) + +(extern (* PangoContext) pango_layout_get_context + (layout (* PangoLayout))) + +(extern void pango_layout_set_text + (layout (* PangoLayout)) + (text (const (* char))) + (length int)) + +(extern void pango_layout_set_font_description + (layout (* PangoLayout)) + (desc (const (* PangoFontDescription)))) + +(extern (const (* PangoFontDescription)) + pango_layout_get_font_description + (layout (* PangoLayout))) + (extern int pango_layout_get_spacing (layout (* PangoLayout))) + (extern void pango_layout_get_extents (layout (* PangoLayout)) (ink_rect (* PangoRectangle)) (logical_rect (* PangoRectangle))) + (extern void pango_layout_get_pixel_extents (layout (* PangoLayout)) (ink_rect (* PangoRectangle)) (logical_rect (* PangoRectangle))) -(extern void pango_layout_set_text - (layout (* PangoLayout)) - (text (const (* char))) - (length int)) -(extern void pango_layout_set_font_description - (layout (* PangoLayout)) - (desc (const (* PangoFontDescription)))) + (extern void pango_layout_index_to_pos (layout (* PangoLayout)) (index int) (pos (* PangoRectangle))) + (extern void pango_layout_xy_to_index (layout (* PangoLayout)) (x int) (y int) (index (* int)) (trailing (* int))) + (extern (* PangoLayoutIter) pango_layout_get_iter (layout (* PangoLayout))) + (extern void pango_layout_iter_free (iter (* PangoLayoutIter))) + (extern int pango_layout_iter_get_baseline - (iter (* PangoLayoutIter))) + (iter (* PangoLayoutIter))) \ No newline at end of file diff --git a/src/gtk/demo.scm b/src/gtk/demo.scm index 63f208e02..21227d412 100644 --- a/src/gtk/demo.scm +++ b/src/gtk/demo.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -49,20 +49,24 @@ USA. (outf-console "; Closed "window".\n") 0)) (let ((drawing (demo-drawing layout1))) + (set-scm-layout-drawing! layout1 drawing) (set-scm-layout-scroll-pos! layout1 175 150) (set-scm-widget-event! - layout1 (demo-event layout1 (scm-layout-event layout1))) + layout1 (demo-event-handler layout1 (scm-layout-event-handler layout1))) + (set-scm-layout-drawing! layout2 drawing) (set-scm-layout-scroll-pos! layout2 175 150) (set-scm-widget-event! - layout2 (demo-event layout2 (scm-layout-event layout2))) + layout2 (demo-event-handler layout2 (scm-layout-event-handler layout2))) + (let ((cursor1 (add-box-item drawing 'BOTTOM)) (cursor2 (add-box-item drawing 'BOTTOM))) (set-demo-drawing-cursor-items! drawing (list (list cursor1 layout1) (list cursor2 layout2))) (let ((thread (start-blinking drawing))) (outf-console "; Cursor blinking courtesy of "thread".\n")))) + (gtk-widget-grab-focus layout1) (outf-console "; Created "layout1" and "layout2"\n")) unspecific) @@ -96,8 +100,8 @@ USA. ;; and mouse motion handler. (cursor-items define standard initial-value '())) -(define (demo-event widget old-handler) - (named-lambda (scm-layout-demo::event GtkWidget GdkEvent) +(define (demo-event-handler widget old-handler) + (named-lambda (scm-layout-demo::handle-event GtkWidget GdkEvent) (trace2 ";(scm-layout-demo::event "GtkWidget" "GdkEvent")\n") (let ((type (C-> GdkEvent "GdkEvent any type"))) diff --git a/src/gtk/ed-ffi.scm b/src/gtk/ed-ffi.scm index 9d72bec5d..6fe4af646 100644 --- a/src/gtk/ed-ffi.scm +++ b/src/gtk/ed-ffi.scm @@ -11,5 +11,6 @@ GTK buffer packaging info |# ("scm-layout" (gtk layout)) ("thread" (gtk thread)) ("main" (gtk main)) + ("pango" (gtk pango)) ("gtk-ev" (gtk event-viewer)) ("demo" (gtk demo)))) \ No newline at end of file diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index 4dfd91b1b..f1b27f5cb 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -197,6 +197,24 @@ USA. (lambda () (set! gc-cleanups (cons (weak-cons object cleanup-thunk) gc-cleanups))))) + +(define (punt-gc-cleanup object) + (without-interrupts + (lambda () + (let ((entry (weak-assq object gc-cleanups))) + (if entry + (begin + (set! gc-cleanups (delq! entry gc-cleanups)) + (weak-cdr entry)) + #f))))) + +(define (weak-assq obj alist) + (let loop ((alist alist)) + (if (null? alist) #f + (let* ((entry (car alist)) + (key (weak-car entry))) + (if (eq? obj key) entry + (loop (cdr alist))))))) ;;; Properties @@ -213,58 +231,59 @@ USA. (C-call "g_object_get_property" (gobject-alien object) name gvalue) (let* ((type (C-> gvalue "GValue g_type")) (value - (case type - (((C-enum "G_TYPE_INVALID")) - (ferror "Property "name" (for "object") is invalid.")) - (((C-enum "G_TYPE_NONE")) - (ferror "Property "name" (for "object") is void.")) - (((C-enum "G_TYPE_INTERFACE")) (unimplemented "an interface")) - (((C-enum "G_TYPE_CHAR")) - (C-call "g_value_get_char" gvalue)) - (((C-enum "G_TYPE_UCHAR")) - (C-call "g_value_get_uchar" gvalue)) - (((C-enum "G_TYPE_BOOLEAN")) - (C-call "g_value_get_boolean" gvalue)) - (((C-enum "G_TYPE_INT")) - (C-call "g_value_get_int" gvalue)) - (((C-enum "G_TYPE_UINT")) - (C-call "g_value_get_uint" gvalue)) - (((C-enum "G_TYPE_LONG")) - (C-call "g_value_get_long" gvalue)) - (((C-enum "G_TYPE_ULONG")) - (C-call "g_value_get_ulong" gvalue)) -; (((C-enum "G_TYPE_INT64")) -; (C-call "g_value_get_int64" gvalue)) -; (((C-enum "G_TYPE_UINT64")) -; (C-call "g_value_get_uint64" gvalue)) - (((C-enum "G_TYPE_ENUM")) - (C-call "g_value_get_enum" gvalue)) - (((C-enum "G_TYPE_FLAGS")) - (C-call "g_value_get_flags" gvalue)) - (((C-enum "G_TYPE_FLOAT")) - (C-call "g_value_get_float" gvalue)) - (((C-enum "G_TYPE_DOUBLE")) - (C-call "g_value_get_double" gvalue)) - (((C-enum "G_TYPE_STRING")) - (let ((alien (make-alien '(const (* |gchar|))))) - (C-call "g_value_get_string" alien gvalue) - (let ((str (c-peek-cstring alien))) - (free alien) - str))) - (((C-enum "G_TYPE_POINTER")) - (let ((alien (make-alien '|gpointer|))) - (C-call "g_value_get_pointer" alien gvalue) - alien)) - (((C-enum "G_TYPE_BOXED")) (unimplemented "a boxed")) - (((C-enum "G_TYPE_PARAM")) (unimplemented "a param")) - (((C-enum "G_TYPE_OBJECT")) - (let ((alien (make-alien '|GObject|))) - (C-call "g_value_get_object" alien gvalue) - alien)) - (else - (ferror "Unexpected GFundamentalType " - (C-enum "enum GFundamentalType" type) - " ("type")."))))) + (cond + ((int:= type (C-enum "G_TYPE_INVALID")) + (ferror "Property "name" (for "object") is invalid.")) + ((int:= type (C-enum "G_TYPE_NONE")) + (ferror "Property "name" (for "object") is void.")) + ((int:= type (C-enum "G_TYPE_INTERFACE")) + (unimplemented "an interface")) + ((int:= type (C-enum "G_TYPE_CHAR")) + (C-call "g_value_get_char" gvalue)) + ((int:= type (C-enum "G_TYPE_UCHAR")) + (C-call "g_value_get_uchar" gvalue)) + ((int:= type (C-enum "G_TYPE_BOOLEAN")) + (C-call "g_value_get_boolean" gvalue)) + ((int:= type (C-enum "G_TYPE_INT")) + (C-call "g_value_get_int" gvalue)) + ((int:= type (C-enum "G_TYPE_UINT")) + (C-call "g_value_get_uint" gvalue)) + ((int:= type (C-enum "G_TYPE_LONG")) + (C-call "g_value_get_long" gvalue)) + ((int:= type (C-enum "G_TYPE_ULONG")) + (C-call "g_value_get_ulong" gvalue)) +; ((int:= type (C-enum "G_TYPE_INT64")) +; (C-call "g_value_get_int64" gvalue)) +; ((int:= type (C-enum "G_TYPE_UINT64")) +; (C-call "g_value_get_uint64" gvalue)) + ((int:= type (C-enum "G_TYPE_ENUM")) + (C-call "g_value_get_enum" gvalue)) + ((int:= type (C-enum "G_TYPE_FLAGS")) + (C-call "g_value_get_flags" gvalue)) + ((int:= type (C-enum "G_TYPE_FLOAT")) + (C-call "g_value_get_float" gvalue)) + ((int:= type (C-enum "G_TYPE_DOUBLE")) + (C-call "g_value_get_double" gvalue)) + ((int:= type (C-enum "G_TYPE_STRING")) + (let ((alien (make-alien '(const (* |gchar|))))) + (C-call "g_value_get_string" alien gvalue) + (let ((str (c-peek-cstring alien))) + (free alien) + str))) + ((int:= type (C-enum "G_TYPE_POINTER")) + (let ((alien (make-alien '|gpointer|))) + (C-call "g_value_get_pointer" alien gvalue) + alien)) + ((int:= type (C-enum "G_TYPE_BOXED")) (unimplemented "a boxed")) + ((int:= type (C-enum "G_TYPE_PARAM")) (unimplemented "a param")) + ((int:= type (C-enum "G_TYPE_OBJECT")) + (let ((alien (make-alien '|GObject|))) + (C-call "g_value_get_object" alien gvalue) + alien)) + (else + (ferror "Unexpected GFundamentalType " + (C-enum "enum GFundamentalType" type) + " ("type")."))))) (free gvalue) value))) @@ -300,68 +319,68 @@ USA. (C-call "g_value_init" gvalue gtype) ;; g_value_set_* gvalue * (let ((fundamental (C-call "G_TYPE_FUNDAMENTAL" gtype))) - (case fundamental - (((C-enum "G_TYPE_CHAR")) - (C-call "g_value_set_char" - gvalue (check-prop-char value name))) - (((C-enum "G_TYPE_UCHAR")) - (C-call "g_value_set_uchar" - gvalue (check-prop-uchar value name))) - (((C-enum "G_TYPE_INT")) - (C-call "g_value_set_int" - gvalue (check-prop-int value name))) - (((C-enum "G_TYPE_UINT")) - (C-call "g_value_set_uint" - gvalue (check-prop-uint value name))) + (cond + ((int:= fundamental (C-enum "G_TYPE_CHAR")) + (C-call "g_value_set_char" + gvalue (check-prop-char value name))) + ((int:= fundamental (C-enum "G_TYPE_UCHAR")) + (C-call "g_value_set_uchar" + gvalue (check-prop-uchar value name))) + ((int:= fundamental (C-enum "G_TYPE_INT")) + (C-call "g_value_set_int" + gvalue (check-prop-int value name))) + ((int:= fundamental (C-enum "G_TYPE_UINT")) + (C-call "g_value_set_uint" + gvalue (check-prop-uint value name))) ; (((C-enum "G_TYPE_LONG")) ; (C-call "g_value_set_long" ; gvalue (check-prop-long value name))) ; (((C-enum "G_TYPE_ULONG")) ; (C-call "g_value_set_ulong" ; gvalue (check-prop-ulong value name))) - (((C-enum "G_TYPE_FLOAT")) - (C-call "g_value_set_float" - gvalue (check-prop-flonum value name))) - (((C-enum "G_TYPE_DOUBLE")) - (C-call "g_value_set_double" - gvalue (check-prop-flonum value name))) - (((C-enum "G_TYPE_STRING")) - (C-call "g_value_set_string" - gvalue (check-prop-string value name))) - (((C-enum "G_TYPE_BOOLEAN")) - (C-call "g_value_set_boolean" - gvalue (check-prop-boolean value name))) - (((C-enum "G_TYPE_ENUM")) - (C-call "g_value_set_enum" - gvalue (check-prop-enum value name))) - (((C-enum "G_TYPE_FLAGS")) - (C-call "g_value_set_flags" - gvalue (check-prop-flags value name))) - (((C-enum "G_TYPE_OBJECT")) - (let* ((value-alien - (cond ((gobject? value) (gobject-alien value)) - ((alien? value) value) - (else - (ferror - "The value "value" for property " - name" of "gclass-name" is not a" - " nor alien.")))) - (value-gtype - (gobject-get-gtype value-alien))) - (if (fix:zero? (C-call "g_value_type_compatible" - value-gtype gtype)) - (ferror "The value "value" for property " - name" of "gclass-name - " has incompatible type " - (gclass-get-name - (gobject-get-gclass value-alien)) - ".")) - (C-call "g_value_set_object" gvalue value-alien))) - (else - (ferror "Fundamental GType " - (C-enum "enum GFundamentalType" fundamental) - " (the type of the "name" property of a " - gclass-name") is not supported.")))) + ((int:= fundamental (C-enum "G_TYPE_FLOAT")) + (C-call "g_value_set_float" + gvalue (check-prop-flonum value name))) + ((int:= fundamental (C-enum "G_TYPE_DOUBLE")) + (C-call "g_value_set_double" + gvalue (check-prop-flonum value name))) + ((int:= fundamental (C-enum "G_TYPE_STRING")) + (C-call "g_value_set_string" + gvalue (check-prop-string value name))) + ((int:= fundamental (C-enum "G_TYPE_BOOLEAN")) + (C-call "g_value_set_boolean" + gvalue (check-prop-boolean value name))) + ((int:= fundamental (C-enum "G_TYPE_ENUM")) + (C-call "g_value_set_enum" + gvalue (check-prop-enum value name))) + ((int:= fundamental (C-enum "G_TYPE_FLAGS")) + (C-call "g_value_set_flags" + gvalue (check-prop-flags value name))) + ((int:= fundamental (C-enum "G_TYPE_OBJECT")) + (let* ((value-alien + (cond ((gobject? value) (gobject-alien value)) + ((alien? value) value) + (else + (ferror + "The value "value" for property " + name" of "gclass-name" is not a" + " nor alien.")))) + (value-gtype + (gobject-get-gtype value-alien))) + (if (fix:zero? (C-call "g_value_type_compatible" + value-gtype gtype)) + (ferror "The value "value" for property " + name" of "gclass-name + " has incompatible type " + (gclass-get-name + (gobject-get-gclass value-alien)) + ".")) + (C-call "g_value_set_object" gvalue value-alien))) + (else + (ferror "Fundamental GType " + (C-enum "enum GFundamentalType" fundamental) + " (the type of the "name" property of a " + gclass-name") is not supported.")))) (C-call "g_object_set_property" object-alien name gvalue) (C-call "g_value_reset" gvalue))) (loop (cddr plist))))) @@ -421,23 +440,26 @@ USA. (define (check-prop-int value name) (check-prop-value value name "fit in an int" (lambda (x) (and (exact-integer? x) - (<= (expt -2 31) x (- (expt 2 32) 1)))))) + (int:<= (expt -2 31) x) + (int:< x (expt 2 31)))))) (define (uint? x) - (and (exact-integer? x) (<= 0 x (- (expt 2 32) 1)))) + (and (exact-integer? x) (int:<= 0 x) (int:< x (expt 2 32)))) (define (check-prop-uint value name) (check-prop-value value name "fit in an unsigned int" uint?)) -;(define (check-prop-long value name) -; (check-prop-value value name "fit in a long" -; (lambda (x) (and (exact-integer? x) -; (<= (expt -2 63) x (- (expt 2 64) 1)))))) +#;(define (check-prop-long value name) + (check-prop-value value name "fit in a long" + (lambda (x) (and (exact-integer? x) + (int:<= (expt -2 63) x) + (int:< x (expt 2 63)))))) -;(define (check-prop-ulong value name) -; (check-prop-value value name "fit in an unsigned long" -; (lambda (x) (and (exact-integer? x) -; (<= 0 x (- (expt 2 64) 1)))))) +#;(define (check-prop-ulong value name) + (check-prop-value value name "fit in an unsigned long" + (lambda (x) (and (exact-integer? x) + (int:<= 0 x) + (int:< x (expt 2 64)))))) (define (check-prop-flonum value name) (check-prop-value value name "be a flonum" flo:flonum?)) diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm index 626a91b83..2ce5da720 100644 --- a/src/gtk/gtk-object.scm +++ b/src/gtk/gtk-object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -69,6 +69,15 @@ USA. (set-gtk-object-destroyed?! object #t) (gtk-object-cleanup (gobject-alien object) (gobject-signals object))))))) + +(define-integrable (gtk-object-flags gtkobject) + ;; Returns GTK_OBJECT(obj)->flags. + (let ((alien (gobject-alien (check-gtk-object gtkobject)))) + (C-> alien "GtkObject flags"))) + +(define-integrable (check-gtk-object object) + (if (gtk-object? object) object + (error:wrong-type-argument object "" 'check-gtk-object))) ;;;; GtkAdjustments @@ -134,9 +143,20 @@ USA. (if (not (int:= new-value old-value)) (C-call "gtk_adjustment_value_changed" alien))))) -(define (check-real object) +(define (peek-gtk-adjustment adjustment) + ;; For debugging... + (let ((alien (live-alien-adjustment adjustment))) + (list + (C-> alien "GtkAdjustment lower") + (C-> alien "GtkAdjustment upper") + (C-> alien "GtkAdjustment value") + (C-> alien "GtkAdjustment page_size") + (C-> alien "GtkAdjustment step_increment") + (C-> alien "GtkAdjustment page_increment")))) + +(define-integrable (check-real object) (if (real? object) object - (ferror "The object "object" is not a real number."))) + (error:wrong-type-argument object "real number" 'check-real))) ;;;; GtkWidgets, GtkContainers @@ -147,24 +167,209 @@ USA. (parent define standard initial-value #f)) (define (gtk-widget-has-focus? widget) - (let* ((alien (gobject-alien (check-gtk-widget widget))) - (flags (C-> alien "GtkWidget object flags"))) + (let ((flags (gtk-object-flags widget))) (not (int:zero? (bit-and flags (C-enum "GTK_HAS_FOCUS")))))) (define (gtk-widget-drawable? widget) - (let* ((alien (gobject-alien (check-gtk-widget widget))) - (flags (C-> alien "GtkWidget object flags"))) + (let ((flags (gtk-object-flags widget))) (and (not (int:zero? (bit-and flags (C-enum "GTK_VISIBLE")))) (not (int:zero? (bit-and flags (C-enum "GTK_MAPPED"))))))) -(define (gtk-widget-show-all widget) - (C-call "gtk_widget_show_all" (gobject-alien (check-gtk-widget widget)))) - (define (gtk-widget-grab-focus widget) - (C-call "gtk_widget_grab_focus" (gobject-alien (check-gtk-widget widget)))) + (C-call "gtk_widget_grab_focus" (check-gtk-widget-alien widget))) + +(define (gtk-widget-show-all widget) + (C-call "gtk_widget_show_all" (check-gtk-widget-alien widget))) (define (gtk-widget-error-bell widget) - (C-call "gtk_widget_error_bell" (gobject-alien (check-gtk-widget widget)))) + (C-call "gtk_widget_error_bell" (check-gtk-widget-alien widget))) + +(define (gtk-widget-queue-draw widget) + (C-call "gtk_widget_queue_draw" (check-gtk-widget-alien widget))) + +(define (gtk-widget-get-pango-context widget) + (C-call "gtk_widget_get_pango_context" + (make-alien '|PangoContext|) (gobject-alien widget))) + +(define (gtk-widget-create-pango-layout widget #!optional text) + (let ((t (if (default-object? text) 0 (check-string text))) + (w (check-gtk-widget widget))) + (let ((l (make-pango-layout))) + (C-call "gtk_widget_create_pango_layout" + (gobject-alien l) (gobject-alien w) t) + l))) + +(define (check-string object) + (if (string? object) object + (error:wrong-type-argument object "a string" 'check-string))) + +(define (gtk-widget-set-size-request widget width height) + (C-call "gtk_widget_set_size_request" (gobject-alien widget) width height)) + + +;;;; GtkWidget Font + +(define (gtk-widget-font widget) + (let ((alien (check-gtk-widget-alien widget)) + (desc (make-alien '|PangoFontDescription|))) + (C-> alien "GtkWidget style" desc) + (C-> desc "GtkStyle font_desc" desc) + (pango-font-description-to-string desc))) + +(define (set-gtk-widget-font! widget desc) + (let ((font (->PangoFontDescription desc))) + (modify-rcstyle widget (lambda (rcstyle) + (set-rcstyle-font! rcstyle font))))) + +(define (modify-rcstyle widget modify) + ;; The _get_modifier_style(), modify, _modify_style() process. And + ;; _queue_draw all. + (let ((gtkwidget (gobject-alien widget)) + (rcstyle (make-alien '|GtkRcStyle|))) + (C-call "gtk_widget_get_modifier_style" rcstyle gtkwidget) + (modify rcstyle) + (C-call "gtk_widget_modify_style" gtkwidget rcstyle) ; rcstyle destroyed + (C-call "gtk_widget_queue_draw" gtkwidget))) + +(define (set-rcstyle-font! rcstyle pangofontdescription) + (C->= rcstyle "struct _GtkRcStyle font_desc" pangofontdescription)) + +(define (->PangoFontDescription desc) + (cond ((and (alien? desc) (eq? '|PangoFontDescription| (alien/ctype desc))) + desc) + ((string? desc) + (let ((alien (pango-font-description-from-string desc))) + (if (alien-null? alien) + (error:wrong-type-argument desc "PangoFontDescription string" + '->PangoFontDescription) + alien))) + (else (error:wrong-type-argument desc "PangoFontDescription" + '->PangoFontDescription)))) + + +;;;; GtkWidget Colors + +(define (gtk-widget-fg-color widget) + ;; Returns WIDGET's foreground color as a new vector: #(red green blue). + (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) + (peek-rgb (C-> gtkstyle "GtkStyle fg")))) + +(define (peek-rgb colors) + (let ((color (C-array-loc colors "GdkColor" (C-enum "GTK_STATE_NORMAL")))) + (vector (/ (C-> color "GdkColor red") 65535) + (/ (C-> color "GdkColor green") 65535) + (/ (C-> color "GdkColor blue") 65535)))) + +(define (gtk-widget-bg-color widget) + ;; Returns WIDGET's background color as a new vector: #(red green blue). + (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) + (peek-rgb (C-> gtkstyle "GtkStyle bg")))) + +(define (gtk-widget-text-color widget) + ;; Returns WIDGET's text color as a new vector: #(red green blue). + (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) + (peek-rgb (C-> gtkstyle "GtkStyle text")))) + +(define (gtk-widget-base-color widget) + ;; Returns WIDGET's base color as a new vector: #(red green blue). + (let ((gtkstyle (C-> (check-gtk-widget-alien widget) "GtkWidget style"))) + (peek-rgb (C-> gtkstyle "GtkStyle base")))) + +(define (set-gtk-widget-fg-color! widget color) + ;; Sets WIDGET's foreground color. Queues a complete redraw. + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-fg-color!))) + (modify-rcstyle widget (lambda (rcstyle) + (set-rcstyle-fg-color! rcstyle gdkcolor))) + (free gdkcolor))) + +(define (set-rcstyle-fg-color! rcstyle gdkcolor) + (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") + (C-> rcstyle "struct _GtkRcStyle fg") + (C-> rcstyle "struct _GtkRcStyle color_flags") + (C-enum "GTK_RC_FG"))) + +(define (set-rcstyle-gdkcolor! newcolor index colors flagss newflag) + ;; Hack modifier style GdkColor array and corresponding flags. + (let ((color (C-array-loc! colors "GdkColor" index)) + (flags (C-array-loc! flagss "uint" index))) + (C->= color "GdkColor red" (C-> newcolor "GdkColor red")) + (C->= color "GdkColor green" (C-> newcolor "GdkColor green")) + (C->= color "GdkColor blue" (C-> newcolor "GdkColor blue")) + (C->= flags "GtkRcFlags" (fix:or newflag (C-> flags "GtkRcFlags"))))) + +(define (set-gtk-widget-bg-color! widget color) + ;; Sets WIDGET's background color. Queues a complete redraw. + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-bg-color!))) + (modify-rcstyle widget (lambda (rcstyle) + (set-rcstyle-bg-color! rcstyle gdkcolor))) + (free gdkcolor))) + +(define (set-rcstyle-bg-color! rcstyle gdkcolor) + (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") + (C-> rcstyle "struct _GtkRcStyle bg") + (C-> rcstyle "struct _GtkRcStyle color_flags") + (C-enum "GTK_RC_BG"))) + +(define (set-gtk-widget-text-color! widget color) + ;; Queues a complete redraw. + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-text-color!))) + (modify-rcstyle widget (lambda (rcstyle) + (set-rcstyle-text-color! rcstyle gdkcolor))) + (free gdkcolor))) + +(define (set-rcstyle-text-color! rcstyle gdkcolor) + (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") + (C-> rcstyle "struct _GtkRcStyle text") + (C-> rcstyle "struct _GtkRcStyle color_flags") + (C-enum "GTK_RC_TEXT"))) + +(define (set-gtk-widget-base-color! widget color) + ;; Queues a complete redraw. + (let ((gdkcolor (->gdkcolor color widget 'set-gtk-widget-base-color!))) + (modify-rcstyle widget (lambda (rcstyle) + (set-rcstyle-base-color! rcstyle gdkcolor))) + (free gdkcolor))) + +(define (set-rcstyle-base-color! rcstyle gdkcolor) + (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") + (C-> rcstyle "struct _GtkRcStyle base") + (C-> rcstyle "struct _GtkRcStyle color_flags") + (C-enum "GTK_RC_BASE"))) + +(define (->gdkcolor object widget operator) + (let ((rgb (->rgb object widget operator)) + (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) + (C->= gdkcolor "GdkColor red" (round->exact (* (vector-ref rgb 0) 65535))) + (C->= gdkcolor "GdkColor green" (round->exact(* (vector-ref rgb 1) 65535))) + (C->= gdkcolor "GdkColor blue" (round->exact (* (vector-ref rgb 2) 65535))) + gdkcolor)) + +(define (->rgb object widget operator) + (or (and (string? object) + (gtk-widget-parse-color widget object)) + (and (vector? object) (= 3 (vector-length object)) + object) + (error:wrong-type-argument object "a color name or #(rgb)" operator))) + +(define (gtk-widget-parse-color widget string) + ;; Returns the color named by STRING, or #F. STRING can be a color + ;; name, hex number, or symbolic color name for the WIDGET. + (guarantee-string string 'gtk-widget-parse-color) + (let ((style (C-> (check-gtk-widget-alien widget) "GtkWidget style")) + (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) + (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor)) + (zero? (C-call "gdk_color_parse" string gdkcolor))) + (begin + (free gdkcolor) + #f) + (let ((rgb (vector (/ (C-> gdkcolor "GdkColor red") 65535) + (/ (C-> gdkcolor "GdkColor green") 65535) + (/ (C-> gdkcolor "GdkColor blue") 65535)))) + (free gdkcolor) + rgb)))) + + +;;;; GtkContainers (define-class () @@ -204,13 +409,17 @@ USA. (gobject-alien (check-gtk-container container)) width)) -(define (check-gtk-widget object) +(define-integrable (check-gtk-widget-alien object) + (gobject-alien (check-gtk-widget object))) + +(define-integrable (check-gtk-widget object) (if (gtk-widget? object) object - (ferror object" is not a instance."))) + (error:wrong-type-argument object "" 'check-gtk-widget))) -(define (check-gtk-container object) +(define-integrable (check-gtk-container object) (if (gtk-container? object) object - (ferror object" is not a instance."))) + (error:wrong-type-argument object "" + 'check-gtk-container))) ;;; GtkLabels @@ -296,6 +505,40 @@ USA. (C-call "gtk_scrolled_window_new" alien null-alien null-alien) (if (alien-null? alien) (ferror "Could not create GtkScrolledWindow.")) window)) + +(define (gtk-scrolled-window-set-policy window horizontal vertical) + (let ((w (check-scrolled-window window)) + (h (check-scrollbar-policy horizontal)) + (v (check-scrollbar-policy vertical))) + (C-call "gtk_scrolled_window_set_policy" (gobject-alien w) h v))) + +(define (gtk-scrolled-window-set-placement window placement) + (let ((w (check-scrolled-window window)) + (p (check-scrolled-window-placement placement))) + (C-call "gtk_scrolled_window_set_placement" (gobject-alien w) p))) + +(define-integrable (check-scrolled-window object) + (if (gtk-scrolled-window? object) object + (error:wrong-type-argument object "" + 'check-scrolled-window))) + +(define-integrable (check-scrollbar-policy object) + (case object + ((ALWAYS) (C-enum "GTK_POLICY_ALWAYS")) + ((AUTO) (C-enum "GTK_POLICY_AUTOMATIC")) + ((NEVER) (C-enum "GTK_POLICY_NEVER")) + (else (error:wrong-type-argument object "symbol: ALWAYS, AUTO or NEVER" + 'check-scrollbar-policy)))) + +(define-integrable (check-scrolled-window-placement object) + (case object + ((TOP-LEFT) (C-enum "GTK_CORNER_TOP_LEFT")) + ((BOTTOM-LEFT) (C-enum "GTK_CORNER_BOTTOM_LEFT")) + ((TOP-RIGHT) (C-enum "GTK_CORNER_TOP_RIGHT")) + ((BOTTOM-RIGHT) (C-enum "GTK_CORNER_BOTTOM_RIGHT")) + (else (error:wrong-type-argument + object "symbol: TOP-LEFT, BOTTOM-LEFT, TOP-RIGHT or BOTTOM-RIGHT" + 'check-scrolled-window-placement)))) ;;;; GtkWindows @@ -321,55 +564,54 @@ USA. (C-call "gtk_window_set_default_size" alien -1 -1) window)) -(define (check-window-type type) +(define-integrable (check-window-type type) (case type ((TOPLEVEL POPUP) type) (else - (check-window-type - (ferror "The argument to gtk-window-new must be one of" - " the symbols TOPLEVEL or POPUP (not "type")."))))) + (error:wrong-type-argument type "symbol: TOPLEVEL or POPUP" + 'check-window-type)))) -(define (guarantee-gtk-window object operator) - (if (not (gtk-window? object)) - (error:wrong-type-argument object "" operator))) +(define-integrable (check-gtk-window object) + (if (gtk-window? object) object + (error:wrong-type-argument object "" 'check-gtk-window))) (define (gtk-window-set-title window title) - (guarantee-gtk-window window 'gtk-window-set-title) (guarantee-string title 'gtk-window-set-title) - (C-call "gtk_window_set_title" (gobject-alien window) title)) + (let ((alien (gobject-alien (check-gtk-window window)))) + (C-call "gtk_window_set_title" alien title))) (define (gtk-window-get-default-size window receiver) ;; Calls RECEIVER with WINDOW's default width and height. (let* ((*width (malloc (fix:* 2 (C-sizeof "gint")) 'gint)) (*height (alien-byte-increment *width (C-sizeof "gint") 'gint))) - (C-call "gtk_window_get_default_size" window *width *height) - (let ((width (C-> *width "* gint")) - (height (C-> *height "* gint"))) + (C-call "gtk_window_get_default_size" + (gobject-alien window) *width *height) + (let ((width (C-> *width "gint")) + (height (C-> *height "gint"))) (free *width) (receiver width height)))) (define (gtk-window-set-default-size window width height) - (guarantee-gtk-window window 'gtk-window-set-default-size) (guarantee-integer width 'gtk-window-set-default-size) (guarantee-integer height 'gtk-window-set-default-size) - (C-call "gtk_window_set_default_size" (gobject-alien window) width height)) + (let ((alien (gobject-alien (check-gtk-window window)))) + (C-call "gtk_window_set_default_size" alien width height))) (define (gtk-window-parse-geometry window geometry) - (guarantee-gtk-window window 'gtk-window-parse-geometry) (guarantee-string geometry 'gtk-window-parse-geometry) - (if (fix:zero? (C-call "gtk_window_parse_geometry" - (gobject-alien window) geometry)) - (ferror "Could not parse geometry string: "geometry))) + (let ((alien (gobject-alien (check-gtk-window window)))) + (if (fix:zero? (C-call "gtk_window_parse_geometry" alien geometry)) + (ferror "Could not parse geometry string: "geometry)))) (define (gtk-window-resize window width height) - (guarantee-gtk-window window 'gtk-window-resize) (guarantee-integer width 'gtk-window-resize) (guarantee-integer height 'gtk-window-resize) - (C-call "gtk_window_resize" (gobject-alien window) width height)) + (let ((alien (gobject-alien (check-gtk-window window)))) + (C-call "gtk_window_resize" alien width height))) (define (gtk-window-present window) - (guarantee-gtk-window window 'gtk-window-present) - (C-call "gtk_window_present" (gobject-alien window))) + (let ((alien (gobject-alien (check-gtk-window window)))) + (C-call "gtk_window_present" alien))) (define trace? #f) diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl index 377c6eef6..2c2cef703 100644 --- a/src/gtk/gtk.cdecl +++ b/src/gtk/gtk.cdecl @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -150,4 +150,15 @@ USA. (extern (* GtkWidget) ;gtk+-2.8.20/gtk/gtkscrolledwindow.h gtk_scrolled_window_new (hadjustment (* GtkAdjustment)) - (vadjustment (* GtkAdjustment))) \ No newline at end of file + (vadjustment (* GtkAdjustment))) + +(extern void + gtk_scrolled_window_set_policy + (scrolled_window (* GtkScrolledWindow)) + (hscrollbar_policy GtkPolicyType) + (vscrollbar_policy GtkPolicyType)) + +(extern void + gtk_scrolled_window_set_placement + (scrolled_window (* GtkScrolledWindow)) + (window_placement GtkCornerType)) \ No newline at end of file diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 3dd3caf13..333a604c6 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -1,6 +1,27 @@ #| -*-Scheme-*- -Gtk System Packaging |# +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Gtk System Packaging (global-definitions "../runtime/runtime") (global-definitions "../ffi/ffi") @@ -16,7 +37,8 @@ Gtk System Packaging |# (export (gtk) gobject-alien gobject-unref gobject-finalized? - g-signal-connect g-signal-disconnect add-gc-cleanup + g-signal-connect g-signal-disconnect + add-gc-cleanup punt-gc-cleanup gobject-get-property gobject-set-properties gquark-from-string gquark-to-string make-pixbuf-loader load-pixbuf-from-file @@ -34,9 +56,22 @@ Gtk System Packaging |# gtk-object-destroyed? gtk-object-destroy make-gtk-adjustment set-gtk-adjustment! gtk-widget? gtk-widget-parent - gtk-widget-has-focus? gtk-widget-drawable? gtk-widget-show-all + gtk-widget-drawable? gtk-widget-has-focus? gtk-widget-grab-focus + gtk-widget-show-all gtk-widget-error-bell + gtk-widget-queue-draw + gtk-widget-get-pango-context + gtk-widget-create-pango-layout + gtk-widget-set-size-request + + gtk-widget-font set-gtk-widget-font! + gtk-widget-fg-color gtk-widget-bg-color + gtk-widget-text-color gtk-widget-base-color + set-gtk-widget-fg-color! set-gtk-widget-bg-color! + set-gtk-widget-text-color! set-gtk-widget-base-color! + gtk-widget-parse-color + gtk-container? gtk-container-children gtk-container-add gtk-container-set-border-width @@ -51,11 +86,9 @@ Gtk System Packaging |# gtk-label-get-text gtk-label-set-text gtk-vbox-new gtk-box-pack-start gtk-box-pack-end gtk-scrolled-window-new - pango-rectangle pangos->pixels pixels->pangos - pango-font-families pango-context-list-families - pango-font-family-get-name pango-font-family-is-monospace? - pango-font-family-faces pango-font-face-get-name) - (import (gtk gobject) gobject-cleanup gobject-signals)) + gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement) + (import (gtk gobject) gobject-cleanup gobject-signals) + (import (gtk pango) make-pango-layout check-PangoFontDescription)) (define-package (gtk widget) (parent (gtk)) @@ -65,7 +98,8 @@ Gtk System Packaging |# set-scm-widget-destroy! set-scm-widget-realize! set-scm-widget-unrealize! set-scm-widget-size-request! set-scm-widget-size-allocate! - set-scm-widget-event! set-scm-widget-set-scroll-adjustments!)) + set-scm-widget-event! + set-scm-widget-set-scroll-adjustments!)) (define-package (gtk layout) (parent (gtk)) @@ -76,17 +110,15 @@ Gtk System Packaging |# scm-layout-geometry set-scm-layout-size! scm-layout-drawing set-scm-layout-drawing! scm-layout-on-screen-area set-scm-layout-scroll-pos! + scm-layout-scroll-step set-scm-layout-scroll-step! - scm-layout-fg-color scm-layout-bg-color - scm-layout-text-color scm-layout-base-color - set-scm-layout-fg-color! set-scm-layout-bg-color! - set-scm-layout-text-color! set-scm-layout-base-color! - scm-layout-parse-color - - make-drawing set-drawing-size! drawing-pick-list + make-drawing drawing-widgets + set-drawing-size! drawing-pick-list - drawn-item-area set-drawn-item-position! + + drawn-item-drawing drawn-item-area set-drawn-item-position! drawn-item-widgets set-drawn-item-widgets! + drawn-item-remove! add-box-item set-box-item-size! set-box-item-pos-size! set-box-item-shadow! @@ -100,6 +132,31 @@ Gtk System Packaging |# add-image-item-from-file)) +(define-package (gtk pango) + (parent (gtk)) + (files "pango") + (export (gtk) + + pango-layout-get-context + pango-layout-get-font-description + pango-layout-set-text + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-font-description-from-string + pango-font-description-to-string + pango-font-description-free + pango-context-get-font-description + pango-context-set-font-description + pango-context-get-metrics + pango-context-spacing + pango-font-metrics-get-ascent + pango-font-metrics-get-descent + pango-font-metrics-get-approximate-char-width + pango-font-metrics-unref + pango-rectangle + pangos->pixels + pixels->pangos)) + (define-package (gtk thread) (parent (runtime thread)) (files "thread") @@ -118,6 +175,8 @@ Gtk System Packaging |# *unused-command-line* hook/process-command-line default/process-command-line) + (import (runtime) + ucode-primitive) (export (gtk) gtk-time-slice-window? gtk-time-slice-window! @@ -135,6 +194,6 @@ Gtk System Packaging |# (parent (gtk)) (files "demo") (import (gtk layout) - scm-layout-event) + scm-layout-event-handler) (export () scm-layout-demo)) \ No newline at end of file diff --git a/src/gtk/gtk.scm b/src/gtk/gtk.scm index e79745e7b..fb8a8a688 100644 --- a/src/gtk/gtk.scm +++ b/src/gtk/gtk.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -152,10 +152,10 @@ USA. (lambda (window-x-start window-x-end window-y-start window-y-end) (call-with-rect-bounds item (lambda (item-x-start item-x-end item-y-start item-y-end) - (cond ((< window-x-end item-x-start) #f) - ((< window-y-end item-y-start) #f) - ((< item-x-end window-x-start) #f) - ((< item-y-end window-y-start) #f) + (cond ((int:< window-x-end item-x-start) #f) + ((int:< window-y-end item-y-start) #f) + ((int:< item-x-end window-x-start) #f) + ((int:< item-y-end window-y-start) #f) (else (let ((x (int:max window-x-start item-x-start)) (y (int:max window-y-start item-y-start)) @@ -166,6 +166,18 @@ USA. (int:- x-end x) (int:- y-end y)))))))))) +(define (rect-union! rect1 rect2) + (call-with-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (call-with-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (let ((x (int:min min-x1 min-x2)) + (y (int:min min-y1 min-y2))) + (set-rect! rect1 + x y + (int:- x (int:max max-x1 max-x2)) + (int:- y (int:max max-y1 max-y2))))))))) + (define (gdk-rectangle #!optional x y width height) (let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|))) (if (default-object? x) alien @@ -245,30 +257,12 @@ USA. (with-simple-restart 'MUFFLE-WARNING "Ignore warning." (lambda () (signal args)))))) - -;;;; Pango - -(define (pango-rectangle #!optional x y width height) - (if (default-object? x) - (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|) - (let ((rect (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|))) - (C->= rect "PangoRectangle x" x) - (C->= rect "PangoRectangle y" y) - (C->= rect "PangoRectangle width" width) - (C->= rect "PangoRectangle height" height) - rect))) - -(define-integrable (pangos->pixels pango-units) - (quotient (int:+ pango-units 512) 1024)) - -(define-integrable (pixels->pangos pixel-units) - (* pixel-units 1024)) +;;; Pango +;;; +;;; Debugging hacks. No gc-cleanups! (define (pango-font-families widget) - (let ((PangoContext (make-alien '|PangoContext|))) - (C-call "gtk_widget_get_pango_context" PangoContext - (gobject-alien widget)) - (pango-context-list-families PangoContext))) + (pango-context-list-families (gtk-widget-get-pango-context widget))) (define (pango-context-list-families PangoContext) (let ((data-arg (malloc (C-sizeof "*") '(* (* |PangoFontFamily|)))) diff --git a/src/gtk/gtk.sf b/src/gtk/gtk.sf index 124024416..e38a2ddee 100644 --- a/src/gtk/gtk.sf +++ b/src/gtk/gtk.sf @@ -1,22 +1,71 @@ #| -*-Scheme-*- -Syntax the GTK system. |# +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz -(load-option 'CREF) -(load-option 'SOS) -(load-option 'FFI) +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. + +|# + +;;;; Syntax the GTK system + +(fluid-let ((load/suppress-loading-message? #t)) + (load-option 'CREF) + (load-option 'SOS) + (load-option 'FFI)) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () - (let ((gtk-files '("gtk" "main" "gobject" "gtk-object" - "scm-widget" "scm-layout" - "gtk-ev" "demo")) - (sf+ - (lambda (files env deps) - (fluid-let ((sf/default-declarations - (cons '(usual-integrations) - sf/default-declarations))) - (sf-with-dependencies files deps (->environment env)))))) + (let* ((files.packages + '(("gtk" . (gtk)) + ("main" . (gtk main)) + ("gobject" . (gtk gobject)) + ("gtk-object" . (gtk gtk-object)) + ("pango" . (gtk pango)) + ("scm-widget" . (gtk widget)) + ("scm-layout" . (gtk layout)) + ("thread" . (gtk thread)) + ("gtk-ev" . (gtk event-viewer)) + ("demo" . (gtk demo)))) + (sf+ + (lambda (files deps) + (let loop ((files (if (pair? files) files (list files)))) + (if (pair? files) + (let* ((file (car files)) + (file.package (assoc file files.packages)) + (package (if (pair? file.package) + (cdr file.package) + (error "No package: " file))) + (env (->environment package))) + (fluid-let ((sf/default-declarations + (cons '(usual-integrations) + sf/default-declarations))) + (sf-with-dependencies file deps env)) + (loop (cdr files))))))) + (sfx+ + (lambda (files deps) + (fluid-let ((sf/default-declarations + (append! + (map (lambda (file) + `(integrate-external + ,(pathname-new-type file #f))) + deps) + sf/default-declarations))) + (sf+ files deps))))) ;; Build an empty package for use at syntax-time. ;; The C-include syntax will bind C-INCLUDES here. @@ -29,8 +78,18 @@ Syntax the GTK system. |# ;; Load the gtkio primitives too. (load-library-object-file "prgtkio" #t) - (sf+ gtk-files '(gtk) '("gtk-const")) - (sf+ "thread" '(gtk thread) '()) + ;; These core files depend only on the constants behind the C- + ;; syntax. + (sf+ '("gtk" "main" "gobject" "gtk-object" "pango" "scm-widget") + '("gtk-const")) + + ;; These files will want the latest rect(angle) and + ;; pango/pixel procedures for inlining. + (sfx+ '("scm-layout" "thread" "gtk-ev" "demo") + '("gtk" "pango")) + + ;; Depends only on (runtime thread). + (sf+ '("thread") '()) ;; Cross-check. (cref/generate-constructors "gtk" 'ALL)))) \ No newline at end of file diff --git a/src/gtk/hello.scm b/src/gtk/hello.scm index 88c96cb9e..e888dc7b7 100644 --- a/src/gtk/hello.scm +++ b/src/gtk/hello.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -This is Havoc Pennington's Hello World example from GGAD, nicely wrapped. |# +This is Havoc Pennington's Hello World example from GGAD, wrapped in Scheme. |# (declare (usual-integrations)) @@ -17,16 +17,14 @@ This is Havoc Pennington's Hello World example from GGAD, nicely wrapped. |# (let ((counter 0)) (g-signal-connect window (C-callback "delete_event") (lambda (w e) - (outf-console ";Delete me "(- 2 counter)" times.\n") + w e ;ignore + (outf-console ";Bite me "(- 2 counter)" times.\n") (set! counter (1+ counter)) ;; Three or more is the charm. (if (> counter 2) 0 1))) (g-signal-connect button (C-callback "clicked") (lambda (w) - (if (= counter 1) - (begin - (outf-console "\n;Erroring in "(current-thread)"...\n") - (error "Testing error handling."))) + w ;ignore (let ((text (gtk-label-get-text label))) (gtk-label-set-text label (list->string (reverse! (string->list text))))) diff --git a/src/gtk/main.scm b/src/gtk/main.scm index 4d28c66e7..59d589815 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2008, 2009 Matthew Birkholz +Copyright (C) 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -27,12 +27,6 @@ USA. (c-include "gtk") -(define-syntax ucode-primitive - (sc-macro-transformer - (lambda (form environment) - environment - (apply make-primitive-procedure (cdr form))))) - (define (initialize-package!) (let ((program-name ((ucode-primitive scheme-program-name 0)))) (let ((processor hook/process-command-line)) diff --git a/src/gtk/pango.scm b/src/gtk/pango.scm new file mode 100644 index 000000000..9537b0428 --- /dev/null +++ b/src/gtk/pango.scm @@ -0,0 +1,226 @@ +#| -*-Scheme-*- + +Copyright (C) 2009, 2010 Matthew Birkholz + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Pango interface. +;;; package: (gtk pango) + + +(c-include "gtk") + +;;; PangoLayout + +(define-class ( (constructor ())) + ()) + +(define-method initialize-instance ((pango-layout )) + (call-next-method pango-layout) + (set-alien/ctype! (gobject-alien pango-layout) '|PangoLayout|)) + +(define (pango-layout-get-context layout) + (C-call "pango_layout_get_context" + (make-alien '|PangoContext|) + (gobject-alien layout))) + +(define (pango-layout-get-font-description layout) + (C-call "pango_layout_get_font_description" + (make-alien '|PangoFontDescription|) + (gobject-alien layout))) + +(define (pango-layout-set-text layout text) + (let ((l (check-pango-layout layout)) + (s (check-string text))) + (C-call "pango_layout_set_text" (gobject-alien l) s (string-length s)))) + +(define (pango-layout-get-pixel-extents layout receiver) + ;; Calls RECEIVER with the logical(?) dimensions (width and height) + ;; of the laid-out text. + + (let ((log-extent (pango-rectangle)) + (ink-extent null-alien)) + (C-call "pango_layout_get_pixel_extents" + (gobject-alien layout) ink-extent log-extent) + (let ((width (C-> log-extent "GdkRectangle width")) + (height (C-> log-extent "GdkRectangle height"))) + (free log-extent) + (receiver width height)))) + +(define (pango-layout-index-to-pos layout index receiver) + ;; Calls RECEIVER with the x, y, width and height of the grapheme at + ;; INDEX in LAYOUT. + (let ((rect (pango-rectangle))) + (C-call "pango_layout_index_to_pos" (gobject-alien layout) index rect) + (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) + (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)))) + +(define-integrable (check-pango-layout object) + (if (pango-layout? object) + object + (error:wrong-type-argument object "" 'check-pango-layout))) + +;;; PangoFontDescription + +(define (pango-font-description-from-string string) + (let ((str (check-string string))) + (let ((font (make-alien '|PangoFontDescription|)) + (copy (make-alien '|PangoFontDescription|))) + (add-gc-cleanup font (pango-font-description-cleanup copy)) + (C-call "pango_font_description_from_string" copy str) + (copy-alien-address! font copy) + font))) + +(define (pango-font-description-cleanup alien) + (lambda () + ;;without-interrupts + (if (not (alien-null? alien)) + (begin + (C-call "pango_font_description_free" alien) + (alien-null! alien))))) + +(define (pango-font-description-free font) + (let ((alien (check-PangoFontDescription font))) + (without-interrupts + (lambda () + (if (not (alien-null? alien)) + (let ((cleanup (punt-gc-cleanup alien))) + (if cleanup (cleanup)) + (alien-null! alien))))))) + +(define (pango-font-description-to-string PangoFontDescription) + (let ((font (check-PangoFontDescription PangoFontDescription))) + (if (alien-null? font) + "" + (let ((cstr (make-alien '|char|))) + (C-call "pango_font_description_to_string" cstr font) + (let ((str (c-peek-cstring cstr))) + (C-call "g_free" cstr) + str))))) + +(define (check-PangoFontDescription object) + (if (and (alien? object) (eq? '|PangoFontDescription| (alien/ctype object))) + object + (check-PangoFontDescription + (error:wrong-type-argument + object "PangoFontDescription's (alien) address" + 'check-PangoFontDescription)))) + +(define (check-string object) + (if (string? object) object + (error:wrong-type-argument object "a string" 'check-string))) + +;;; PangoContext + +(define (pango-context-get-font-description context) + ;; Owned by the PangoContext, not Scheme. + (C-call "pango_context_get_font_description" + (make-alien '|PangoFontDescription|) + (check-PangoContext context))) + +(define (pango-context-set-font-description context font) + (C-call "pango_context_set_font_description" + (check-PangoContext context) + (check-PangoFontDescription font))) + +(define (pango-context-get-metrics context font) + ;; Owned by Scheme. + (let ((context (check-PangoContext context)) + (font (check-PangoFontDescription font))) + (let ((alien (make-alien '|PangoFontMetrics|)) + (copy (make-alien '|PangoFontMetrics|))) + (add-gc-cleanup alien (pango-font-metrics-cleanup copy)) + (C-call "pango_context_get_metrics" copy context font 0) + (copy-alien-address! alien copy) + alien))) + +(define (pango-context-spacing context) + (let ((layout (make-alien '|PangoLayout|))) + (C-call "pango_layout_new" layout (check-PangoContext context)) + (let ((spacing (C-call "pango_layout_get_spacing" layout))) + (C-call "g_object_unref" layout) + spacing))) + +(define (check-PangoContext object) + (if (and (alien? object) (eq? '|PangoContext| (alien/ctype object))) + object + (check-PangoContext + (error:wrong-type-argument + object "the (alien) address of a PangoContext" + 'check-PangoContext)))) + +;;; PangoFontMetrics + +(define (pango-font-metrics-cleanup alien) + (lambda () + ;;without-interrupts + (if (not (alien-null? alien)) + (begin + (C-call "pango_font_metrics_unref" alien) + (alien-null! alien))))) + +(define (pango-font-metrics-unref metrics) + (let ((alien (check-PangoFontMetrics metrics))) + (without-interrupts + (lambda () + (if (not (alien-null? alien)) + (let ((cleanup (punt-gc-cleanup alien))) + (if cleanup (cleanup)) + (alien-null! alien))))))) + +(define (pango-font-metrics-get-ascent metrics) + (C-call "pango_font_metrics_get_ascent" (check-PangoFontMetrics metrics))) + +(define (pango-font-metrics-get-descent metrics) + (C-call "pango_font_metrics_get_descent" (check-PangoFontMetrics metrics))) + +(define (pango-font-metrics-get-approximate-char-width metrics) + (C-call "pango_font_metrics_get_approximate_char_width" + (check-PangoFontMetrics metrics))) + +(define (check-PangoFontMetrics object) + (if (and (alien? object) (eq? '|PangoFontMetrics| (alien/ctype object))) + object + (check-PangoFontMetrics + (error:wrong-type-argument + object "the (alien) address of PangoFontMetrics" + 'check-PangoFontMetrics)))) + +;;; PangoRectangle + +(define (pango-rectangle #!optional x y width height) + (if (default-object? x) + (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|) + (let ((rect (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|))) + (C->= rect "PangoRectangle x" x) + (C->= rect "PangoRectangle y" y) + (C->= rect "PangoRectangle width" width) + (C->= rect "PangoRectangle height" height) + rect))) + +(define-integrable (pangos->pixels pango-units) + (quotient (int:+ pango-units 512) 1024)) + +(define-integrable (pixels->pangos pixel-units) + (* pixel-units 1024)) \ No newline at end of file diff --git a/src/gtk/scm-layout.scm b/src/gtk/scm-layout.scm index ed92158d0..175492d31 100644 --- a/src/gtk/scm-layout.scm +++ b/src/gtk/scm-layout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -30,30 +30,28 @@ USA. (define-class ( (constructor make-scm-layout ())) () - ;; Our window, a GdkWindow alien, and its geometry (allocation). - ;; Until realized, these are a NULL alien and #f. If realized, they - ;; are a non-NULL alien and a rectangular area in device coordinates - ;; (e.g. size in pixels, offset within parent window [ancestor - ;; widget]). - + ;; Our window, a GdkWindow alien. Until realized, this will be NULL. (window define accessor initializer (lambda () (make-alien '|GdkWindow|))) + + ;; Our window geometry (allocation) -- a rectangular area in device + ;; coordinates (e.g. size in pixels, offset within parent window + ;; [ancestor widget]). (geometry define accessor initializer make-rect) ;; Scrollbar widgets. (vadjustment define standard initial-value #f) (hadjustment define standard initial-value #f) + (scroll-step define accessor initializer (lambda () (cons 10 20))) ;; Scrollable area (drawing size), in logical device coords. - ;; The rectangle contains integers (or #f if uninitialized). (scrollable-area define accessor initializer (lambda () (make-rect 0 0 100 100))) ;; Scroll offset and window size (on-screen area). - ;; The rectangle contains integers (or #f if uninitialized). ;; The width and height should match the window geometry. (on-screen-area define accessor - initializer (lambda () (make-rect 0 0 100 100))) + initializer (lambda () (make-rect 0 0))) ;; The drawing. (drawing define standard @@ -61,8 +59,8 @@ USA. initial-value #f)) (define (scm-layout-new width height) - (let ((w (check-non-negative-fixnum width)) - (h (check-non-negative-fixnum height)) + (let ((w (check-non-negative-integer width)) + (h (check-non-negative-integer height)) (layout (make-scm-layout))) (let ((alien (gobject-alien layout))) (C->= alien "GtkWidget requisition width" w) @@ -70,15 +68,18 @@ USA. (set-scm-widget-size-request! layout (scm-layout-size-request layout)) (set-scm-widget-size-allocate! layout (scm-layout-size-allocate layout)) (set-scm-widget-realize! layout (scm-layout-realize layout)) - (set-scm-widget-event! layout (scm-layout-event layout)) + (set-scm-widget-event! layout (scm-layout-event-handler layout)) (set-scm-widget-set-scroll-adjustments! layout (scm-layout-set-scroll-adjustments layout)) layout)) +(define-integrable (scm-layout-realized? layout) + (not (alien-null? (scm-layout-window layout)))) + (define (set-scm-layout-size! widget width height) ;; Tells WIDGET to (re)request the given WIDTH and HEIGHT in pixels. - (let ((w (check-non-negative-fixnum width)) - (h (check-non-negative-fixnum height)) + (let ((w (check-non-negative-integer width)) + (h (check-non-negative-integer height)) (alien (check-scm-layout-alien widget))) (let ((rw (C-> alien "GtkWidget requisition width")) (rh (C-> alien "GtkWidget requisition height"))) @@ -88,38 +89,66 @@ USA. (C->= alien "GtkWidget requisition width" w)) (if (not (fix:= h rh)) (C->= alien "GtkWidget requisition height" h)) - (if (not (alien-null? (scm-layout-window widget))) ;;realized + (if (scm-layout-realized? widget) (C-call "gtk_widget_queue_resize" alien))))))) (define (set-scm-layout-scroll-size! widget width height) ;; Tells WIDGET to adjust its scrollable area. Notifies any ;; scrollbars. - (set-rect-size! (scm-layout-scrollable-area widget) width height) - (adjust-adjustments widget)) + (let ((w (check-positive-integer width)) + (h (check-positive-integer height)) + (area (scm-layout-scrollable-area widget))) + (if (not (and (int:= w (rect-width area)) + (int:= h (rect-height area)))) + (begin + (set-rect-size! area w h) + (if (scm-layout-realized? widget) + (adjust-adjustments widget)))))) (define (set-scm-layout-scroll-pos! widget x y) - (let ((xI (check-non-negative-integer x)) - (yI (check-non-negative-integer y)) - (window-area (scm-layout-on-screen-area widget)) - (alien-window (scm-layout-window widget))) - (let ((xW (rect-x window-area)) (yW (rect-y window-area))) - (set-rect-pos! window-area xI yI) - (adjust-adjustments widget) - - (if (not (alien-null? alien-window)) - (let ((dx (int:- xI xW)) (dy (int:- yI yW))) - (if (not (or (int:zero? dx) (int:zero? dy))) - ;; If more than 25% will remain onscreen, scroll; else jump. - (let ((width (rect-width window-area)) - (height (rect-height window-area))) - (if (< 0.25 (/ (* dx dy) (* width height))) - ;; Scroll. - (C-call "gdk_window_scroll" alien-window - (int:* -1 dx) (int:* -1 dy)) - ;; Jump. - (C-call "gtk_widget_queue_draw_area" - (gobject-alien widget) 0 0 width height)) - (C-call "gdk_window_process_updates" alien-window 0)))))))) + (let ((x1 (check-integer x)) + (y1 (check-integer y))) + (scroll widget x1 y1))) + +(define (scroll widget new-x new-y) + ;; Scroll if more than 25% will remain in the window, else jump. + (if (scm-layout-realized? widget) + (let ((scroll (scm-layout-on-screen-area widget))) + (let ((old-x (rect-x scroll)) + (old-y (rect-y scroll))) + (let ((dx (int:- new-x old-x)) + (dy (int:- new-y old-y))) + (if (not (and (int:zero? dx) (int:zero? dy))) + (let ((width (rect-width scroll)) + (height (rect-height scroll)) + (gdkwindow (scm-layout-window widget))) + (let ((remaining-width (int:- width (int:abs dy))) + (remaining-height (int:- height (int:abs dx)))) + (if (or (int:negative? remaining-width) + (int:negative? remaining-height) + (< 0.25 (/ (int:* remaining-width remaining-height) + (int:* width height)))) + (C-call "gdk_window_scroll" + gdkwindow (int:negate dx) (int:negate dy)) + (C-call "gtk_widget_queue_draw" + (gobject-alien widget))) + (set-rect-pos! scroll new-x new-y) + (adjust-adjustments widget)) + (C-call "gdk_window_process_updates" gdkwindow 0)))))))) + +(define-integrable (int:abs i) + (if (int:negative? i) (int:negate i) i)) + +(define (set-scm-layout-scroll-step! widget width height) + ;; Tells WIDGET to use WIDTH/HEIGHT as its "step-increment" when + ;; setting up h/vscrollbars. + (let ((w (check-positive-integer width)) + (h (check-positive-integer height))) + (let ((width.height (scm-layout-scroll-step widget))) + (set-car! width.height w) + (set-cdr! width.height h))) + (if (scm-layout-realized? widget) + (adjust-adjustments widget))) (define (set-scm-layout-drawing! widget drawing) (let ((old (scm-layout-drawing widget)) @@ -129,171 +158,37 @@ USA. (%set-scm-layout-drawing! widget new) (drawing-add-widget! new widget) (let ((a (drawing-area new))) - (set-scm-layout-scroll-size! widget (rect-width a) (rect-height a))) - (if (not (alien-null? (scm-layout-window widget))) ;;realized - (let ((geo (scm-layout-geometry widget))) - (C-call "gtk_widget_queue_draw_area" alien - 0 0 (rect-width geo) (rect-height geo)))))) + (set-rect! (scm-layout-scrollable-area widget) + (rect-x a) (rect-y a) (rect-width a) (rect-height a)) + (if (scm-layout-realized? widget) + (begin + (adjust-adjustments widget) + (C-call "gtk_widget_queue_draw" alien)))))) (define-integrable (check-scm-layout-alien obj) (if (scm-layout? obj) (gobject-alien obj) - (ferror "Not a instance: "obj))) - - -;;;; Colors - -(define (scm-layout-fg-color layout) - ;; Returns LAYOUT's foreground color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle fg")))) - -(define (peek-rgb colors) - (let ((color (C-array-loc colors "GdkColor" (C-enum "GTK_STATE_NORMAL")))) - (vector (/ (C-> color "GdkColor red") 65535) - (/ (C-> color "GdkColor green") 65535) - (/ (C-> color "GdkColor blue") 65535)))) - -(define (scm-layout-bg-color layout) - ;; Returns LAYOUT's background color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle bg")))) - -(define (scm-layout-text-color layout) - ;; Returns LAYOUT's text color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle text")))) - -(define (scm-layout-base-color layout) - ;; Returns LAYOUT's base color as a new vector: #(red green blue). - (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style"))) - (peek-rgb (C-> gtkstyle "GtkStyle base")))) - -(define (set-scm-layout-fg-color! layout color) - ;; Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-fg-color!))) - (set-gdkcolor! layout gdkcolor set-rcstyle-fg-color!) - (free gdkcolor))) - -(define (set-gdkcolor! layout gdkcolor applicator) - (let ((scmwidget (gobject-alien layout)) - (rcstyle (make-alien '|GtkRcStyle|))) - (C-call "gtk_widget_get_modifier_style" rcstyle scmwidget) - (applicator rcstyle gdkcolor) - (C-call "gtk_widget_modify_style" scmwidget rcstyle) ; rcstyle destroyed - (if (not (alien-null? (scm-layout-window layout))) ;realized - (let ((geo (scm-layout-geometry layout))) - (C-call "gtk_widget_queue_draw_area" scmwidget - 0 0 (rect-width geo) (rect-height geo)))))) - -(define (set-rcstyle-fg-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle fg") - (C-> rcstyle "struct _GtkRcStyle color_flags") - (C-enum "GTK_RC_FG"))) - -(define (set-rcstyle-gdkcolor! newcolor index colors flagss newflag) - (let ((color (C-array-loc! colors "GdkColor" index)) - (flags (C-array-loc! flagss "uint" index))) - (C->= color "GdkColor red" (C-> newcolor "GdkColor red")) - (C->= color "GdkColor green" (C-> newcolor "GdkColor green")) - (C->= color "GdkColor blue" (C-> newcolor "GdkColor blue")) - (C->= flags "GtkRcFlags" (fix:or newflag (C-> flags "GtkRcFlags"))))) - -(define (set-scm-layout-bg-color! layout color) - ;; Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-bg-color!))) - (set-gdkcolor! layout gdkcolor set-rcstyle-bg-color!) - (free gdkcolor)) - (let ((gdkwindow (scm-layout-window layout))) - (if (not (alien-null? gdkwindow)) ;realized - (let* ((scmwidget (gobject-alien layout)) - (style (C-> scmwidget "GtkWidget style"))) - (C-call "gtk_style_set_background" style gdkwindow - (C-enum "GTK_STATE_NORMAL")))))) - -(define (set-rcstyle-bg-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle bg") - (C-> rcstyle "struct _GtkRcStyle color_flags") - (C-enum "GTK_RC_BG"))) - -(define (set-scm-layout-text-color! layout color) - ;; Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-text-color!))) - (set-gdkcolor! layout gdkcolor set-rcstyle-text-color!) - (free gdkcolor))) - -(define (set-rcstyle-text-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle text") - (C-> rcstyle "struct _GtkRcStyle color_flags") - (C-enum "GTK_RC_TEXT"))) - -(define (set-scm-layout-base-color! layout color) - ;; Queues a complete redraw. - (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-base-color!))) - (set-gdkcolor! layout gdkcolor set-rcstyle-base-color!) - (free gdkcolor))) - -(define (set-rcstyle-base-color! rcstyle gdkcolor) - (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL") - (C-> rcstyle "struct _GtkRcStyle base") - (C-> rcstyle "struct _GtkRcStyle color_flags") - (C-enum "GTK_RC_BASE"))) - -(define (->gdkcolor object layout operator) - (let ((rgb (->rgb object layout operator)) - (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) - (C->= gdkcolor "GdkColor red" (round (* (vector-ref rgb 0) 65535))) - (C->= gdkcolor "GdkColor green" (round (* (vector-ref rgb 1) 65535))) - (C->= gdkcolor "GdkColor blue" (round (* (vector-ref rgb 2) 65535))) - gdkcolor)) - -(define (->rgb object layout operator) - (or (and (string? object) - (scm-layout-parse-color layout object)) - (and (vector? object) (= 3 (vector-length object)) - object) - (error:wrong-type-argument object "a color name or #(rgb)" operator))) - -(define (scm-layout-parse-color layout string) - ;; Returns the color named by STRING, or #F. STRING can be a color - ;; name, hex number, or symbolic color name for the LAYOUT widget. - (guarantee-string string 'scm-layout-parse-color) - (let ((scmwidget (gobject-alien layout))) - (let ((style (C-> scmwidget "GtkWidget style")) - (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|))) - (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor)) - (zero? (C-call "gdk_color_parse" string gdkcolor))) - (begin - (free gdkcolor) - #f) - (let ((rgb (vector (/ (C-> gdkcolor "GdkColor red") 65535) - (/ (C-> gdkcolor "GdkColor green") 65535) - (/ (C-> gdkcolor "GdkColor blue") 65535)))) - (free gdkcolor) - rgb))))) + (error:wrong-type-argument obj "" 'check-scm-layout-alien))) ;;;; Callback handlers. (define (scm-layout-size-request widget) (named-lambda (scm-layout::size-request GtkWidget GtkRequisition) - (trace ";((scm-layout-size-request "widget") "GtkWidget - " "GtkRequisition")\n") + (trace2 ";((scm-layout-size-request "widget") "GtkWidget + " "GtkRequisition")\n") (let ((alien (gobject-alien widget))) (let ((width (C-> alien "GtkWidget requisition width")) (height(C-> alien "GtkWidget requisition height"))) (C->= GtkRequisition "GtkRequisition width" width) (C->= GtkRequisition "GtkRequisition height" height) - (trace "; Requisition: "widget"x"height" from "widget"\n") + (trace "; Requisition: "width"x"height" from "widget"\n") )))) (define (scm-layout-size-allocate widget) (named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation) - (trace ";((scm-layout-size-allocate "widget") "GtkWidget - " "GtkAllocation")\n") + (trace2 ";((scm-layout-size-allocate "widget") "GtkWidget + " "GtkAllocation")\n") (let ((x (C-> GtkAllocation "GtkAllocation x")) (y (C-> GtkAllocation "GtkAllocation y")) @@ -308,21 +203,20 @@ USA. (C->= GtkWidget "GtkWidget allocation y" y) (C->= GtkWidget "GtkWidget allocation width" width) (C->= GtkWidget "GtkWidget allocation height" height) - (let ((window (scm-layout-window widget))) - (if (not (alien-null? window)) ;;realized - (begin - (C-call "gdk_window_move_resize" window x y width height) - (adjust-adjustments widget))))))) + (if (scm-layout-realized? widget) + (begin + (C-call "gdk_window_move_resize" (scm-layout-window widget) + x y width height) + (adjust-adjustments widget)))))) (define (scm-layout-realize widget) (named-lambda (scm-layout::realize GtkWidget) - (trace ";((scm-layout-realize "widget") "GtkWidget")\n") + (trace2 ";((scm-layout-realize "widget") "GtkWidget")\n") ;; ScmWidget automatically sets GTK_REALIZED. (let ((attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) (main-GdkWindow (scm-layout-window widget)) - (GtkStyle (C-> GtkWidget "GtkWidget style")) (parent-GdkWindow (make-alien '|GdkWindow|)) ; (GdkVisual (make-alien '|GdkVisual|)) ; (GdkColormap (make-alien '|GdkColormap|)) @@ -340,7 +234,6 @@ USA. (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) (let ((r (scm-layout-geometry widget))) - ;; Just assume geometry has been allocated?! (C->= attr "GdkWindowAttr x" (rect-x r)) (C->= attr "GdkWindowAttr y" (rect-y r)) (C->= attr "GdkWindowAttr width" (rect-width r)) @@ -364,20 +257,24 @@ USA. ;; Style - (C-call "gtk_style_attach" GtkStyle - (C-> GtkWidget "GtkWidget style" GtkStyle) main-GdkWindow) - (C->= GtkWidget "GtkWidget style" GtkStyle) - (C-call "gtk_style_set_background" - GtkStyle main-GdkWindow (C-enum "GTK_STATE_NORMAL")) + (let ((GtkStyle (C-> GtkWidget "GtkWidget style"))) + (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow) + (C->= GtkWidget "GtkWidget style" GtkStyle) + (C-call "gdk_window_set_background" + main-GdkWindow + (C-array-loc (C-> GtkStyle "GtkStyle base" ) + "GdkColor" (C-enum "GTK_STATE_NORMAL")))) + + (adjust-adjustments widget) unspecific))) -(define (scm-layout-event widget) - (named-lambda (scm-layout::event GtkWidget GdkEvent) - (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n") +(define (scm-layout-event-handler widget) + (named-lambda (scm-layout-handle-event GtkWidget GdkEvent) + (trace2 ";((scm-layout-handle-event "widget") "GtkWidget" "GdkEvent")\n") (let ((type (C-> GdkEvent "GdkEvent any type"))) - (cond ((fix:= type (C-enum "GDK_EXPOSE")) + (cond ((int:= type (C-enum "GDK_EXPOSE")) (let ((window (C-> GdkEvent "GdkEvent any window")) (x (C-> GdkEvent "GdkEventExpose area x")) (y (C-> GdkEvent "GdkEventExpose area y")) @@ -400,18 +297,15 @@ USA. width height))))))) (else - (let ((name (C-enum "GdkEventType" type)) - (addr (alien/address-string - (C-> GdkEvent "GdkEvent any window")))) - (trace "; "name" on "GtkWidget" (window 0x"addr").\n"))))) + (trace "; "(C-enum "GdkEventType" type)" on "widget"\n")))) 1 ;;TRUE -- "handled" -- done. )) (define (scm-layout-set-scroll-adjustments widget) (named-lambda (scm-layout::set-scroll-adjustments GtkWidget hGtkAdjustment vGtkAdjustment) - (trace ";((scm-layout-set-scroll-adjustments "widget")" - " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n") + (trace2 ";((scm-layout-set-scroll-adjustments "widget")" + " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n") (let ((haddr (alien/address-string hGtkAdjustment)) (vaddr (alien/address-string vGtkAdjustment))) @@ -420,7 +314,8 @@ USA. widget set-scm-layout-hadjustment!) (connect-adjustment (scm-layout-vadjustment widget) vGtkAdjustment widget set-scm-layout-vadjustment!) - (adjust-adjustments widget) + (if (scm-layout-realized? widget) + (adjust-adjustments widget)) 0 ;; What does this mean? )) @@ -448,78 +343,56 @@ USA. (define (scm-layout-adjustment-value-changed widget adjustment) (named-lambda (scm-layout::adjustment-value-changed GtkAdjustment) - (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")" - " "GtkAdjustment")\n") + (trace2 ";((scm-layout-adjustment-value-changed "widget" "adjustment")" + " "GtkAdjustment")\n") - (let ((alien-widget (gobject-alien widget)) - (alien-window (scm-layout-window widget)) - (window-area (scm-layout-on-screen-area widget)) + (let ((window-area (scm-layout-on-screen-area widget)) (vadjustment (scm-layout-vadjustment widget)) (hadjustment (scm-layout-hadjustment widget)) - (alien-adjustment (gobject-alien adjustment))) - (let ((value - (floor->exact (C-> alien-adjustment "GtkAdjustment value")))) - (cond ((eq? adjustment vadjustment) - (let* ((y (rect-y window-area)) - (dy (int:- value y))) - (trace "; Vadjustment to "value" (dy:"dy")\n") - (if (not (int:zero? dy)) - (let ((width (rect-width window-area))) - (set-rect-y! window-area value) - (if (> (abs dy) (* 0.90 width)) - (let ((height (rect-height window-area))) - (if (not (alien-null? alien-window)) ;;realized - (C-call "gtk_widget_queue_draw_area" - alien-widget 0 0 width height))) - (C-call "gdk_window_scroll" - alien-window 0 (int:* -1 dy))) - (C-call "gdk_window_process_updates" alien-window 0))))) - ((eq? adjustment hadjustment) - (let* ((x (rect-x window-area)) - (height (rect-height window-area)) - (dx (int:- value x))) - (trace "; Hadjustment to "value" (dx:"dx")\n") - (if (not (int:zero? dx)) - (begin - (set-rect-x! window-area value) - (if (> (abs dx) (* 0.90 height)) - (let ((width (rect-width window-area))) - (if (not (alien-null? alien-window)) ;;realized - (C-call "gtk_widget_queue_draw_area" - alien-widget 0 0 width height))) - (C-call "gdk_window_scroll" - alien-window (int:* -1 dx) 0)) - (C-call "gdk_window_process_updates" alien-window 0))))) - (else (fwarn "Unexpected adjustment "adjustment - " (not "vadjustment" nor "hadjustment")."))))))) + (value (floor->exact + (C-> (gobject-alien adjustment) "GtkAdjustment value")))) + (cond ((eq? adjustment vadjustment) + (trace "; Vadjustment to "value"\n") + (scroll widget (rect-x window-area) value)) + ((eq? adjustment hadjustment) + (trace "; Hadjustment to "value"\n") + (scroll widget value (rect-y window-area))) + (else (fwarn "Unexpected adjustment "adjustment + " (not "vadjustment" nor "hadjustment").")))))) (define (adjust-adjustments widget) ;; Called after the widget gets new adjustment(s) or its size or ;; scrollable area changes. - (let ((hadj (scm-layout-hadjustment widget)) - (vadj (scm-layout-vadjustment widget))) + (let ((vadj (scm-layout-vadjustment widget))) (if (and vadj (not (gobject-finalized? vadj))) - (let* ((total-height (rect-height (scm-layout-scrollable-area widget))) - (scroll (scm-layout-on-screen-area widget)) - (window-height (rect-height scroll)) - (value (rect-y scroll))) - (set-gtk-adjustment! - vadj value ;value - 0 total-height ;lower (top), upper (bottom) - window-height 10 ;page-size, step-increment - (- window-height ;page-increment - (* 0.05 window-height))))) + (let* ((window (scm-layout-on-screen-area widget)) + (window-height (rect-height window)) + (area (scm-layout-scrollable-area widget)) + (top (rect-y area)) ;most neg. + (bottom (int:+ top ;most pos. + (max (rect-height area) window-height))) + (value (rect-y window)) + (page-size window-height) + (step-incr (cdr (scm-layout-scroll-step widget))) + (page-incr (min page-size (- page-size step-incr)))) + (set-gtk-adjustment! vadj value top bottom + page-size step-incr page-incr)))) + + (let ((hadj (scm-layout-hadjustment widget))) (if (and hadj (not (gobject-finalized? hadj))) - (let* ((total-width (rect-width (scm-layout-scrollable-area widget))) - (scroll (scm-layout-on-screen-area widget)) - (window-width (rect-width scroll)) - (value (rect-x scroll))) - (set-gtk-adjustment! - hadj value - 0 total-width - window-width 10 - (- window-width (* 0.05 window-width))))))) + (let* ((window (scm-layout-on-screen-area widget)) + (window-width (rect-width window)) + (area (scm-layout-scrollable-area widget)) + (left (rect-x area)) ;most neg. + (right (int:+ left ;most pos. + (max (rect-width area) window-width))) + (value (rect-x window)) + (page-size window-width) + (step-incr (car (scm-layout-scroll-step widget))) + (page-incr (min page-size (- page-size step-incr)))) + (set-gtk-adjustment! hadj value left right + page-size step-incr page-incr))))) ;;;; Drawings @@ -540,7 +413,7 @@ USA. (define (drawing-damage item #!optional rect) ;; Invalidates any widget areas affected by RECT in ITEM. By ;; default, RECT is ITEM's entire area. - (trace ";(drawing-damage "item")\n") + (trace2 ";(drawing-damage "item")\n") (let ((area (if (default-object? rect) (drawn-item-area item) @@ -594,7 +467,7 @@ USA. (define-generic drawn-item-expose (item widget window expose-area) ;; Due to the checks in drawing-expose, methods of this generic can - ;; assume expose-area and the draw item's area are well-defined (all + ;; assume expose-area and the drawn item's area are well-defined (all ;; four members are integers), intersecting, and ITEM is visible in ;; WIDGET. Methods may also assume the widget is realized and its ;; window's (gc's) clipping is already set. The widget's scroll @@ -617,6 +490,9 @@ USA. (set-drawing-widgets! drawing (delq! widget widgets)))) (define (drawing-add-item! drawing item where) + ;; WHERE can be 'TOP (or #f) or 'BOTTOM or a drawn item already in + ;; the display list. If a drawn-item, WHERE means ITEM should be + ;; spliced in just under (before) it. (cond ((or (eq? #f where) (eq? 'TOP where)) (set-drawing-display-list! @@ -624,7 +500,18 @@ USA. ((eq? 'BOTTOM where) (set-drawing-display-list! drawing (cons item (drawing-display-list drawing)))) - (else (ferror "Bad where: "where))) + ((drawn-item? where) + (let loop ((items (drawing-display-list drawing)) + (prev #f)) + (if (null? items) + (error "Item not found in drawing:" item drawing) + (let ((i (car items))) + (if (eq? where i) + (if (pair? prev) + (set-cdr! prev (cons item items)) + (set-drawing-display-list! drawing (cons item items))) + (loop (cdr items) items)))))) + (else (error:wrong-type-argument where "display list location, one of #F, TOP, BOTTOM, or a already in the drawing's display list" 'drawing-add-item!))) (drawing-damage item)) (define (set-drawing-size! drawing width height) @@ -634,6 +521,14 @@ USA. (for-each (lambda (widget) (set-scm-layout-scroll-size! widget w h)) (drawing-widgets drawing)))) + +(define (set-drawing-area! drawing rectangle) + (let ((area (drawing-area drawing))) + (set-rect! area + (rect-x rectangle) + (rect-y rectangle) + (rect-width rectangle) + (rect-height rectangle)))) ;;;; Drawn items. @@ -650,41 +545,41 @@ USA. (drawing-add-item! (drawn-item-drawing item) item where)) (define (set-drawn-item-position! item x y) - (let ((area (drawn-item-area item)) - (ix (check-non-negative-integer x)) - (iy (check-non-negative-integer y))) - (let ((curr-x (rect-x area)) - (curr-y (rect-y area)) - (width (rect-width area)) - (height (rect-height area))) - - ;; Two trivial cases, and a general one. - (cond ((and (integer? curr-x) (int:= x curr-x) - (integer? curr-y) (int:= y curr-y)) - unspecific) - ((or (not (integer? width)) (int:zero? width) - (not (integer? height)) (int:zero? height)) - (set-rect-pos! area ix iy)) - (else - (drawing-damage item) - (set-rect-pos! area ix iy) - (drawing-damage item)))))) - -(define (%set-drawn-item-size! item width height) + (let ((x (check-non-negative-integer x)) + (y (check-non-negative-integer y))) + (without-interrupts + (lambda () + (let ((area (drawn-item-area item))) + (let ((x* (rect-x area)) + (y* (rect-y area))) + (if (and (int:= x x*) (int:= y y*)) + unspecific + (begin + (drawing-damage item) + (set-rect-pos! area x y) + (drawing-damage item))))))))) + +(define (set-drawn-item-size! item width height) (let ((area (drawn-item-area item))) - (drawing-damage item) - (set-rect-size! area width height) - (drawing-damage item))) + (let ((width* (rect-width area)) + (height* (rect-height area))) + (if (and (int:= width width*) (int:= height height*)) + unspecific + (begin + (drawing-damage item) + (set-rect-size! area width height) + (drawing-damage item)))))) (define (set-drawn-item-widgets! item new) ;; Draw ITEM only on the NEW widgets. If NEW is #f, ITEM will ;; appear in all views. (let ((old (drawn-item-widgets item))) (if (not (equal? old new)) - (begin - (drawing-damage item) - (%set-drawn-item-widgets! item new) - (drawing-damage item))))) + (without-interrupts + (lambda () + (drawing-damage item) + (%set-drawn-item-widgets! item new) + (drawing-damage item)))))) (define (drawn-item-widget item) ;; Return a widget that will display the item. @@ -693,6 +588,15 @@ USA. (if (null? widgets) (ferror "No widgets display drawing "drawing".") (car widgets)))) + +(define (drawn-item-remove! item) + (let ((drawing (drawn-item-drawing item))) + (if (not (memq item (drawing-display-list drawing))) + (warn "Removing orphan drawn-item" item drawing) + (set-drawing-display-list! + drawing (delq! item (drawing-display-list drawing)))) + (drawing-damage item) + (set-drawn-item-drawing! item #f))) ;;;; Simple Items (e.g. the toolkit's gtk_paint_* operators). @@ -727,9 +631,9 @@ USA. (rect-height area))))))) (define (set-box-item-size! item width height) - (let ((w (check-non-negative-fixnum width)) - (h (check-non-negative-fixnum height))) - (%set-drawn-item-size! item w h))) + (let ((w (check-non-negative-integer width)) + (h (check-non-negative-integer height))) + (set-drawn-item-size! item w h))) (define (set-box-item-pos-size! item x y width height) (let ((area (drawn-item-area item)) @@ -737,17 +641,20 @@ USA. (yI (if (and (integer? y) (not (int:negative? y))) y 0)) (wI (if (and (fixnum? width) (not (fix:negative? width))) width 0)) (hI (if (and (fixnum? height) (not (fix:negative? height))) height 0))) - (drawing-damage item) - (set-rect! area xI yI wI hI) - (drawing-damage item))) + (without-interrupts + (lambda () + (drawing-damage item) + (set-rect! area xI yI wI hI) + (drawing-damage item))))) (define (box-item-shadow item) - (case (%box-item-shadow item) - (((C-enum "GTK_SHADOW_NONE")) 'NONE) - (((C-enum "GTK_SHADOW_IN")) 'IN) - (((C-enum "GTK_SHADOW_OUT")) 'OUT) - (((C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN) - (((C-enum "GTK_SHADOW_ETCHED_OUT")) 'ETCHED-OUT))) + (let ((shadow (%box-item-shadow item))) + (cond + ((int:= shadow (C-enum "GTK_SHADOW_NONE")) 'NONE) + ((int:= shadow (C-enum "GTK_SHADOW_IN")) 'IN) + ((int:= shadow (C-enum "GTK_SHADOW_OUT")) 'OUT) + ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_IN")) 'ETCHED-IN) + ((int:= shadow (C-enum "GTK_SHADOW_ETCHED_OUT")) 'ETCHED-OUT)))) (define (set-box-item-shadow! item type) (let ((new @@ -788,9 +695,9 @@ USA. (int:- (rect-y area) scroll-y))))))) (define (set-hline-item-size! item width) - (let ((w (check-non-negative-fixnum width)) + (let ((w (check-non-negative-integer width)) (hline (check-hline-item item))) - (%set-drawn-item-size! hline w (rect-height (drawn-item-area hline))))) + (set-drawn-item-size! hline w (rect-height (drawn-item-area hline))))) (define (check-hline-item obj) (if (hline-item? obj) obj @@ -821,9 +728,9 @@ USA. (int:- (rect-x area) scroll-x))))))) (define (set-vline-item-size! item height) - (let ((h (check-non-negative-fixnum height)) + (let ((h (check-non-negative-integer height)) (vline (check-vline-item item))) - (%set-drawn-item-size! vline (rect-width (drawn-item-area vline)) h))) + (set-drawn-item-size! vline (rect-width (drawn-item-area vline)) h))) (define (check-vline-item obj) (if (vline-item? obj) obj @@ -882,8 +789,6 @@ USA. (define (set-text-item-text! text-item text) (let ((layout (text-item-pango-layout text-item))) - (drawing-damage text-item) - (if (alien-null? layout) (begin (C-call "gtk_widget_create_pango_layout" layout @@ -893,48 +798,51 @@ USA. (let ((log-extent (pango-rectangle)) (ink-extent null-alien)) (C-call "pango_layout_get_pixel_extents" layout ink-extent log-extent) - (set-rect-size! (drawn-item-area text-item) - (C-> log-extent "GdkRectangle width") - (C-> log-extent "GdkRectangle height")) - (%set-text-item-text! text-item text) - (free log-extent)) - (drawing-damage text-item) + (without-interrupts + (lambda () + (drawing-damage text-item) + (set-rect-size! (drawn-item-area text-item) + (C-> log-extent "GdkRectangle width") + (C-> log-extent "GdkRectangle height")) + (%set-text-item-text! text-item text) + (drawing-damage text-item))) - unspecific)) + (free log-extent)))) (define (text-item-xy-to-index item x y) ;; Assumes (X,Y) is in ITEM's area (all logical dev. coords.). - (let ((layout (text-item-pango-layout item)) - (area (drawn-item-area item))) + (let ((layout (text-item-pango-layout item))) (if (not (alien-null? layout)) - (let ((index-alien (malloc (C-sizeof "int") '(* int))) - ;;-> layout coords. - (xL (int:- x (rect-x area))) - (yL (int:- y (rect-y area)))) - (if (fix:= 0 (C-call "pango_layout_xy_to_index" layout - (pixels->pangos xL) (pixels->pangos yL) - index-alien null-alien)) - (begin - (free index-alien) - #f) - (let ((index (C-> index-alien "int"))) - (free index-alien) - index))) + (let ((area (drawn-item-area item)) + (index-alien (malloc (C-sizeof "int") 'int))) + (let ((xL (int:- x (rect-x area))) ; layout coords. + (yL (int:- y (rect-y area)))) + (if (fix:= 0 (C-call "pango_layout_xy_to_index" layout + (pixels->pangos xL) (pixels->pangos yL) + index-alien null-alien)) + (begin + (free index-alien) + #f) + (let ((index (C-> index-alien "int"))) + (free index-alien) + index)))) #f))) (define (call-with-text-item-grapheme-rect item index receiver) ;; Calls RECEIVER with the x, y, width and height of the grapheme at ;; INDEX in ITEM. - (let ((layout (text-item-pango-layout item)) - (rect (pango-rectangle))) - (C-call "pango_layout_index_to_pos" layout index rect) - (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) - (y (pangos->pixels (C-> rect "PangoRectangle y"))) - (width (pangos->pixels (C-> rect "PangoRectangle width"))) - (height (pangos->pixels (C-> rect "PangoRectangle height")))) - (free rect) - (receiver x y width height)))) + (let ((layout (text-item-pango-layout item))) + (if (not (alien-null? layout)) + (let ((rect (pango-rectangle))) + (C-call "pango_layout_index_to_pos" layout index rect) + (let ((x (pangos->pixels (C-> rect "PangoRectangle x"))) + (y (pangos->pixels (C-> rect "PangoRectangle y"))) + (width (pangos->pixels (C-> rect "PangoRectangle width"))) + (height (pangos->pixels (C-> rect "PangoRectangle height")))) + (free rect) + (receiver x y width height))) + #f))) ;;;; Images (aka GdkPixbufLoaders) @@ -957,7 +865,7 @@ USA. (define (image-item-size-prepared item) (named-lambda (image-item::size-prepared width height) (trace "; image-item::size-prepared "item" "width" "height"\n") - (%set-drawn-item-size! item width height))) + (set-drawn-item-size! item width height))) (define (image-item-pixbuf-prepared item) (named-lambda (image-item::pixbuf-prepared pixbuf) @@ -1020,24 +928,15 @@ USA. )))))))) (define (add-image-item-from-file drawing where filename) - ;; WHERE can be 'TOP (or #f) or 'BOTTOM. - (let ((item (add-image-item drawing (check-where where)))) + (let ((item (add-image-item drawing where))) (load-pixbuf-from-file (image-item-loader item) filename) item)) -(define (check-where where) - (cond ((eq? where #f) 'TOP) - ((eq? where 'TOP) 'TOP) - ((eq? where 'BOTTOM) 'BOTTOM) - (else (ferror "The WHERE argument ("where") must be TOP (or #f)" - " or BOTTOM if it is not optional.")))) - -(define-integrable (check-non-negative-fixnum obj) - (if (fixnum? obj) - (if (fix:negative? obj) - (ferror "Not a NON-NEGATIVE fixnum: "obj) - obj) - (ferror "Not a non-negative fixnum: "obj))) +(define-integrable (check-positive-integer obj) + (if (and (integer? obj) (int:> obj 0)) + obj + (error:wrong-type-argument obj "positive, non-zero integer" + 'check-positive-integer))) (define-integrable (check-non-negative-integer obj) (if (integer? obj) @@ -1050,4 +949,9 @@ USA. (define-syntax trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + +(define trace2? #f) +(define-syntax trace2 + (syntax-rules () + ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index 55eb41598..3b35fc1ce 100644 --- a/src/gtk/thread.scm +++ b/src/gtk/thread.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -69,9 +69,12 @@ USA. (+ (real-time-clock) 1000))))) (define (kill-gtk-thread) - (if (not gtk-thread) (error "A GTk thread is not running.")) - (signal-thread-event - gtk-thread (lambda () (exit-current-thread #t)))) + (let ((thread gtk-thread)) + (set! gtk-thread #f) + (if (not thread) (error "A GTk thread was not running.")) + (signal-thread-event + thread (lambda () + (exit-current-thread #t))))) (define trace? #f) diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 4a2bb7275..ff59d0b06 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -795,7 +795,6 @@ if test ${enable_valgrind_mode} != no; then M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1" fi -dnl Add support for Gtk if present. AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) if test ${with_gtk} = yes; then AC_MSG_CHECKING([for gtk]) @@ -804,7 +803,7 @@ if test ${with_gtk} = yes; then else if pkg-config --exists gtk+-2.0; then AC_MSG_RESULT([yes]) - MODULE_BASES="${MODULE_BASES} prgtkio" + MODULE_TARGETS="${MODULE_TARGETS} prgtkio.so" else AC_MSG_RESULT([no, ! pkg-config --exists gtk+-2.0]) fi