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

   1 /* $Id$ */
   2
   3 #include <string.h>
   4 #include <caml/mlvalues.h>
   5 #include <caml/alloc.h>
   6 #include <caml/memory.h>
   7 #include <caml/callback.h>
   8 #include <caml/fail.h>
   9
  10 #include "wrappers.h"
  11
  12 value copy_memblock_indirected (void *src, asize_t size)
  13 {
  14     value ret = alloc (Wosize_asize(size)+2, Abstract_tag);
  15     if (!src) ml_raise_null_pointer ();
  16
  17     Field(ret,1) = 2;
  18     memcpy (&Field(ret,2), src, size);
  19     return ret;
  20 }
  21
  22 value ml_some (value v)
  23 {
  24      CAMLparam1(v);
  25      value ret = alloc_small(1,0);
  26      Field(ret,0) = v;
  27      CAMLreturn(ret);
  28 }
  29
  30 void ml_raise_null_pointer ()
  31 {
  32   static value * exn = NULL;
  33   if (exn == NULL)
  34       exn = caml_named_value ("null_pointer");
  35   raise_constant (*exn);
  36 }
  37
  38 value Val_pointer (void *ptr)
  39 {
  40     value ret = alloc_small (2, Abstract_tag);
  41     if (!ptr) ml_raise_null_pointer ();
  42     Field(ret,1) = (value)ptr;
  43     return ret;
  44 }
  45
  46 value copy_string_check (const char*str)
  47 {
  48     if (!str) ml_raise_null_pointer ();
  49     return copy_string ((char*) str);
  50 }
  51
  52 value copy_string_or_null (const char*str)
  53 {
  54     return copy_string (str ? (char*) str : "");
  55 }
  56
  57 value ml_lookup_from_c (lookup_info *table, int data)
  58 {
  59     int i;
  60     for (i = table[0].data; i > 0; i--)
  61         if (table[i].data == data) return table[i].key;
  62     invalid_argument ("ml_lookup_from_c");
  63 }
  64
  65 int ml_lookup_to_c (lookup_info *table, value key)
  66 {
  67     int first = 1, last = table[0].data, current;
  68
  69     while (first < last) {
  70         current = (first+last)/2;
  71         if (table[current].key >= key) last = current;
  72         else first = current + 1;
  73     }
  74     if (table[first].key == key) return table[first].data;
  75     invalid_argument ("ml_lookup_to_c");
  76 }