helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/ml_gtk.c

   1 /* $Id$ */
   2
   3 #include <string.h>
   4 #include <gtk/gtk.h>
   5 #include <caml/mlvalues.h>
   6 #include <caml/alloc.h>
   7 #include <caml/memory.h>
   8 #include <caml/callback.h>
   9 #include <caml/fail.h>
  10
  11 #include "wrappers.h"
  12 #include "ml_glib.h"
  13 #include "ml_gdk.h"
  14 #include "ml_gtk.h"
  15 #include "gtk_tags.h"
  16
  17 void ml_raise_gtk (const char *errmsg)
  18 {
  19   static value * exn = NULL;
  20   if (exn == NULL)
  21       exn = caml_named_value ("gtkerror");
  22   raise_with_string (*exn, (char*)errmsg);
  23 }
  24
  25 /* conversion functions */
  26
  27 #include "gtk_tags.c"
  28
  29 ML_1 (Val_direction_type, Int_val, Id)
  30 ML_1 (Val_orientation, Int_val, Id)
  31 ML_1 (Val_toolbar_style, Int_val, Id)
  32 ML_1 (Val_state_type, Int_val, Id)
  33 ML_1 (Val_scroll_type, Int_val, Id)
  34
  35 static Make_Flags_val (Dest_defaults_val)
  36 static Make_Flags_val (Target_flags_val)
  37 static Make_Flags_val (Font_type_val)
  38
  39 /* gtkobject.h */
  40
  41 Make_Val_final_pointer(GtkObject, gtk_object_ref, gtk_object_unref, 0)
  42
  43 #define gtk_object_ref_and_sink(w) (gtk_object_ref(w), gtk_object_sink(w))
  44 Make_Val_final_pointer_ext(GtkObject, _sink , gtk_object_ref_and_sink,
  45                            gtk_object_unref, 20)
  46
  47 /* gtkaccelgroup.h */
  48
  49 Make_Val_final_pointer (GtkAccelGroup, gtk_accel_group_ref,
  50                         gtk_accel_group_unref, 0)
  51 Make_Val_final_pointer_ext (GtkAccelGroup, _no_ref, Ignore,
  52                             gtk_accel_group_unref, 20)
  53 Make_OptFlags_val (Accel_flag_val)
  54
  55 #define Signal_name_val(val) String_val(Field(val,0))
  56
  57 ML_0 (gtk_accel_group_new, Val_GtkAccelGroup_no_ref)
  58 ML_0 (gtk_accel_group_get_default, Val_GtkAccelGroup)
  59 ML_3 (gtk_accel_group_activate, GtkAccelGroup_val, Int_val,
  60       OptFlags_GdkModifier_val, Val_bool)
  61 ML_3 (gtk_accel_groups_activate, GtkObject_val, Int_val,
  62       OptFlags_GdkModifier_val, Val_bool)
  63 ML_2 (gtk_accel_group_attach, GtkAccelGroup_val, GtkObject_val, Unit)
  64 ML_2 (gtk_accel_group_detach, GtkAccelGroup_val, GtkObject_val, Unit)
  65 ML_1 (gtk_accel_group_lock, GtkAccelGroup_val, Unit)
  66 ML_1 (gtk_accel_group_unlock, GtkAccelGroup_val, Unit)
  67 ML_3 (gtk_accel_group_lock_entry, GtkAccelGroup_val, Int_val,
  68       OptFlags_GdkModifier_val, Unit)
  69 ML_3 (gtk_accel_group_unlock_entry, GtkAccelGroup_val, Int_val,
  70       OptFlags_GdkModifier_val, Unit)
  71 ML_6 (gtk_accel_group_add, GtkAccelGroup_val, Int_val,
  72       OptFlags_GdkModifier_val, OptFlags_Accel_flag_val,
  73       GtkObject_val, Signal_name_val, Unit)
  74 ML_bc6 (ml_gtk_accel_group_add)
  75 ML_4 (gtk_accel_group_remove, GtkAccelGroup_val, Int_val,
  76       OptFlags_GdkModifier_val, GtkObject_val, Unit)
  77 ML_2 (gtk_accelerator_valid, Int_val, OptFlags_GdkModifier_val, Val_bool)
  78 ML_1 (gtk_accelerator_set_default_mod_mask, OptFlags_GdkModifier_val, Unit)
  79
  80 /* gtkstyle.h */
  81
  82 Make_Val_final_pointer (GtkStyle, gtk_style_ref, gtk_style_unref, 0)
  83 Make_Val_final_pointer_ext (GtkStyle, _no_ref, Ignore, gtk_style_unref, 20)
  84 ML_0 (gtk_style_new, Val_GtkStyle_no_ref)
  85 ML_1 (gtk_style_copy, GtkStyle_val, Val_GtkStyle_no_ref)
  86 ML_2 (gtk_style_attach, GtkStyle_val, GdkWindow_val, Val_GtkStyle)
  87 ML_1 (gtk_style_detach, GtkStyle_val, Unit)
  88 ML_3 (gtk_style_set_background, GtkStyle_val, GdkWindow_val, State_type_val, Unit)
  89 ML_6 (gtk_draw_hline, GtkStyle_val, GdkWindow_val, State_type_val,
  90       Int_val, Int_val, Int_val, Unit)
  91 ML_bc6 (ml_gtk_draw_hline)
  92 ML_6 (gtk_draw_vline, GtkStyle_val, GdkWindow_val, State_type_val,
  93       Int_val, Int_val, Int_val, Unit)
  94 ML_bc6 (ml_gtk_draw_vline)
  95 Make_Array_Extractor (gtk_style_get, GtkStyle_val, State_type_val,  bg, Val_copy)
  96 Make_Array_Setter (gtk_style_set, GtkStyle_val, State_type_val, *GdkColor_val, bg)
  97 Make_Extractor (gtk_style_get, GtkStyle_val, colormap, Val_GdkColormap)
  98 Make_Extractor (gtk_style_get, GtkStyle_val, depth, Val_int)
  99 Make_Extractor (gtk_style_get, GtkStyle_val, font, Val_GdkFont)
 100 /* Make_Setter (gtk_style_set, GtkStyle_val, GdkFont_val, font) */
 101 value ml_gtk_style_set_font (value st, value font)
 102 {
 103     GtkStyle *style = GtkStyle_val(st);
 104     if (style->font) gdk_font_unref(style->font);
 105     style->font = GdkFont_val(font);
 106     gdk_font_ref(style->font);
 107     return Val_unit;
 108 }
 109 Make_Array_Extractor (gtk_style_get, GtkStyle_val, State_type_val,  dark_gc, Val_GdkGC)
 110 Make_Array_Extractor (gtk_style_get, GtkStyle_val, State_type_val,  light_gc, Val_GdkGC)
 111
 112 /* gtktypeutils.h */
 113
 114 ML_1 (gtk_type_name, Int_val, Val_string)
 115 ML_1 (gtk_type_from_name, String_val, Val_int)
 116 ML_1 (gtk_type_parent, Int_val, Val_int)
 117 ML_1 (gtk_type_class, Int_val, (value))
 118 ML_1 (gtk_type_parent_class, Int_val, (value))
 119 ML_2 (gtk_type_is_a, Int_val, Int_val, Val_bool)
 120 value ml_gtk_type_fundamental (value type)
 121 {
 122     return Val_fundamental_type (GTK_FUNDAMENTAL_TYPE (Int_val(type)));
 123 }
 124
 125 /* gtkobject.h */
 126
 127 /* ML_1 (GTK_OBJECT_TYPE, GtkObject_val, Val_int) */
 128 value ml_gtk_object_type (value val)
 129 {
 130     return Val_int (GtkObject_val(val)->klass->type);
 131 }
 132
 133 ML_1 (gtk_object_destroy, GtkObject_val, Unit)
 134 ML_1 (gtk_object_ref, GtkObject_val, Unit)
 135 ML_1 (gtk_object_unref, GtkObject_val, Unit)
 136 ML_1 (gtk_object_sink, GtkObject_val, Unit)
 137
 138 Make_Extractor (gtk_class,(GtkObjectClass *),type,Val_int)
 139
 140 /* gtkdata.h */
 141
 142 /* gtkadjustment.h */
 143
 144 ML_6 (gtk_adjustment_new, Float_val, Float_val, Float_val, Float_val,
 145       Float_val, Float_val, Val_GtkObject_sink)
 146 ML_bc6 (ml_gtk_adjustment_new)
 147 ML_2 (gtk_adjustment_set_value, GtkAdjustment_val, Float_val, Unit)
 148 ML_3 (gtk_adjustment_clamp_page, GtkAdjustment_val,
 149       Float_val, Float_val, Unit)
 150 Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, lower, copy_double)
 151 Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, upper, copy_double)
 152 Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, value, copy_double)
 153 Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, step_increment,
 154                 copy_double)
 155 Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, page_increment,
 156                 copy_double)
 157 Make_Extractor (gtk_adjustment_get, GtkAdjustment_val, page_size, copy_double)
 158
 159 /* gtktooltips.h */
 160
 161 #define GtkTooltips_val(val) check_cast(GTK_TOOLTIPS,val)
 162 ML_0 (gtk_tooltips_new, Val_GtkAny)
 163 ML_1 (gtk_tooltips_enable, GtkTooltips_val, Unit)
 164 ML_1 (gtk_tooltips_disable, GtkTooltips_val, Unit)
 165 ML_2 (gtk_tooltips_set_delay, GtkTooltips_val, Int_val, Unit)
 166 ML_4 (gtk_tooltips_set_tip, GtkTooltips_val, GtkWidget_val,
 167       String_option_val, String_option_val, Unit)
 168 ML_3 (gtk_tooltips_set_colors, GtkTooltips_val,
 169       Option_val(arg2, GdkColor_val, NULL) Ignore,
 170       Option_val(arg3, GdkColor_val, NULL) Ignore,
 171       Unit)
 172
 173 /* gtkwidget.h */
 174
 175 value ml_gtk_widget_set_can_default (value val, value bool)
 176 {
 177     GtkWidget *w = GtkWidget_val(val);
 178     guint32 saved_flags = GTK_WIDGET_FLAGS(w);
 179     if (Bool_val(bool)) GTK_WIDGET_SET_FLAGS(w, GTK_CAN_DEFAULT);
 180     else GTK_WIDGET_UNSET_FLAGS(w, GTK_CAN_DEFAULT);
 181     if (saved_flags != GTK_WIDGET_FLAGS(w))
 182         gtk_widget_queue_resize (w);
 183     return Val_unit;
 184 }
 185 value ml_gtk_widget_set_can_focus (value val, value bool)
 186 {
 187     GtkWidget *w = GtkWidget_val(val);
 188     guint32 saved_flags = GTK_WIDGET_FLAGS(w);
 189     if (Bool_val(bool)) GTK_WIDGET_SET_FLAGS(w, GTK_CAN_FOCUS);
 190     else GTK_WIDGET_UNSET_FLAGS(w, GTK_CAN_FOCUS);
 191     if (saved_flags != GTK_WIDGET_FLAGS(w))
 192         gtk_widget_queue_resize (w);
 193     return Val_unit;
 194 }
 195 ML_1 (gtk_widget_unparent, GtkWidget_val, Unit)
 196 ML_1 (gtk_widget_show, GtkWidget_val, Unit)
 197 ML_1 (gtk_widget_show_now, GtkWidget_val, Unit)
 198 ML_1 (gtk_widget_show_all, GtkWidget_val, Unit)
 199 ML_1 (gtk_widget_hide, GtkWidget_val, Unit)
 200 ML_1 (gtk_widget_hide_all, GtkWidget_val, Unit)
 201 ML_1 (gtk_widget_map, GtkWidget_val, Unit)
 202 ML_1 (gtk_widget_unmap, GtkWidget_val, Unit)
 203 ML_1 (gtk_widget_realize, GtkWidget_val, Unit)
 204 ML_1 (gtk_widget_unrealize, GtkWidget_val, Unit)
 205 ML_1 (gtk_widget_queue_draw, GtkWidget_val, Unit)
 206 ML_1 (gtk_widget_queue_resize, GtkWidget_val, Unit)
 207 ML_2 (gtk_widget_draw, GtkWidget_val,
 208       Option_val(arg2,GdkRectangle_val,NULL) Ignore, Unit)
 209 ML_1 (gtk_widget_draw_focus, GtkWidget_val, Unit)
 210 ML_1 (gtk_widget_draw_default, GtkWidget_val, Unit)
 211 /* ML_1 (gtk_widget_draw_children, GtkWidget_val, Unit) */
 212 ML_2 (gtk_widget_event, GtkWidget_val, GdkEvent_val, Val_bool)
 213 ML_1 (gtk_widget_activate, GtkWidget_val, Val_bool)
 214 ML_2 (gtk_widget_reparent, GtkWidget_val, GtkWidget_val, Unit)
 215 ML_3 (gtk_widget_popup, GtkWidget_val, Int_val, Int_val, Unit)
 216 value ml_gtk_widget_intersect (value w, value area)
 217 {
 218     GdkRectangle inter;
 219     if (gtk_widget_intersect(GtkWidget_val(w), GdkRectangle_val(area), &inter))
 220         return ml_some (Val_copy (inter));
 221     return Val_unit;
 222 }
 223 /* ML_1 (gtk_widget_basic, GtkWidget_val, Val_bool) */
 224 ML_1 (gtk_widget_grab_focus, GtkWidget_val, Unit)
 225 ML_1 (gtk_widget_grab_default, GtkWidget_val, Unit)
 226 ML_2 (gtk_widget_set_name, GtkWidget_val, String_val, Unit)
 227 ML_1 (gtk_widget_get_name, GtkWidget_val, Val_string)
 228 ML_2 (gtk_widget_set_state, GtkWidget_val, State_type_val, Unit)
 229 ML_2 (gtk_widget_set_sensitive, GtkWidget_val, Bool_val, Unit)
 230 ML_3 (gtk_widget_set_uposition, GtkWidget_val, Int_val, Int_val, Unit)
 231 ML_3 (gtk_widget_set_usize, GtkWidget_val, Int_val, Int_val, Unit)
 232 ML_2 (gtk_widget_add_events, GtkWidget_val, Flags_Event_mask_val, Unit)
 233 ML_2 (gtk_widget_set_events, GtkWidget_val, Flags_Event_mask_val, Unit)
 234 ML_2 (gtk_widget_set_extension_events, GtkWidget_val, Extension_events_val,
 235       Unit)
 236 ML_1 (gtk_widget_get_toplevel, GtkWidget_val, Val_GtkWidget)
 237 ML_2 (gtk_widget_get_ancestor, GtkWidget_val, Int_val, Val_GtkWidget)
 238 ML_1 (gtk_widget_get_colormap, GtkWidget_val, Val_GdkColormap)
 239 ML_1 (gtk_widget_get_visual, GtkWidget_val, (value))
 240 value ml_gtk_widget_get_pointer (value w)
 241 {
 242     int x,y;
 243     value ret;
 244     gtk_widget_get_pointer (GtkWidget_val(w), &x, &y);
 245     ret = alloc_small (2,0);
 246     Field(ret,0) = Val_int(x);
 247     Field(ret,1) = Val_int(y);
 248     return ret;
 249 }
 250 ML_2 (gtk_widget_is_ancestor, GtkWidget_val, GtkWidget_val, Val_bool)
 251 /* ML_2 (gtk_widget_is_child, GtkWidget_val, GtkWidget_val, Val_bool) */
 252 ML_2 (gtk_widget_set_style, GtkWidget_val, GtkStyle_val, Unit)
 253 ML_1 (gtk_widget_set_rc_style, GtkWidget_val, Unit)
 254 ML_1 (gtk_widget_ensure_style, GtkWidget_val, Unit)
 255 ML_1 (gtk_widget_get_style, GtkWidget_val, Val_GtkStyle)
 256 ML_1 (gtk_widget_restore_default_style, GtkWidget_val, Unit)
 257
 258 ML_6 (gtk_widget_add_accelerator, GtkWidget_val, Signal_name_val,
 259       GtkAccelGroup_val, Char_val, OptFlags_GdkModifier_val,
 260       OptFlags_Accel_flag_val, Unit)
 261 ML_bc6 (ml_gtk_widget_add_accelerator)
 262 ML_4 (gtk_widget_remove_accelerator, GtkWidget_val, GtkAccelGroup_val,
 263       Char_val, OptFlags_GdkModifier_val, Unit)
 264 ML_1 (gtk_widget_lock_accelerators, GtkWidget_val, Unit)
 265 ML_1 (gtk_widget_unlock_accelerators, GtkWidget_val, Unit)
 266 ML_1 (gtk_widget_accelerators_locked, GtkWidget_val, Val_bool)
 267
 268 ML_1 (GTK_WIDGET_VISIBLE, GtkWidget_val, Val_bool)
 269 ML_1 (GTK_WIDGET_HAS_FOCUS, GtkWidget_val, Val_bool)
 270
 271 Make_Extractor (GtkWidget, GtkWidget_val, window, Val_GdkWindow)
 272 Make_Extractor (gtk_widget, GtkWidget_val, parent, Val_GtkWidget)
 273 static value Val_GtkAllocation (GtkAllocation allocation)
 274 {
 275     value ret = alloc_small (4, 0);
 276     Field(ret,0) = Val_int(allocation.x);
 277     Field(ret,1) = Val_int(allocation.y);
 278     Field(ret,2) = Val_int(allocation.width);
 279     Field(ret,3) = Val_int(allocation.height);
 280     return ret;
 281 }
 282 Make_Extractor (gtk_widget, GtkWidget_val, allocation, Val_GtkAllocation)
 283 /*
 284 #define GtkAllocation_val(val) ((GtkAllocation*)Pointer_val(val))
 285 Make_Extractor (gtk_allocation, GtkAllocation_val, x, Val_int)
 286 Make_Extractor (gtk_allocation, GtkAllocation_val, y, Val_int)
 287 Make_Extractor (gtk_allocation, GtkAllocation_val, width, Val_int)
 288 Make_Extractor (gtk_allocation, GtkAllocation_val, height, Val_int)
 289 */
 290
 291 ML_2 (gtk_widget_set_app_paintable, GtkWidget_val, Bool_val, Unit)
 292
 293 ML_2 (gtk_widget_set_visual, GtkWidget_val, GdkVisual_val, Unit)
 294 ML_2 (gtk_widget_set_colormap, GtkWidget_val, GdkColormap_val, Unit)
 295 ML_1 (gtk_widget_set_default_visual, GdkVisual_val, Unit)
 296 ML_1 (gtk_widget_set_default_colormap, GdkColormap_val, Unit)
 297 ML_0 (gtk_widget_get_default_visual, Val_GdkVisual)
 298 ML_0 (gtk_widget_get_default_colormap, Val_GdkColormap)
 299 ML_1 (gtk_widget_push_visual, GdkVisual_val, Unit)
 300 ML_1 (gtk_widget_push_colormap, GdkColormap_val, Unit)
 301 ML_0 (gtk_widget_pop_visual, Unit)
 302 ML_0 (gtk_widget_pop_colormap, Unit)
 303
 304 /* gtkdnd.h */
 305
 306 value ml_gtk_drag_dest_set (value w, value f, value t, value a)
 307 {
 308   GtkTargetEntry *targets = (GtkTargetEntry *)Val_unit;
 309   int n_targets, i;
 310
 311   CAMLparam4 (w,f,t,a);
 312   n_targets = Wosize_val(t);
 313   if (n_targets)
 314       targets = (GtkTargetEntry *)
 315           alloc (Wosize_asize(n_targets * sizeof(GtkTargetEntry)),
 316                  Abstract_tag);
 317   for (i=0; i<n_targets; i++) {
 318     targets[i].target = String_val(Field(Field(t, i), 0));
 319     targets[i].flags = Flags_Target_flags_val(Field(Field(t, i), 1));
 320     targets[i].info = Int_val(Field(Field(t, i), 2));
 321   }
 322   gtk_drag_dest_set (GtkWidget_val(w), Flags_Dest_defaults_val(f),
 323                      targets, n_targets, Flags_GdkDragAction_val(a));
 324   CAMLreturn(Val_unit);
 325 }
 326 ML_1 (gtk_drag_dest_unset, GtkWidget_val, Unit)
 327 ML_4 (gtk_drag_finish, GdkDragContext_val, Bool_val, Bool_val, Int_val, Unit)
 328 ML_4 (gtk_drag_get_data, GtkWidget_val, GdkDragContext_val, Int_val, Int_val, Unit)
 329 ML_1 (gtk_drag_get_source_widget, GdkDragContext_val, Val_GtkWidget)
 330 ML_1 (gtk_drag_highlight, GtkWidget_val, Unit)
 331 ML_1 (gtk_drag_unhighlight, GtkWidget_val, Unit)
 332 ML_4 (gtk_drag_set_icon_widget, GdkDragContext_val, GtkWidget_val,
 333       Int_val, Int_val, Unit)
 334 ML_6 (gtk_drag_set_icon_pixmap, GdkDragContext_val, GdkColormap_val,
 335       GdkPixmap_val, Option_val(arg4, GdkBitmap_val, NULL) Ignore,
 336       Int_val, Int_val, Unit)
 337 ML_bc6 (ml_gtk_drag_set_icon_pixmap)
 338 ML_1 (gtk_drag_set_icon_default, GdkDragContext_val, Unit)
 339 ML_5 (gtk_drag_set_default_icon, GdkColormap_val,
 340       GdkPixmap_val, Option_val(arg3, GdkBitmap_val, NULL) Ignore,
 341       Int_val, Int_val, Unit)
 342 value ml_gtk_drag_source_set (value w, value m, value t, value a)
 343 {
 344   GtkTargetEntry *targets = (GtkTargetEntry *)Val_unit;
 345   int n_targets, i;
 346   CAMLparam4 (w,m,t,a);
 347
 348   n_targets = Wosize_val(t);
 349   if (n_targets)
 350       targets = (GtkTargetEntry *)
 351           alloc (Wosize_asize(n_targets * sizeof(GtkTargetEntry)),
 352                  Abstract_tag);
 353   for (i=0; i<n_targets; i++) {
 354     targets[i].target = String_val(Field(Field(t, i), 0));
 355     targets[i].flags = Flags_Target_flags_val(Field(Field(t, i), 1));
 356     targets[i].info = Int_val(Field(Field(t, i), 2));
 357   }
 358   gtk_drag_source_set (GtkWidget_val(w), OptFlags_GdkModifier_val(m),
 359                        targets, n_targets, Flags_GdkDragAction_val(a));
 360   CAMLreturn(Val_unit);
 361 }
 362 ML_4 (gtk_drag_source_set_icon, GtkWidget_val, GdkColormap_val,
 363       GdkPixmap_val, Option_val(arg4, GdkBitmap_val, NULL) Ignore, Unit)
 364 ML_1 (gtk_drag_source_unset, GtkWidget_val, Unit)
 365
 366 /* gtkwidget.h / gtkselection.h */
 367
 368 #define GtkSelectionData_val(val) ((GtkSelectionData *)Pointer_val(val))
 369
 370 Make_Extractor (gtk_selection_data, GtkSelectionData_val, selection, Val_int)
 371 Make_Extractor (gtk_selection_data, GtkSelectionData_val, target, Val_int)
 372 Make_Extractor (gtk_selection_data, GtkSelectionData_val, type, Val_int)
 373 Make_Extractor (gtk_selection_data, GtkSelectionData_val, format, Val_int)
 374 value ml_gtk_selection_data_get_data (value val)
 375 {
 376     value ret;
 377     GtkSelectionData *data = GtkSelectionData_val(val);
 378
 379     if (data->length < 0) ml_raise_null_pointer();
 380     ret = alloc_string (data->length);
 381     if (data->length) memcpy ((void*)ret, data->data, data->length);
 382     return ret;
 383 }
 384
 385 ML_4 (gtk_selection_data_set, GtkSelectionData_val, Int_val, Int_val,
 386       Insert((guchar*)String_option_val(arg4))
 387       Option_val(arg4, string_length, -1) Ignore,
 388       Unit)
 389
 390 /* gtkcontainer.h */
 391
 392 #define GtkContainer_val(val) check_cast(GTK_CONTAINER,val)
 393 ML_2 (gtk_container_set_border_width, GtkContainer_val, Int_val, Unit)
 394 ML_2 (gtk_container_set_resize_mode, GtkContainer_val, Resize_mode_val, Unit)
 395 ML_2 (gtk_container_add, GtkContainer_val, GtkWidget_val, Unit)
 396 ML_2 (gtk_container_remove, GtkContainer_val, GtkWidget_val, Unit)
 397 static void ml_gtk_simple_callback (GtkWidget *w, gpointer data)
 398 {
 399     value val, *clos = (value*)data;
 400     val = Val_GtkWidget(w);
 401     callback (*clos, val);
 402 }
 403 value ml_gtk_container_foreach (value w, value clos)
 404 {
 405     CAMLparam1(clos);
 406     gtk_container_foreach (GtkContainer_val(w), ml_gtk_simple_callback,
 407                            &clos);
 408     CAMLreturn(Val_unit);
 409 }
 410 ML_1 (gtk_container_register_toplevel, GtkContainer_val, Unit)
 411 ML_1 (gtk_container_unregister_toplevel, GtkContainer_val, Unit)
 412 ML_2 (gtk_container_focus, GtkContainer_val, Direction_type_val, Val_bool)
 413 ML_2 (gtk_container_set_focus_child, GtkContainer_val, GtkWidget_val, Unit)
 414 ML_2 (gtk_container_set_focus_vadjustment, GtkContainer_val,
 415       GtkAdjustment_val, Unit)
 416 ML_2 (gtk_container_set_focus_hadjustment, GtkContainer_val,
 417       GtkAdjustment_val, Unit)
 418
 419 /* gtkdialog.h */
 420
 421 static void window_unref (GtkObject *w)
 422 {
 423     /* If the window exists and is still not visible, then unreference twice.
 424        This should be enough to destroy it. */
 425     if (!GTK_OBJECT_DESTROYED(w) && !GTK_WIDGET_VISIBLE(w))
 426         gtk_object_unref (w);
 427     gtk_object_unref (w);
 428 }
 429 Make_Val_final_pointer_ext (GtkObject, _window, gtk_object_ref, window_unref,
 430                             20)
 431 #define Val_GtkWidget_window(w) Val_GtkObject_window((GtkObject*)w)
 432
 433 #define GtkDialog_val(val) check_cast(GTK_DIALOG,val)
 434 ML_0 (gtk_dialog_new, Val_GtkWidget_window)
 435 Make_Extractor (GtkDialog, GtkDialog_val, action_area, Val_GtkWidget)
 436 Make_Extractor (GtkDialog, GtkDialog_val, vbox, Val_GtkWidget)
 437
 438 /* gtkinputdialog.h */
 439
 440 ML_0 (gtk_input_dialog_new, Val_GtkWidget_window)
 441
 442 /* gtkfileselection.h */
 443
 444 #define GtkFileSelection_val(val) check_cast(GTK_FILE_SELECTION,val)
 445 ML_1 (gtk_file_selection_new, String_val, Val_GtkWidget_window)
 446 ML_2 (gtk_file_selection_set_filename, GtkFileSelection_val, String_val, Unit)
 447 ML_1 (gtk_file_selection_get_filename, GtkFileSelection_val, Val_string)
 448 ML_1 (gtk_file_selection_show_fileop_buttons, GtkFileSelection_val, Unit)
 449 ML_1 (gtk_file_selection_hide_fileop_buttons, GtkFileSelection_val, Unit)
 450 Make_Extractor (gtk_file_selection_get, GtkFileSelection_val, ok_button,
 451                 Val_GtkWidget)
 452 Make_Extractor (gtk_file_selection_get, GtkFileSelection_val, cancel_button,
 453                 Val_GtkWidget)
 454 Make_Extractor (gtk_file_selection_get, GtkFileSelection_val, help_button,
 455                 Val_GtkWidget)
 456
 457 /* gtkwindow.h */
 458
 459 #define GtkWindow_val(val) check_cast(GTK_WINDOW,val)
 460 ML_1 (gtk_window_new, Window_type_val, Val_GtkWidget_window)
 461 ML_2 (gtk_window_set_title, GtkWindow_val, String_val, Unit)
 462 ML_3 (gtk_window_set_wmclass, GtkWindow_val, String_val, String_val, Unit)
 463 Make_Extractor (gtk_window_get, GtkWindow_val, wmclass_name, Val_optstring)
 464 Make_Extractor (gtk_window_get, GtkWindow_val, wmclass_class, Val_optstring)
 465 ML_2 (gtk_window_set_focus, GtkWindow_val, GtkWidget_val, Unit)
 466 ML_2 (gtk_window_set_default, GtkWindow_val, GtkWidget_val, Unit)
 467 ML_4 (gtk_window_set_policy, GtkWindow_val, Bool_val, Bool_val, Bool_val, Unit)
 468 Make_Extractor (gtk_window_get, GtkWindow_val, allow_shrink, Val_bool)
 469 Make_Extractor (gtk_window_get, GtkWindow_val, allow_grow, Val_bool)
 470 Make_Extractor (gtk_window_get, GtkWindow_val, auto_shrink, Val_bool)
 471 ML_2 (gtk_window_add_accel_group, GtkWindow_val,
 472       GtkAccelGroup_val, Unit)
 473 ML_2 (gtk_window_remove_accel_group, GtkWindow_val,
 474       GtkAccelGroup_val, Unit)
 475 ML_1 (gtk_window_activate_focus, GtkWindow_val, Val_bool)
 476 ML_1 (gtk_window_activate_default, GtkWindow_val, Val_bool)
 477 ML_2 (gtk_window_set_modal, GtkWindow_val, Bool_val, Unit)
 478 ML_3 (gtk_window_set_default_size, GtkWindow_val, Int_val, Int_val, Unit)
 479 ML_2 (gtk_window_set_position, GtkWindow_val, Window_position_val, Unit)
 480 ML_2 (gtk_window_set_transient_for, GtkWindow_val, GtkWindow_val, Unit)
 481
 482 /* gtkcolorsel.h */
 483
 484 #define GtkColorSelection_val(val) check_cast(GTK_COLOR_SELECTION,val)
 485 #define GtkColorSelectionDialog_val(val) check_cast(GTK_COLOR_SELECTION_DIALOG,val)
 486 ML_0 (gtk_color_selection_new, Val_GtkWidget_sink)
 487 ML_2 (gtk_color_selection_set_update_policy, GtkColorSelection_val,
 488       Update_type_val, Unit)
 489 ML_2 (gtk_color_selection_set_opacity, GtkColorSelection_val,
 490       Bool_val, Unit)
 491 value ml_gtk_color_selection_set_color (value w, value red, value green,
 492                                         value blue, value opacity)
 493 {
 494     double color[4];
 495     color[0] = Double_val(red);
 496     color[1] = Double_val(green);
 497     color[2] = Double_val(blue);
 498     color[3] = Option_val(opacity,Double_val,0.0);
 499     gtk_color_selection_set_color (GtkColorSelection_val(w), color);
 500     return Val_unit;
 501 }
 502 value ml_gtk_color_selection_get_color (value w)
 503 {
 504     value ret;
 505     double color[4];
 506     color[3] = 0.0;
 507     gtk_color_selection_get_color (GtkColorSelection_val(w), color);
 508     ret = alloc (4*Double_wosize, Double_array_tag);
 509     Store_double_field (ret, 0, color[0]);
 510     Store_double_field (ret, 1, color[1]);
 511     Store_double_field (ret, 2, color[2]);
 512     Store_double_field (ret, 3, color[3]);
 513     return ret;
 514 }
 515 ML_1 (gtk_color_selection_dialog_new, String_val, Val_GtkWidget_window)
 516 Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, ok_button, Val_GtkWidget)
 517 Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, cancel_button, Val_GtkWidget)
 518 Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, help_button, Val_GtkWidget)
 519 Make_Extractor (gtk_color_selection_dialog, GtkColorSelectionDialog_val, colorsel, Val_GtkWidget)
 520
 521 /* gtkfontsel.h */
 522
 523 #define GtkFontSelection_val(val) \
 524    check_cast(GTK_FONT_SELECTION,val)
 525 ML_0 (gtk_font_selection_new, Val_GtkWidget_sink)
 526 ML_1 (gtk_font_selection_get_font, GtkFontSelection_val,
 527       Val_GdkFont)
 528 ML_1 (gtk_font_selection_get_font_name, GtkFontSelection_val,
 529       copy_string_check)
 530 ML_2 (gtk_font_selection_set_font_name, GtkFontSelection_val,
 531       String_val, Val_bool)
 532 ML_9 (gtk_font_selection_set_filter, GtkFontSelection_val,
 533       Font_filter_type_val, Flags_Font_type_val,
 534       (gchar**), (gchar**), (gchar**),
 535       (gchar**), (gchar**), (gchar**), Unit)
 536 ML_bc9 (ml_gtk_font_selection_set_filter)
 537 ML_1 (gtk_font_selection_get_preview_text, GtkFontSelection_val,
 538       copy_string)
 539 ML_2 (gtk_font_selection_set_preview_text, GtkFontSelection_val,
 540       String_val, Unit)
 541
 542 #define GtkFontSelectionDialog_val(val) \
 543    check_cast(GTK_FONT_SELECTION_DIALOG,val)
 544 ML_1 (gtk_font_selection_dialog_new, String_option_val, Val_GtkWidget_window)
 545 /*
 546 ML_1 (gtk_font_selection_dialog_get_font, GtkFontSelectionDialog_val,
 547       Val_GdkFont)
 548 ML_1 (gtk_font_selection_dialog_get_font_name, GtkFontSelectionDialog_val,
 549       copy_string_check)
 550 ML_2 (gtk_font_selection_dialog_set_font_name, GtkFontSelectionDialog_val,
 551       String_val, Val_bool)
 552 ML_9 (gtk_font_selection_dialog_set_filter, GtkFontSelectionDialog_val,
 553       Font_filter_type_val, Flags_Font_type_val,
 554       (gchar**), (gchar**), (gchar**),
 555       (gchar**), (gchar**), (gchar**), Unit)
 556 ML_bc9 (ml_gtk_font_selection_dialog_set_filter)
 557 ML_1 (gtk_font_selection_dialog_get_preview_text, GtkFontSelectionDialog_val,
 558       copy_string)
 559 ML_2 (gtk_font_selection_dialog_set_preview_text, GtkFontSelectionDialog_val,
 560       String_val, Unit)
 561 */
 562 Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
 563                 fontsel, Val_GtkWidget)
 564 Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
 565                 ok_button, Val_GtkWidget)
 566 Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
 567                 apply_button, Val_GtkWidget)
 568 Make_Extractor (gtk_font_selection_dialog, GtkFontSelectionDialog_val,
 569                 cancel_button, Val_GtkWidget)
 570
 571 /* gtkplug.h */
 572
 573 ML_1 (gtk_plug_new, XID_val, Val_GtkWidget_window)
 574
 575 /* gtkctree.h */
 576 #define GtkCTree_val(val) check_cast(GTK_CTREE,val)
 577 /* Beware: this definition axpects arg1 to be a GtkCTree */
 578 /*
 579 #define GtkCTreeNode_val(val) \
 580      (gtk_ctree_find(GtkCTree_val(arg1),NULL,(GtkCTreeNode*)(val-1)) \
 581      ? (GtkCTreeNode*)(val-1) : (ml_raise_gtk ("Bad GtkCTreeNode"), NULL))
 582 #define Val_GtkCTreeNode Val_addr
 583 ML_2 (gtk_ctree_new, Int_val, Int_val, Val_GtkWidget_sink)
 584 ML_3 (gtk_ctree_new_with_titles, Int_val, Int_val, (char **),
 585       Val_GtkWidget_sink)
 586 ML_11 (gtk_ctree_insert_node, GtkCTree_val, GtkCTreeNode_val,
 587        GtkCTreeNode_val, (char**), Int_val, GdkPixmap_val, GdkBitmap_val,
 588        GdkPixmap_val, GdkBitmap_val, Bool_val, Bool_val,
 589        Val_GtkCTreeNode)
 590 ML_2 (gtk_ctree_remove_node, GtkCTree_val, GtkCTreeNode_val, Unit)
 591 ML_2 (gtk_ctree_is_viewable, GtkCTree_val, GtkCTreeNode_val, Val_bool)
 592 */
 593
 594 /* gtkpreview.h */
 595 /*
 596 #define GtkPreview_val(val) GTK_PREVIEW(Pointer_val(val))
 597 ML_1 (gtk_preview_new, Preview_val, Val_GtkWidget_sink)
 598 ML_3 (gtk_preview_size, GtkPreview_val, Int_val, Int_val, Unit)
 599 ML_9 (gtk_preview_put, GtkPreview_val, GdkWindow_val, GdkGC_val,
 600       Int_val, Int_val, Int_val, Int_val, Int_val, Int_val, Unit)
 601 ML_bc9 (ml_gtk_preview_put)
 602 */
 603
 604 /* gtkmain.h */
 605
 606 value ml_gtk_init (value argv)
 607 {
 608     CAMLparam1 (argv);
 609     int argc = Wosize_val(argv), i;
 610     CAMLlocal1 (copy);
 611
 612     copy = (argc ? alloc (argc, Abstract_tag) : Atom(0));
 613     for (i = 0; i < argc; i++) Field(copy,i) = Field(argv,i);
 614     gtk_init (&argc, (char ***)&copy);
 615
 616     argv = (argc ? alloc (argc, 0) : Atom(0));
 617     for (i = 0; i < argc; i++) modify(&Field(argv,i), Field(copy,i));
 618     CAMLreturn (argv);
 619 }
 620 ML_1 (gtk_exit, Int_val, Unit)
 621 ML_0 (gtk_set_locale, Val_string)
 622 ML_0 (gtk_main, Unit)
 623 ML_1 (gtk_main_iteration_do, Bool_val, Val_bool)
 624 ML_0 (gtk_main_quit, Unit)
 625 ML_1 (gtk_grab_add, GtkWidget_val, Unit)
 626 ML_1 (gtk_grab_remove, GtkWidget_val, Unit)
 627 ML_0 (gtk_grab_get_current, Val_GtkWidget)
 628 value ml_gtk_get_version (value unit)
 629 {
 630     value ret = alloc_small(3,0);
 631     Field(ret,0) = Val_int(gtk_major_version);
 632     Field(ret,1) = Val_int(gtk_minor_version);
 633     Field(ret,2) = Val_int(gtk_micro_version);
 634     return ret;
 635 }
 636
 637 /* Marshalling */
 638
 639 void ml_gtk_callback_marshal (GtkObject *object, gpointer data,
 640                                guint nargs, GtkArg *args)
 641 {
 642     value vargs = alloc_small(3,0);
 643
 644     CAMLparam1 (vargs);
 645     Field(vargs,0) = (value) object;
 646     Field(vargs,1) = Val_int(nargs);
 647     Field(vargs,2) = (value) args;
 648
 649     callback (*(value*)data, vargs);
 650
 651     Field(vargs,0) = Val_int(-1);
 652     Field(vargs,1) = Val_int(-1);
 653     CAMLreturn0;
 654 }
 655
 656 value ml_gtk_arg_shift (GtkArg *args, value index)
 657 {
 658     return (value) (&args[Int_val(index)]);
 659 }
 660
 661 value ml_gtk_arg_get_type (GtkArg *arg)
 662 {
 663     return Val_int (arg->type);
 664 }
 665
 666 value ml_gtk_arg_get (GtkArg *arg)
 667 {
 668     CAMLparam0();
 669     CAMLlocal1(tmp);
 670     value ret = Val_unit;
 671     GtkFundamentalType type = GTK_FUNDAMENTAL_TYPE(arg->type);
 672     int tag;
 673
 674     switch (type) {
 675     case GTK_TYPE_CHAR:
 676         tag = 0;
 677         tmp = Int_val(GTK_VALUE_CHAR(*arg));
 678         break;
 679     case GTK_TYPE_BOOL:
 680         tag = 1;
 681         tmp = Val_bool(GTK_VALUE_BOOL(*arg));
 682         break;
 683     case GTK_TYPE_INT:
 684     case GTK_TYPE_ENUM:
 685     case GTK_TYPE_UINT:
 686     case GTK_TYPE_FLAGS:
 687         tag = 2;
 688         tmp = Val_int (GTK_VALUE_INT(*arg)); break;
 689     case GTK_TYPE_LONG:
 690     case GTK_TYPE_ULONG:
 691         tag = 2;
 692         tmp = Val_int (GTK_VALUE_LONG(*arg)); break;
 693     case GTK_TYPE_FLOAT:
 694         tag = 3;
 695         tmp = copy_double ((double)GTK_VALUE_FLOAT(*arg)); break;
 696     case GTK_TYPE_DOUBLE:
 697         tag = 3;
 698         tmp = copy_double (GTK_VALUE_DOUBLE(*arg)); break;
 699     case GTK_TYPE_STRING:
 700         tag = 4;
 701         tmp = Val_option (GTK_VALUE_STRING(*arg), copy_string); break;
 702     case GTK_TYPE_OBJECT:
 703         tag = 5;
 704         tmp = Val_option (GTK_VALUE_OBJECT(*arg), Val_GtkObject); break;
 705     case GTK_TYPE_BOXED:
 706     case GTK_TYPE_POINTER:
 707         tag = 6;
 708         tmp = Val_option (GTK_VALUE_POINTER(*arg), Val_pointer); break;
 709     default:
 710         tag = -1;
 711     }
 712     if (tag != -1) {
 713         ret = alloc_small(1,tag);
 714         Field(ret,0) = tmp;
 715     }
 716     CAMLreturn(ret);
 717 }
 718
 719 value ml_gtk_arg_set_retloc (GtkArg *arg, value val)
 720 {
 721     value type = Fundamental_type_val(Is_block(val) ? Field(val,0) : val);
 722     value data = (Is_block(val) ? Field(val,1) : 0);
 723     if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_POINTER
 724         && GTK_FUNDAMENTAL_TYPE(arg->type) != type)
 725         ml_raise_gtk ("GtkArgv.Arg.set : argument type mismatch");
 726     switch (type) {
 727     case GTK_TYPE_CHAR:   *GTK_RETLOC_CHAR(*arg) = Int_val(data); break;
 728     case GTK_TYPE_BOOL:   *GTK_RETLOC_BOOL(*arg) = Int_val(data); break;
 729     case GTK_TYPE_INT:
 730     case GTK_TYPE_ENUM:   *GTK_RETLOC_INT(*arg) = Int_val(data); break;
 731     case GTK_TYPE_UINT:
 732     case GTK_TYPE_FLAGS:  *GTK_RETLOC_UINT(*arg) = Int32_val(data); break;
 733     case GTK_TYPE_LONG:
 734     case GTK_TYPE_ULONG:  *GTK_RETLOC_LONG(*arg) = Nativeint_val(data); break;
 735     case GTK_TYPE_FLOAT:  *GTK_RETLOC_FLOAT(*arg) = Float_val(data); break;
 736     case GTK_TYPE_DOUBLE: *GTK_RETLOC_DOUBLE(*arg) = Double_val(data); break;
 737     case GTK_TYPE_STRING:
 738          *GTK_RETLOC_STRING(*arg) = Option_val(data, String_val, NULL);
 739          break;
 740     case GTK_TYPE_BOXED:
 741     case GTK_TYPE_POINTER:
 742     case GTK_TYPE_OBJECT:
 743          *GTK_RETLOC_POINTER(*arg) = Option_val(data, Pointer_val, NULL);
 744          break;
 745     }
 746     return Val_unit;
 747 }
 748
 749 /*
 750 value ml_gtk_arg_get_char (GtkArg *arg)
 751 {
 752     if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_CHAR)
 753         ml_raise_gtk ("argument type mismatch");
 754     return Val_char (GTK_VALUE_CHAR(*arg));
 755 }
 756
 757 value ml_gtk_arg_get_bool (GtkArg *arg)
 758 {
 759     if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_BOOL)
 760         ml_raise_gtk ("argument type mismatch");
 761     return Val_bool (GTK_VALUE_BOOL(*arg));
 762 }
 763
 764 value ml_gtk_arg_get_int (GtkArg *arg)
 765 {
 766     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 767     case GTK_TYPE_INT:
 768     case GTK_TYPE_UINT:
 769         return Val_int (GTK_VALUE_INT(*arg));
 770     case GTK_TYPE_LONG:
 771     case GTK_TYPE_ULONG:
 772         return Val_long (GTK_VALUE_LONG(*arg));
 773     case GTK_TYPE_ENUM:
 774         return Val_int (GTK_VALUE_ENUM(*arg));
 775     case GTK_TYPE_FLAGS:
 776         return Val_int (GTK_VALUE_FLAGS(*arg));
 777     default:
 778         ml_raise_gtk ("argument type mismatch");
 779     }
 780     return Val_unit;
 781 }
 782 */
 783 value ml_gtk_arg_get_nativeint(GtkArg *arg) {
 784
 785      switch(GTK_FUNDAMENTAL_TYPE(arg->type)) {
 786      case GTK_TYPE_INT:
 787      case GTK_TYPE_UINT:
 788           return copy_nativeint (GTK_VALUE_INT(*arg));
 789      case GTK_TYPE_LONG:
 790      case GTK_TYPE_ULONG:
 791           return copy_nativeint (GTK_VALUE_LONG(*arg));
 792      case GTK_TYPE_ENUM:
 793           return copy_nativeint (GTK_VALUE_ENUM(*arg));
 794      case GTK_TYPE_FLAGS:
 795           return copy_nativeint (GTK_VALUE_FLAGS(*arg));
 796      default:
 797           ml_raise_gtk ("argument type mismatch");
 798      }
 799      return Val_unit;
 800 }
 801 /*
 802 value ml_gtk_arg_get_float (GtkArg *arg)
 803 {
 804     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 805     case GTK_TYPE_FLOAT:
 806         return copy_double ((double)GTK_VALUE_FLOAT(*arg));
 807     case GTK_TYPE_DOUBLE:
 808         return copy_double (GTK_VALUE_DOUBLE(*arg));
 809     default:
 810         ml_raise_gtk ("argument type mismatch");
 811     }
 812     return Val_unit;
 813 }
 814
 815 value ml_gtk_arg_get_string (GtkArg *arg)
 816 {
 817     char *p;
 818     if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_STRING)
 819         ml_raise_gtk ("argument type mismatch");
 820     p = GTK_VALUE_STRING(*arg);
 821     return Val_option (p, copy_string);
 822 }
 823 */
 824 value ml_gtk_arg_get_pointer (GtkArg *arg)
 825 {
 826     gpointer p = NULL;
 827     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 828     case GTK_TYPE_STRING:
 829     case GTK_TYPE_BOXED:
 830     case GTK_TYPE_POINTER:
 831     case GTK_TYPE_OBJECT:
 832         p = GTK_VALUE_POINTER(*arg); break;
 833     default:
 834         ml_raise_gtk ("GtkArgv.get_pointer : argument type mismatch");
 835     }
 836     return Val_pointer(p);
 837 }
 838 /*
 839 value ml_gtk_arg_get_object (GtkArg *arg)
 840 {
 841     GtkObject *p;
 842     if (GTK_FUNDAMENTAL_TYPE(arg->type) != GTK_TYPE_OBJECT)
 843         ml_raise_gtk ("argument type mismatch");
 844     p = GTK_VALUE_OBJECT(*arg);
 845     return Val_option (p, Val_GtkObject);
 846 }
 847 */
 848
 849 value ml_string_at_pointer (value ofs, value len, value ptr)
 850 {
 851     char *start = ((char*)Pointer_val(ptr)) + Option_val(ofs, Int_val, 0);
 852     int length = Option_val(len, Int_val, strlen(start));
 853     value ret = alloc_string(length);
 854     memcpy ((char*)ret, start, length);
 855     return ret;
 856 }
 857
 858 value ml_int_at_pointer (value ptr)
 859 {
 860     return Val_int(*(int*)Pointer_val(ptr));
 861 }
 862
 863 /*
 864 value ml_gtk_arg_set_char (GtkArg *arg, value val)
 865 {
 866     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 867     case GTK_TYPE_POINTER:
 868     case GTK_TYPE_CHAR:
 869          *GTK_RETLOC_CHAR(*arg) = Char_val(val); break;
 870     default:
 871         ml_raise_gtk ("argument type mismatch");
 872     }
 873     return Val_unit;
 874 }
 875
 876 value ml_gtk_arg_set_bool (GtkArg *arg, value val)
 877 {
 878     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 879     case GTK_TYPE_POINTER:
 880     case GTK_TYPE_BOOL:
 881          *GTK_RETLOC_BOOL(*arg) = Bool_val(val); break;
 882     default:
 883         ml_raise_gtk ("argument type mismatch");
 884     }
 885     return Val_unit;
 886 }
 887
 888 value ml_gtk_arg_set_int (GtkArg *arg, value val)
 889 {
 890     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 891     case GTK_TYPE_POINTER:
 892     case GTK_TYPE_INT:
 893     case GTK_TYPE_UINT:
 894         *GTK_RETLOC_INT(*arg) = Int_val(val); break;
 895     case GTK_TYPE_LONG:
 896     case GTK_TYPE_ULONG:
 897         *GTK_RETLOC_LONG(*arg) = Long_val(val); break;
 898     case GTK_TYPE_ENUM:
 899         *GTK_RETLOC_ENUM(*arg) = Int_val(val); break;
 900     case GTK_TYPE_FLAGS:
 901         *GTK_RETLOC_FLAGS(*arg) = Int_val(val); break;
 902     default:
 903         ml_raise_gtk ("argument type mismatch");
 904     }
 905     return Val_unit;
 906 }
 907
 908 value ml_gtk_arg_set_nativeint (GtkArg *arg, value val)
 909 {
 910     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 911     case GTK_TYPE_POINTER:
 912     case GTK_TYPE_INT:
 913     case GTK_TYPE_UINT:
 914         *GTK_RETLOC_INT(*arg) = Nativeint_val(val); break;
 915     case GTK_TYPE_LONG:
 916     case GTK_TYPE_ULONG:
 917         *GTK_RETLOC_LONG(*arg) = Nativeint_val(val); break;
 918     case GTK_TYPE_ENUM:
 919         *GTK_RETLOC_ENUM(*arg) = Nativeint_val(val); break;
 920     case GTK_TYPE_FLAGS:
 921         *GTK_RETLOC_FLAGS(*arg) = Nativeint_val(val); break;
 922     default:
 923         ml_raise_gtk ("argument type mismatch");
 924     }
 925     return Val_unit;
 926 }
 927
 928 value ml_gtk_arg_set_float (GtkArg *arg, value val)
 929 {
 930     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 931     case GTK_TYPE_POINTER:
 932     case GTK_TYPE_FLOAT:
 933         *GTK_RETLOC_FLOAT(*arg) = (float) Double_val(val); break;
 934     case GTK_TYPE_DOUBLE:
 935         *GTK_RETLOC_DOUBLE(*arg) = Double_val(val); break;
 936     default:
 937         ml_raise_gtk ("argument type mismatch");
 938     }
 939     return Val_unit;
 940 }
 941
 942 value ml_gtk_arg_set_string (GtkArg *arg, value val)
 943 {
 944     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 945     case GTK_TYPE_POINTER:
 946     case GTK_TYPE_STRING:
 947          *GTK_RETLOC_STRING(*arg) = String_val(val); break;
 948     default:
 949         ml_raise_gtk ("argument type mismatch");
 950     }
 951     return Val_unit;
 952 }
 953
 954 value ml_gtk_arg_set_pointer (GtkArg *arg, value val)
 955 {
 956     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 957     case GTK_TYPE_BOXED:
 958         *GTK_RETLOC_BOXED(*arg) = Pointer_val(val); break;
 959     case GTK_TYPE_POINTER:
 960         *GTK_RETLOC_POINTER(*arg) = Pointer_val(val); break;
 961     default:
 962         ml_raise_gtk ("argument type mismatch");
 963     }
 964     return Val_unit;
 965 }
 966
 967 value ml_gtk_arg_set_object (GtkArg *arg, value val)
 968 {
 969     switch (GTK_FUNDAMENTAL_TYPE(arg->type)) {
 970     case GTK_TYPE_POINTER:
 971     case GTK_TYPE_OBJECT:
 972          *GTK_RETLOC_OBJECT(*arg) = GtkObject_val(val); break;
 973     default:
 974         ml_raise_gtk ("argument type mismatch");
 975     }
 976     return Val_unit;
 977 }
 978 */
 979
 980 /* gtksignal.h */
 981
 982 value ml_gtk_signal_connect (value object, value name, value clos, value after)
 983 {
 984     value *clos_p = ml_global_root_new (clos);
 985     return Val_int (gtk_signal_connect_full
 986                     (GtkObject_val(object), String_val(name), NULL,
 987                      ml_gtk_callback_marshal, clos_p,
 988                      ml_global_root_destroy, FALSE, Bool_val(after)));
 989 }
 990
 991 ML_2 (gtk_signal_disconnect, GtkObject_val, Int_val, Unit)
 992 ML_2 (gtk_signal_emit_stop_by_name, GtkObject_val, String_val, Unit)
 993 ML_2 (gtk_signal_handler_block, GtkObject_val, Int_val, Unit)
 994 ML_2 (gtk_signal_handler_unblock, GtkObject_val, Int_val, Unit)
 995 ML_2_name (ml_gtk_signal_emit_none, gtk_signal_emit_by_name,
 996            GtkObject_val, String_val, Unit)
 997 ML_3_name (ml_gtk_signal_emit_int, gtk_signal_emit_by_name,
 998            GtkObject_val, String_val, Int_val, Unit)
 999 ML_4_name (ml_gtk_signal_emit_scroll, gtk_signal_emit_by_name,
1000            GtkObject_val, String_val, Scroll_type_val, Double_val, Unit)
1001
1002 /* gtkmain.h (again) */
1003
1004 value ml_gtk_timeout_add (value interval, value clos)
1005 {
1006     value *clos_p = ml_global_root_new (clos);
1007     return Val_int (gtk_timeout_add_full
1008                     (Int_val(interval), NULL, ml_gtk_callback_marshal, clos_p,
1009                      ml_global_root_destroy));
1010 }
1011 ML_1 (gtk_timeout_remove, Int_val, Unit)
1012
1013 ML_1 (gtk_rc_add_default_file, String_val, Unit)