\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
@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
@ifnottex
@node Top, Introduction, (dir), (dir)
-@top Gtk Users' Manual
+@top Gtk Interface
@insertcopying
@end ifnottex
* 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
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
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})
@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
@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
A demo of two @code{<scm-layout>} widgets displaying one canvas is
provided. The canvas contains text, horizontal and vertical lines,
and an image. It also contains animated boxes that blink and follow
-the mouse. Enter these 3 lines to create this widget.
+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
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)
$(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
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
[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}])
AC_MSG_RESULT([yes])
fi
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+if test "${with_gtk}" = yes; then
+ AC_MSG_CHECKING([for gtk])
+ if test "${PKG_CONFIG}" != yes; then
+ AC_MSG_RESULT([no, no pkg-config])
+ with_gtk=no
+ elif ! "${MIT_SCHEME_EXE}" --eval "(load-option'FFI)" \
+ --batch-mode </dev/null >/dev/null 2>&1; then
+ AC_MSG_RESULT([no, no FFI])
+ with_gtk=no
+ else
+ if pkg-config --exists gtk+-2.0; then
+ AC_MSG_RESULT([yes])
+ FFIS=gtk
+ else
+ AC_MSG_RESULT([no, ! pkg-config --exists gtk+2.0])
+ fi
+ fi
+fi
+
AC_SUBST([ALL_TARGET])
+AC_SUBST([FFIS])
AC_SUBST([INSTALL_COM])
AC_SUBST([INSTALL_LIARC_BUNDLES])
AC_SUBST([MIT_SCHEME_EXE])
cref/Makefile
edwin/Makefile
ffi/Makefile
-gtk/Makefile
imail/Makefile
runtime/Makefile
sf/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
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
--- /dev/null
+gtk-const
+gtk-const.c
+gtk-const.scm
+gtk-shim.c
+gtk-shim.so
+scmwidget.c
(GDK_SCROLL)
(GDK_WINDOW_STATE)
(GDK_SETTING)
- (GDK_OWNER_CHANGE)))
+ (GDK_OWNER_CHANGE)
+ (GDK_GRAB_BROKEN)
+ (GDK_DAMAGE)))
(typedef GdkEventMask
(enum
(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)
(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
(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)))
(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
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)))
;(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
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(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)
;; 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")))
("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
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(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)))))))
\f
;;; Properties
(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)))
(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"
- " <gobject> nor alien."))))
- (value-gtype
- (gobject-get-gtype value-alien)))
- (if (fix:zero? (C-call "g_value_type_compatible"
- value-gtype gtype))
- (ferror "The value "value" for property "
- name" of "gclass-name
- " has incompatible type "
- (gclass-get-name
- (gobject-get-gclass value-alien))
- "."))
- (C-call "g_value_set_object" gvalue value-alien)))
- (else
- (ferror "Fundamental GType "
- (C-enum "enum GFundamentalType" fundamental)
- " (the type of the "name" property of a "
- gclass-name") is not supported."))))
+ ((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"
+ " <gobject> nor alien."))))
+ (value-gtype
+ (gobject-get-gtype value-alien)))
+ (if (fix:zero? (C-call "g_value_type_compatible"
+ value-gtype gtype))
+ (ferror "The value "value" for property "
+ name" of "gclass-name
+ " has incompatible type "
+ (gclass-get-name
+ (gobject-get-gclass value-alien))
+ "."))
+ (C-call "g_value_set_object" gvalue value-alien)))
+ (else
+ (ferror "Fundamental GType "
+ (C-enum "enum GFundamentalType" fundamental)
+ " (the type of the "name" property of a "
+ gclass-name") is not supported."))))
(C-call "g_object_set_property" object-alien name gvalue)
(C-call "g_value_reset" gvalue)))
(loop (cddr plist)))))
(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?))
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(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 "<gtk-object>" 'check-gtk-object)))
\f
;;;; GtkAdjustments
(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)))
\f
;;;; GtkWidgets, GtkContainers
(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))
+\f
+
+;;;; 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))))
+\f
+
+;;;; 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))))
+\f
+
+;;;; GtkContainers
(define-class <gtk-container> (<gtk-widget>)
(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 <gtk-widget> instance.")))
+ (error:wrong-type-argument object "<gtk-widget>" 'check-gtk-widget)))
-(define (check-gtk-container object)
+(define-integrable (check-gtk-container object)
(if (gtk-container? object) object
- (ferror object" is not a <gtk-container> instance.")))
+ (error:wrong-type-argument object "<gtk-container>"
+ 'check-gtk-container)))
\f
;;; GtkLabels
(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 "<gtk-scrolled-window>"
+ '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))))
\f
;;;; GtkWindows
(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 "<gtk-window>" operator)))
+(define-integrable (check-gtk-window object)
+ (if (gtk-window? object) object
+ (error:wrong-type-argument object "<gtk-window>" '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)
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(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
#| -*-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")
(export (gtk)
<gobject> 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
<pixbuf-loader> make-pixbuf-loader load-pixbuf-from-file
<gtk-object> gtk-object-destroyed? gtk-object-destroy
<gtk-adjustment> make-gtk-adjustment set-gtk-adjustment!
<gtk-widget> gtk-widget? gtk-widget-parent
- gtk-widget-has-focus? gtk-widget-drawable? gtk-widget-show-all
+ gtk-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?
gtk-container-children gtk-container-add
gtk-container-set-border-width
gtk-label-get-text gtk-label-set-text
<gtk-vbox> gtk-vbox-new gtk-box-pack-start gtk-box-pack-end
<gtk-scrolled-window> gtk-scrolled-window-new
- pango-rectangle pangos->pixels pixels->pangos
- pango-font-families pango-context-list-families
- pango-font-family-get-name pango-font-family-is-monospace?
- pango-font-family-faces pango-font-face-get-name)
- (import (gtk gobject) gobject-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))
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))
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
-
- <drawing> make-drawing set-drawing-size! drawing-pick-list
+ <drawing> make-drawing drawing-widgets
+ set-drawing-size! drawing-pick-list
- <drawn-item> drawn-item-area set-drawn-item-position!
+ <drawn-item>
+ drawn-item-drawing drawn-item-area set-drawn-item-position!
drawn-item-widgets set-drawn-item-widgets!
+ drawn-item-remove!
<box-item> add-box-item set-box-item-size!
set-box-item-pos-size! set-box-item-shadow!
<image-item> add-image-item-from-file))
+(define-package (gtk pango)
+ (parent (gtk))
+ (files "pango")
+ (export (gtk)
+ <pango-layout>
+ pango-layout-get-context
+ pango-layout-get-font-description
+ pango-layout-set-text
+ pango-layout-get-pixel-extents
+ pango-layout-index-to-pos
+ pango-font-description-from-string
+ pango-font-description-to-string
+ pango-font-description-free
+ pango-context-get-font-description
+ pango-context-set-font-description
+ pango-context-get-metrics
+ pango-context-spacing
+ pango-font-metrics-get-ascent
+ pango-font-metrics-get-descent
+ pango-font-metrics-get-approximate-char-width
+ pango-font-metrics-unref
+ pango-rectangle
+ pangos->pixels
+ pixels->pangos))
+
(define-package (gtk thread)
(parent (runtime thread))
(files "thread")
*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!
(parent (gtk))
(files "demo")
(import (gtk layout)
- scm-layout-event)
+ scm-layout-event-handler)
(export ()
scm-layout-demo))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(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))
(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
(with-simple-restart 'MUFFLE-WARNING "Ignore warning."
(lambda () (signal args))))))
\f
-
-;;;; Pango
-
-(define (pango-rectangle #!optional x y width height)
- (if (default-object? x)
- (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|)
- (let ((rect (malloc (C-sizeof "PangoRectangle") '|PangoRectangle|)))
- (C->= rect "PangoRectangle x" x)
- (C->= rect "PangoRectangle y" y)
- (C->= rect "PangoRectangle width" width)
- (C->= rect "PangoRectangle height" height)
- rect)))
-
-(define-integrable (pangos->pixels pango-units)
- (quotient (int:+ pango-units 512) 1024))
-
-(define-integrable (pixels->pangos pixel-units)
- (* pixel-units 1024))
+;;; 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|))))
#| -*-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.
;; 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
#| -*-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))
(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)))))
#| -*-Scheme-*-
-Copyright (C) 2008, 2009 Matthew Birkholz
+Copyright (C) 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(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))
--- /dev/null
+#| -*-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")
+\f
+;;; PangoLayout
+
+(define-class (<pango-layout> (constructor ()))
+ (<gobject>))
+
+(define-method initialize-instance ((pango-layout <pango-layout>))
+ (call-next-method pango-layout)
+ (set-alien/ctype! (gobject-alien pango-layout) '|PangoLayout|))
+
+(define (pango-layout-get-context layout)
+ (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 "<pango-layout>" 'check-pango-layout)))
+\f
+;;; PangoFontDescription
+
+(define (pango-font-description-from-string string)
+ (let ((str (check-string string)))
+ (let ((font (make-alien '|PangoFontDescription|))
+ (copy (make-alien '|PangoFontDescription|)))
+ (add-gc-cleanup font (pango-font-description-cleanup copy))
+ (C-call "pango_font_description_from_string" copy str)
+ (copy-alien-address! font copy)
+ font)))
+
+(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)
+ "<null>"
+ (let ((cstr (make-alien '|char|)))
+ (C-call "pango_font_description_to_string" cstr font)
+ (let ((str (c-peek-cstring cstr)))
+ (C-call "g_free" cstr)
+ str)))))
+
+(define (check-PangoFontDescription object)
+ (if (and (alien? object) (eq? '|PangoFontDescription| (alien/ctype object)))
+ object
+ (check-PangoFontDescription
+ (error:wrong-type-argument
+ object "PangoFontDescription's (alien) address"
+ 'check-PangoFontDescription))))
+
+(define (check-string object)
+ (if (string? object) object
+ (error:wrong-type-argument object "a string" 'check-string)))
+\f
+;;; 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))))
+\f
+;;; 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))))
+\f
+;;; 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
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(define-class (<scm-layout> (constructor make-scm-layout ()))
(<scm-widget>)
- ;; 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
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)
(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")))
(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))
(%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 <scm-layout> instance: "obj)))
-\f
-
-;;;; 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 "<scm-layout>" 'check-scm-layout-alien)))
\f
;;;; 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"))
(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|))
(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))
;; 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"))
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)))
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?
))
(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)))))
\f
;;;; Drawings
(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)
(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
(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!
((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 <drawn-item> already in the drawing's display list" 'drawing-add-item!)))
(drawing-damage item))
(define (set-drawing-size! drawing width height)
(for-each
(lambda (widget) (set-scm-layout-scroll-size! widget w h))
(drawing-widgets drawing))))
+
+(define (set-drawing-area! drawing rectangle)
+ (let ((area (drawing-area drawing)))
+ (set-rect! area
+ (rect-x rectangle)
+ (rect-y rectangle)
+ (rect-width rectangle)
+ (rect-height rectangle))))
\f
;;;; Drawn items.
(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.
(if (null? widgets)
(ferror "No widgets display drawing "drawing".")
(car widgets))))
+
+(define (drawn-item-remove! item)
+ (let ((drawing (drawn-item-drawing item)))
+ (if (not (memq item (drawing-display-list drawing)))
+ (warn "Removing orphan drawn-item" item drawing)
+ (set-drawing-display-list!
+ drawing (delq! item (drawing-display-list drawing))))
+ (drawing-damage item)
+ (set-drawn-item-drawing! item #f)))
\f
;;;; Simple Items (e.g. the toolkit's gtk_paint_* operators).
(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))
(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
(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
(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
(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
(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)))
\f
;;;; Images (aka GdkPixbufLoaders)
(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)
))))))))
(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)
(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
#| -*-Scheme-*-
-Copyright (C) 2007, 2008, 2009 Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz
This file is part of MIT/GNU Scheme.
(+ (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)
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])
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
projects / mit-scheme.git / commitdiff