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