From edbe9e6f52fb12116ee8fe937f2d9b6aafe2104f Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 29 Jul 2009 21:36:51 -0700 Subject: [PATCH] Support scm-layout colors: fg, bg, text and base. * doc/.gitignore, src/.gitignore, src/TAGS, src/gtk/ed-ffi.scm: Added the Gtk build products/byproducts, Emacs and Edwin source file declarations. * src/gtk/Includes/: gdkcolor.cdecl, gdktypes.cdecl, gdkwindow.cdecl, gtk.cdecl, gtkrc.cdecl, gtkstyle.cdecl, gtkwidget.cdecl, gtkwindow.cdecl, pango-layout.cdecl: Declare additional C functions and constants. * src/gtk/Makefile-fragment: Make C-generate products dependent on ALL .cdecl files, including all of Includes/*.cdecl. * src/gtk/compile.scm: Factored some common code into a tricked-out sf procedure: sf+. * src/gtk/gtk-object.scm: Added new widget and window functions. Do more argument type checking. * src/gtk/gtk.cdecl: Removed gtk_window_new, gtk_window_set_title and gtk_window_set_default_size to Includes/gtkwindow.cdecl. * src/gtk/gtk.pkg: Export new widget, window and color procedures. * src/gtk/scm-layout.scm: Uncomment trace statements; implement trace as a syntactic keyword. Comment out visual and colormap GdkWindowAttr settings. Added accessors and mutators for the widget's four GTK_STATE_NORMAL colors. --- src/TAGS | 2 + src/gtk/Includes/gdkcolor.cdecl | 6 +- src/gtk/Includes/gdktypes.cdecl | 6 +- src/gtk/Includes/gdkwindow.cdecl | 9 +- src/gtk/Includes/gtk.cdecl | 4 +- src/gtk/Includes/gtkrc.cdecl | 30 ++++ src/gtk/Includes/gtkstyle.cdecl | 6 + src/gtk/Includes/gtkwidget.cdecl | 6 + src/gtk/Includes/gtkwindow.cdecl | 55 +++++++ src/gtk/Includes/pango-layout.cdecl | 2 + src/gtk/Makefile-fragment | 2 +- src/gtk/compile.scm | 22 ++- src/gtk/ed-ffi.scm | 17 +++ src/gtk/gtk-object.scm | 50 ++++++- src/gtk/gtk.cdecl | 15 -- src/gtk/gtk.pkg | 14 +- src/gtk/scm-layout.scm | 216 ++++++++++++++++++++++------ 17 files changed, 377 insertions(+), 85 deletions(-) create mode 100644 src/gtk/Includes/gtkrc.cdecl create mode 100644 src/gtk/Includes/gtkwindow.cdecl create mode 100644 src/gtk/ed-ffi.scm diff --git a/src/TAGS b/src/TAGS index e0668593b..c54e128f0 100644 --- a/src/TAGS +++ b/src/TAGS @@ -16,3 +16,5 @@ cref/TAGS,include rcs/TAGS,include ffi/TAGS,include + +gtk/TAGS,include diff --git a/src/gtk/Includes/gdkcolor.cdecl b/src/gtk/Includes/gdkcolor.cdecl index 9535948dd..e7af670f3 100644 --- a/src/gtk/Includes/gdkcolor.cdecl +++ b/src/gtk/Includes/gdkcolor.cdecl @@ -53,9 +53,9 @@ gtk-2.0/gdk/gdkcolor.h |# ; (color (const (* GdkColor)))) ;(extern void gdk_color_free ; (color (* GdkColor))) -;(extern gint gdk_color_parse -; (spec (const (* gchar))) -; (color (* GdkColor))) +(extern gint gdk_color_parse + (spec (const (* gchar))) + (color (* GdkColor))) ;(extern guint gdk_color_hash ; (colora (const (* GdkColor)))) ;(extern gboolean gdk_color_equal diff --git a/src/gtk/Includes/gdktypes.cdecl b/src/gtk/Includes/gdktypes.cdecl index 43bf3dbdc..58ef7c44c 100644 --- a/src/gtk/Includes/gdktypes.cdecl +++ b/src/gtk/Includes/gdktypes.cdecl @@ -52,9 +52,11 @@ gtk-2.0/gdk/gdktypes.h |# (GDK_BUTTON3_MASK) (GDK_BUTTON4_MASK) (GDK_BUTTON5_MASK) + (GDK_SUPER_MASK) + (GDK_HYPER_MASK) + (GDK_META_MASK) (GDK_RELEASE_MASK) - ;;GDK_MODIFIER_MASK = GDK_RELEASE_MASK | 0x1fff - )) + (GDK_MODIFIER_MASK))) (typedef GdkInputCondition (enum diff --git a/src/gtk/Includes/gdkwindow.cdecl b/src/gtk/Includes/gdkwindow.cdecl index 2b3292160..de51593bf 100644 --- a/src/gtk/Includes/gdkwindow.cdecl +++ b/src/gtk/Includes/gdkwindow.cdecl @@ -212,10 +212,11 @@ gtk-2.0/gdk/gdkwindow.h |# (dx gint) (dy gint)) -;(extern void gdk_window_invalidate_rect -; (window (* GdkWindow)) -; (rect (* GdkRectangle)) -; (invalidate_children gboolean)) +(extern void + gdk_window_invalidate_rect + (window (* GdkWindow)) + (rect (* (const GdkRectangle))) + (invalidate_children gboolean)) (extern void gdk_window_process_updates (window (* GdkWindow)) diff --git a/src/gtk/Includes/gtk.cdecl b/src/gtk/Includes/gtk.cdecl index 99f02f6a8..15b2b06de 100644 --- a/src/gtk/Includes/gtk.cdecl +++ b/src/gtk/Includes/gtk.cdecl @@ -109,7 +109,7 @@ gtk-2.0/gtk/gtk.h |# ;(include "gtkradiomenuitem") ;(include "gtkradiotoolbutton") ;(include "gtkrange") -;(include "gtkrc") +(include "gtkrc") ;(include "gtkruler") ;(include "gtkscale") ;(include "gtkscrollbar") @@ -162,4 +162,4 @@ gtk-2.0/gtk/gtk.h |# ;(include "gtkvscrollbar") ;(include "gtkvseparator") (include "gtkwidget") -;(include "gtkwindow") \ No newline at end of file +(include "gtkwindow") \ No newline at end of file diff --git a/src/gtk/Includes/gtkrc.cdecl b/src/gtk/Includes/gtkrc.cdecl new file mode 100644 index 000000000..54a10956f --- /dev/null +++ b/src/gtk/Includes/gtkrc.cdecl @@ -0,0 +1,30 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkrc.h |# + +(typedef GtkRcFlags + (enum + (GTK_RC_FG) + (GTK_RC_BG) + (GTK_RC_TEXT) + (GTK_RC_BASE))) + +(struct _GtkRcStyle + (parent_instance GObject) + (name (* gchar)) + (bg_pixmap_name (array (* gchar) 5)) + (font_desc (* PangoFontDescription)) + (color_flags (array GtkRcFlags 5)) + (fg (array GdkColor 5)) + (bg (array GdkColor 5)) + (text (array GdkColor 5)) + (base (array GdkColor 5)) + (xthickness gint) + (ythickness gint) + ;; private + ;; (rc_properties (* GArray)) + ;; (rc_style_lists (* GSList)) + ;; (icon_factories (* GSList)) + ;; bit field + ;; (engine_specified guint) + ) \ No newline at end of file diff --git a/src/gtk/Includes/gtkstyle.cdecl b/src/gtk/Includes/gtkstyle.cdecl index dc852dc3b..bb78ee4bf 100644 --- a/src/gtk/Includes/gtkstyle.cdecl +++ b/src/gtk/Includes/gtkstyle.cdecl @@ -5,6 +5,7 @@ gtk-2.0/gtk/gtkstyle.h |# (typedef GtkWidget (struct _GtkWidget)) (typedef GtkStyle (struct _GtkStyle)) +(typedef GtkRcStyle (struct _GtkRcStyle)) (struct _GtkStyle (parent_instance GObject) @@ -62,6 +63,11 @@ gtk-2.0/gtk/gtkstyle.h |# (window (* GdkWindow)) (state_type GtkStateType)) +(extern gboolean gtk_style_lookup_color + (style (* GtkStyle)) + (color_name (const (* gchar))) + (color (* GdkColor))) + (extern void gtk_paint_hline (style (* GtkStyle)) (window (* GdkWindow)) diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl index cf9918af9..70439ab76 100644 --- a/src/gtk/Includes/gtkwidget.cdecl +++ b/src/gtk/Includes/gtkwidget.cdecl @@ -299,9 +299,15 @@ gtk-2.0/gtk/gtkwidget.h |# (width gint) (height gint)) +(extern void gtk_widget_grab_focus + (widget (* GtkWidget))) + (extern (* GdkWindow) gtk_widget_get_parent_window (widget (* GtkWidget))) +(extern void gtk_widget_error_bell + (widget (* GtkWidget))) + (extern (* GdkColormap) gtk_widget_get_colormap (widget (* GtkWidget))) (extern (* GdkVisual) gtk_widget_get_visual diff --git a/src/gtk/Includes/gtkwindow.cdecl b/src/gtk/Includes/gtkwindow.cdecl new file mode 100644 index 000000000..f5935d99a --- /dev/null +++ b/src/gtk/Includes/gtkwindow.cdecl @@ -0,0 +1,55 @@ +#| -*-Scheme-*- + +gtk-2.0/gtk/gtkwindow.h |# + +(include "gdk") +;(include "gtkaccelgroup") +;(include "gtkbin") +(include "gtkenums") +(include "gtkwidget") + +;(typedef GtkWindow (struct _GtkWindow)) +;(typedef GtkWindowGeometryInfo (struct _GtkWindowGeometryInfo)) + +(extern (* GtkWidget) + gtk_window_new + (type GtkWindowType)) + +(extern void + gtk_window_set_title + (window (* GtkWindow)) + (title (* (const gchar)))) + +(extern void + gtk_window_set_geometry_hints + (window (* GtkWindow)) + (geometry_widget (* GtkWidget)) + (geometry (* GdkGeometry)) + (geom_mask GdkWindowHints)) + +(extern void + gtk_window_present + (window (* GtkWindow))) + +(extern void + gtk_window_set_default_size + (window (* GtkWindow)) + (width gint) + (height gint)) + +(extern void + gtk_window_get_default_size + (window (* GtkWindow)) + (width (* gint)) + (height (* gint))) + +(extern void + gtk_window_resize + (window (* GtkWindow)) + (width gint) + (height gint)) + +(extern gboolean + gtk_window_parse_geometry + (window (* GtkWindow)) + (geometry (* (const gchar)))) \ No newline at end of file diff --git a/src/gtk/Includes/pango-layout.cdecl b/src/gtk/Includes/pango-layout.cdecl index 6f27065eb..cb622cd94 100644 --- a/src/gtk/Includes/pango-layout.cdecl +++ b/src/gtk/Includes/pango-layout.cdecl @@ -7,6 +7,8 @@ pango-1.0/pango/pango-layout.h |# ;(include "pango-glyph-item") ;(include "pango-tabs") +(extern int pango_layout_get_spacing + (layout (* PangoLayout))) (extern void pango_layout_get_extents (layout (* PangoLayout)) (ink_rect (* PangoRectangle)) diff --git a/src/gtk/Makefile-fragment b/src/gtk/Makefile-fragment index 74feb9bde..f718e04bf 100644 --- a/src/gtk/Makefile-fragment +++ b/src/gtk/Makefile-fragment @@ -49,7 +49,7 @@ scmwidget.c: scmwidget.c.stay gtk-shim.o: gtk-shim.c gtk-shim.h ../lib/mit-scheme.h $(COMPILE_SHIM) `pkg-config --cflags gtk+-2.0` -o $@ -c $< -gtk-shim.c gtk-const.c gtk-types.bin: gtk.cdecl +gtk-shim.c gtk-const.c gtk-types.bin: gtk.cdecl Includes/*.cdecl (echo "(load-option 'FFI)"; \ echo '(C-generate "gtk" "#include \"gtk-shim.h\"")') \ | mit-scheme --batch-mode diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index a1addd393..ec3de31b7 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -7,11 +7,18 @@ Compile the GTK system. |# (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"))) + "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)))))) ;; Build an empty package for use at syntax-time. ;; The C-include syntax will bind C-INCLUDES here. @@ -24,17 +31,8 @@ Compile the GTK system. |# ;; Load the gtkio primitives too. (load-library-object-file "prgtkio" #t) - ;; Syntax in (gtk). - (fluid-let ((sf/default-syntax-table (->environment '(gtk))) - (sf/default-declarations - (cons '(usual-integrations) sf/default-declarations))) - (for-each (lambda (f) (sf-conditionally f #t)) gtk-files)) - - ;; Syntax in (runtime thread). - (fluid-let ((sf/default-syntax-table (->environment '(gtk thread))) - (sf/default-declarations - (cons '(usual-integrations) sf/default-declarations))) - (sf-conditionally "thread" #t)) + (sf+ gtk-files '(gtk) '("gtk-const")) + (sf+ "thread" '(gtk thread) '()) ;; Cross-check. (cref/generate-constructors "gtk" 'ALL) diff --git a/src/gtk/ed-ffi.scm b/src/gtk/ed-ffi.scm new file mode 100644 index 000000000..fdc3f5730 --- /dev/null +++ b/src/gtk/ed-ffi.scm @@ -0,0 +1,17 @@ +#| -*- Scheme -*- + +$Id: $ + +GTK buffer packaging info |# + +(standard-scheme-find-file-initialization + '#( + ("gtk" (gtk)) + ("gobject" (gtk gobject)) + ("gtk-object" (gtk gtk-object)) + ("scm-widget" (gtk widget)) + ("scm-layout" (gtk layout)) + ("thread" (gtk thread)) + ("main" (gtk main)) + ("gtk-ev" (gtk event-viewer)) + ("demo" (gtk demo)))) \ No newline at end of file diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm index ba7f0302d..3cbe0cc67 100644 --- a/src/gtk/gtk-object.scm +++ b/src/gtk/gtk-object.scm @@ -160,8 +160,13 @@ USA. (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)))) + (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)))) + +(define (gtk-widget-error-bell widget) + (C-call "gtk_widget_error_bell" (gobject-alien (check-gtk-widget widget)))) (define-class () @@ -326,12 +331,49 @@ USA. (ferror "The argument to gtk-window-new must be one of" " the symbols TOPLEVEL or POPUP (not "type")."))))) -(define (gtk-window-set-title window string) - (C-call "gtk_window_set_title" (gobject-alien window) string)) +(define (guarantee-gtk-window object operator) + (if (not (gtk-window? object)) + (error:wrong-type-argument object "" operator))) + +(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)) + +(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"))) + (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)) +(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))) + +(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)) + +(define (gtk-window-present window) + (guarantee-gtk-window window 'gtk-window-present) + (C-call "gtk_window_present" (gobject-alien window))) + + (define trace? #f) (define-syntax trace diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl index cd8d90b57..1d6989f7d 100644 --- a/src/gtk/gtk.cdecl +++ b/src/gtk/gtk.cdecl @@ -130,10 +130,6 @@ USA. (container (* GtkContainer)) (border_width guint)) -(extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtkwindow.h - gtk_window_new - (type GtkWindowType)) - (extern (* GtkWidget) ;gtk+-2.4.0/gtk/gtkbutton.h gtk_button_new) @@ -141,17 +137,6 @@ USA. gtk_label_new (str (* (const char)))) -(extern void ;gtk+-2.4.0/gtk/gtkwindow.h - gtk_window_set_title - (window (* GtkWindow)) - (title (* (const gchar)))) - -(extern void ;gtk+-2.10.14/gtk/gtkwindow.h - gtk_window_set_default_size - (window (* GtkWindow)) - (width gint) - (height gint)) - (extern (* (const gchar)) ;gtk+-2.4.0/gtk/gtklabel.h gtk_label_get_text (label (* GtkLabel))) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 957ee35e9..40a6331da 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -37,11 +37,17 @@ Gtk System Packaging |# make-gtk-adjustment set-gtk-adjustment! gtk-widget? gtk-widget-parent gtk-widget-has-focus? gtk-widget-drawable? gtk-widget-show-all + gtk-widget-grab-focus + gtk-widget-error-bell gtk-container? gtk-container-children gtk-container-add gtk-container-set-border-width gtk-window-type - gtk-window-new gtk-window-set-title gtk-window-set-default-size + gtk-window-new gtk-window-set-title + gtk-window-set-default-size gtk-window-get-default-size + gtk-window-parse-geometry + gtk-window-resize + gtk-window-present gtk-button-new gtk-label-new gtk-label-get-text gtk-label-set-text @@ -73,6 +79,12 @@ Gtk System Packaging |# scm-layout-drawing set-scm-layout-drawing! scm-layout-on-screen-area set-scm-layout-scroll-pos! + 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 drawn-item-area set-drawn-item-position! diff --git a/src/gtk/scm-layout.scm b/src/gtk/scm-layout.scm index 451183184..fe5ee0d98 100644 --- a/src/gtk/scm-layout.scm +++ b/src/gtk/scm-layout.scm @@ -33,12 +33,16 @@ USA. () ;; Our window, a GdkWindow alien, and its geometry (allocation). - ;; Until realized, these are null and #f (x, y, width and height). - ;; If realized, they are non-null and fixnums (respectively). + ;; 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]). + (window define accessor initializer (lambda () (make-alien '|GdkWindow|))) (geometry define accessor initializer make-rect) + ;; Scrollbar widgets. (vadjustment define standard initial-value #f) (hadjustment define standard initial-value #f) @@ -138,14 +142,147 @@ USA. (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))))) + + ;;;; Callback handlers. (define (scm-layout-size-request widget) (named-lambda (scm-layout::size-request GtkWidget GtkRequisition) - GtkWidget ;;Ignored. - -;;; (trace ";((scm-layout-size-request "widget") "GtkWidget" " -;;; GtkRequisition")\n") + (trace ";((scm-layout-size-request "widget") "GtkWidget + " "GtkRequisition")\n") (let ((alien (gobject-alien widget))) (let ((width (C-> alien "GtkWidget requisition width")) @@ -157,8 +294,8 @@ USA. (define (scm-layout-size-allocate widget) (named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation) - -;;; (trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n") + (trace ";((scm-layout-size-allocate "widget") "GtkWidget + " "GtkAllocation")\n") (let ((x (C-> GtkAllocation "GtkAllocation x")) (y (C-> GtkAllocation "GtkAllocation y")) @@ -181,8 +318,7 @@ USA. (define (scm-layout-realize widget) (named-lambda (scm-layout::realize GtkWidget) - -;;; (trace ";((scm-layout-realize "widget") "GtkWidget")\n") + (trace ";((scm-layout-realize "widget") "GtkWidget")\n") ;; ScmWidget automatically sets GTK_REALIZED. @@ -190,8 +326,8 @@ USA. (main-GdkWindow (scm-layout-window widget)) (GtkStyle (C-> GtkWidget "GtkWidget style")) (parent-GdkWindow (make-alien '|GdkWindow|)) - (GdkVisual (make-alien '|GdkVisual|)) - (GdkColormap (make-alien '|GdkColormap|)) +; (GdkVisual (make-alien '|GdkVisual|)) +; (GdkColormap (make-alien '|GdkColormap|)) (check-!null (lambda (alien message) (if (alien-null? alien) (ferror "scm-layout: "message) @@ -199,10 +335,10 @@ USA. ;; Create widget window. - (C-call "gtk_widget_get_visual" GdkVisual GtkWidget) - (check-!null GdkVisual "Could not get GdkVisual.") - (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) - (check-!null GdkColormap "Could not get GdkColormap.") +; (C-call "gtk_widget_get_visual" GdkVisual GtkWidget) +; (check-!null GdkVisual "Could not get GdkVisual.") +; (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) +; (check-!null GdkColormap "Could not get GdkColormap.") (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) (let ((r (scm-layout-geometry widget))) @@ -212,8 +348,8 @@ USA. (C->= attr "GdkWindowAttr width" (rect-width r)) (C->= attr "GdkWindowAttr height" (rect-height r))) (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) - (C->= attr "GdkWindowAttr visual" GdkVisual) - (C->= attr "GdkWindowAttr colormap" GdkColormap) +; (C->= attr "GdkWindowAttr visual" GdkVisual) +; (C->= attr "GdkWindowAttr colormap" GdkColormap) (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) @@ -221,7 +357,8 @@ USA. (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr (bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y") - (C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP"))) +; (C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP") + )) (check-!null main-GdkWindow "Could not create main window.") (C->= GtkWidget "GtkWidget window" main-GdkWindow) (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) @@ -230,7 +367,7 @@ USA. ;; Style (C-call "gtk_style_attach" GtkStyle - (C-> GtkWidget "GtkWidget style") main-GdkWindow) + (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")) @@ -238,8 +375,7 @@ USA. (define (scm-layout-event widget) (named-lambda (scm-layout::event GtkWidget GdkEvent) - GtkWidget widget ;;Ignored, thus far. -;;; (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n") + (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n") (let ((type (C-> GdkEvent "GdkEvent any type"))) @@ -276,10 +412,9 @@ USA. (define (scm-layout-set-scroll-adjustments widget) (named-lambda (scm-layout::set-scroll-adjustments GtkWidget hGtkAdjustment vGtkAdjustment) - GtkWidget ;;Ignored. + (trace ";((scm-layout-set-scroll-adjustments "widget")" + " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n") -;;; (trace ";((scm-layout-set-scroll-adjustments "widget")" -;;; " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n") (let ((haddr (alien/address-string hGtkAdjustment)) (vaddr (alien/address-string vGtkAdjustment))) (trace "; Adjustments: 0x"haddr" 0x"vaddr"\n")) @@ -315,10 +450,8 @@ USA. (define (scm-layout-adjustment-value-changed widget adjustment) (named-lambda (scm-layout::adjustment-value-changed GtkAdjustment) - GtkAdjustment ;;Ignored. - -;;; (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")" -;;; " "GtkAdjustment")\n") + (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")" + " "GtkAdjustment")\n") (let ((alien-widget (gobject-alien widget)) (alien-window (scm-layout-window widget)) @@ -363,7 +496,7 @@ USA. " (not "vadjustment" nor "hadjustment")."))))))) (define (adjust-adjustments widget) - ;; Called when the widget gets new adjustments or its size or + ;; Called after the widget gets new adjustment(s) or its size or ;; scrollable area changes. (let ((hadj (scm-layout-hadjustment widget)) @@ -409,7 +542,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 "drawing" "item")\n") + (trace ";(drawing-damage "item")\n") (let ((area (if (default-object? rect) (drawn-item-area item) @@ -575,7 +708,7 @@ USA. (define-method drawn-item-expose ((item ) widget window area) area ;;Ignored. Assumed clipping already set. -;;; (trace "; (Re)Drawing "item" on "widget".\n") + (trace "; (Re)Drawing "item" on "widget".\n") (let ((widgets (drawn-item-widgets item))) (if (or (eq? #f widgets) @@ -637,7 +770,7 @@ USA. (define-method drawn-item-expose ((item ) widget window area) area ;;Ignored. Assumed clipping already set. -;;; (trace "; (Re)Drawing "item" on "widget".\n") + (trace "; (Re)Drawing "item" on "widget".\n") (let ((widgets (drawn-item-widgets item))) (if (or (eq? #f widgets) @@ -670,7 +803,7 @@ USA. (define-method drawn-item-expose ((item ) widget window area) area ;;Ignored. Assumed clipping already set. -;;; (trace "; (Re)Drawing "item" on "widget".\n") + (trace "; (Re)Drawing "item" on "widget".\n") (let ((widgets (drawn-item-widgets item))) (if (or (eq? #f widgets) @@ -727,7 +860,7 @@ USA. (define-method drawn-item-expose ((item ) widget window area) area ;;Ignored. Assumed clipping already set. -;;; (trace "; (Re)Drawing "item" on "widget".\n") + (trace "; (Re)Drawing "item" on "widget".\n") (let ((widgets (drawn-item-widgets item))) (if (or (eq? #f widgets) @@ -854,7 +987,7 @@ USA. unspecific)))) (define-method drawn-item-expose ((item ) widget window area) -;;; (trace "; (Re)Drawing "item" on "widget".\n") + (trace "; (Re)Drawing "item" on "widget".\n") (let ((widgets (drawn-item-widgets item))) (if (or (eq? #f widgets) @@ -901,14 +1034,14 @@ USA. (else (ferror "The WHERE argument ("where") must be TOP (or #f)" " or BOTTOM if it is not optional.")))) -(define (check-non-negative-fixnum obj) +(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 (check-non-negative-integer obj) +(define-integrable (check-non-negative-integer obj) (if (integer? obj) (if (int:negative? obj) (ferror "Not a NON-NEGATIVE integer: "obj) @@ -916,6 +1049,7 @@ USA. (ferror "Not a non-negative integer: "obj))) (define trace? #f) -(define (trace . objects) - (if trace? - (apply outf-console objects))) \ No newline at end of file + +(define-syntax trace + (syntax-rules () + ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file -- 2.25.1