helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/ml_glib.c

   1 /* $Id$ */
   2
   3 #include <glib.h>
   4 #include <caml/mlvalues.h>
   5 #include <caml/alloc.h>
   6 #include <caml/memory.h>
   7 #include <caml/callback.h>
   8
   9 #include "wrappers.h"
  10 #include "ml_glib.h"
  11
  12 /*
  13 value Val_GSList (GSList *list, value (*func)(gpointer))
  14 {
  15     value new_cell, result, last_cell, cell;
  16
  17     if (list == NULL) return Val_unit;
  18
  19     last_cell = cell = Val_unit;
  20     result = func(list->data);
  21     Begin_roots3 (last_cell, cell, result);
  22     cell = last_cell = alloc_tuple (2);
  23     Field(cell,0) = result;
  24     Field(cell,1) = Val_unit;
  25     list = list->next;
  26     while (list != NULL) {
  27         result = func(list->data);
  28         new_cell = alloc_tuple(2);
  29         Field(new_cell,0) = result;
  30         Field(new_cell,1) = Val_unit;
  31         modify(&Field(last_cell,1), new_cell);
  32         last_cell = new_cell;
  33         list = list->next;
  34     }
  35     End_roots ();
  36     return cell;
  37 }
  38
  39 GSList *GSList_val (value list, gpointer (*func)(value))
  40 {
  41     GSList *res = NULL;
  42     GSList **current = &res;
  43     value cell = list;
  44     if (list == Val_unit) return res;
  45     Begin_root (cell);
  46     while (cell != Val_unit) {
  47         *current = g_slist_alloc ();
  48         (*current)->data = func(Field(cell,0));
  49         cell = Field(cell,1);
  50         current = &(*current)->next;
  51     }
  52     End_roots ();
  53     return res;
  54 }
  55 */
  56
  57 value Val_GList (GList *list, value (*func)(gpointer))
  58 {
  59     value new_cell, result, last_cell, cell;
  60
  61     if (list == NULL) return Val_unit;
  62
  63     last_cell = cell = Val_unit;
  64     result = func(list->data);
  65     Begin_roots3 (last_cell, cell, result);
  66     cell = last_cell = alloc_small(2,0);
  67     Field(cell,0) = result;
  68     Field(cell,1) = Val_unit;
  69     list = list->next;
  70     while (list != NULL) {
  71         result = func(list->data);
  72         new_cell = alloc_small(2,0);
  73         Field(new_cell,0) = result;
  74         Field(new_cell,1) = Val_unit;
  75         modify(&Field(last_cell,1), new_cell);
  76         last_cell = new_cell;
  77         list = list->next;
  78     }
  79     End_roots ();
  80     return cell;
  81 }
  82
  83 GList *GList_val (value list, gpointer (*func)(value))
  84 {
  85     CAMLparam1(list);
  86     GList *res = NULL;
  87     if (list == Val_unit) CAMLreturn (res);
  88     for (; Is_block(list); list = Field(list,1))
  89       res = g_list_append (res, func(Field(list,0)));
  90     CAMLreturn (res);
  91 }
  92
  93 static value ml_warning_handler = 0L;
  94
  95 static void ml_warning_wrapper (const gchar *msg)
  96 {
  97     value arg = copy_string ((char*)msg);
  98     callback (ml_warning_handler, arg);
  99 }
 100
 101 value ml_g_set_warning_handler (value clos)
 102 {
 103     value old_handler = ml_warning_handler ? ml_warning_handler : clos;
 104     if (!ml_warning_handler) register_global_root (&ml_warning_handler);
 105     g_set_warning_handler (ml_warning_wrapper);
 106     ml_warning_handler = clos;
 107     return old_handler;
 108 }
 109
 110 static value ml_print_handler = 0L;
 111
 112 static void ml_print_wrapper (const gchar *msg)
 113 {
 114     value arg = copy_string ((char*)msg);
 115     callback (ml_print_handler, arg);
 116 }
 117
 118 value ml_g_set_print_handler (value clos)
 119 {
 120     value old_handler = ml_print_handler ? ml_print_handler : clos;
 121     if (!ml_print_handler) register_global_root (&ml_print_handler);
 122     g_set_print_handler (ml_print_wrapper);
 123     ml_print_handler = clos;
 124     return old_handler;
 125 }
 126
 127 value ml_get_null (value unit) { return 0L; }
 128
 129 #define GMainLoop_val(val) ((GMainLoop*)Addr_val(val))
 130 ML_1 (g_main_new, Bool_val, Val_addr)
 131 ML_1 (g_main_iteration, Bool_val, Val_bool)
 132 ML_0 (g_main_pending, Val_bool)
 133 ML_1 (g_main_is_running, GMainLoop_val, Val_bool)
 134 ML_1 (g_main_quit, GMainLoop_val, Unit)
 135 ML_1 (g_main_destroy, GMainLoop_val, Unit)