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

   1 /* $Id$ */
   2
   3 #ifndef _wrappers_
   4 #define _wrappers_
   5
   6 #include <caml/mlvalues.h>
   7 #include <caml/fail.h>
   8
   9 value copy_memblock_indirected (void *src, asize_t size);
  10 value ml_some (value);
  11 void ml_raise_null_pointer (void) Noreturn;
  12 value Val_pointer (void *);
  13 value copy_string_check (const char*);
  14 value copy_string_or_null (const char *);
  15
  16 typedef struct { value key; int data; } lookup_info;
  17 value ml_lookup_from_c (lookup_info *table, int data);
  18 int ml_lookup_to_c (lookup_info *table, value key);
  19
  20 /* Wrapper generators */
  21
  22 #define ML_0(cname, conv) \
  23 value ml_##cname (value unit) { return conv (cname ()); }
  24 #define ML_1(cname, conv1, conv) \
  25 value ml_##cname (value arg1) { return conv (cname (conv1 (arg1))); }
  26 #define ML_1_post(cname, conv1, conv, post) \
  27 value ml_##cname (value arg1) \
  28 { value ret = conv (cname (conv1(arg1))); post; return ret; }
  29 #define ML_2(cname, conv1, conv2, conv) \
  30 value ml_##cname (value arg1, value arg2) \
  31 { return conv (cname (conv1(arg1), conv2(arg2))); }
  32 #define ML_2_name(mlname, cname, conv1, conv2, conv) \
  33 value mlname (value arg1, value arg2) \
  34 { return conv (cname (conv1(arg1), conv2(arg2))); }
  35 #define ML_3(cname, conv1, conv2, conv3, conv) \
  36 value ml_##cname (value arg1, value arg2, value arg3) \
  37 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); }
  38 #define ML_3_name(mlname, cname, conv1, conv2, conv3, conv) \
  39 value mlname (value arg1, value arg2, value arg3) \
  40 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3))); }
  41 #define ML_4(cname, conv1, conv2, conv3, conv4, conv) \
  42 value ml_##cname (value arg1, value arg2, value arg3, value arg4) \
  43 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); }
  44 #define ML_4_name(mlname, cname, conv1, conv2, conv3, conv4, conv) \
  45 value mlname (value arg1, value arg2, value arg3, value arg4) \
  46 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4))); }
  47 #define ML_5(cname, conv1, conv2, conv3, conv4, conv5, conv) \
  48 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5) \
  49 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  50                       conv5(arg5))); }
  51 #define ML_6(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv) \
  52 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  53                   value arg6) \
  54 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  55                       conv5(arg5), conv6(arg6))); }
  56 #define ML_7(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv) \
  57 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  58                   value arg6, value arg7) \
  59 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  60                       conv5(arg5), conv6(arg6), conv7(arg7))); }
  61 #define ML_8(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
  62              conv) \
  63 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  64                   value arg6, value arg7, value arg8) \
  65 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  66                       conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8))); }
  67 #define ML_9(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
  68               conv9, conv) \
  69 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  70                   value arg6, value arg7, value arg8, value arg9) \
  71 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  72                       conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
  73                       conv9(arg9))); }
  74 #define ML_10(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
  75               conv9, conv10, conv) \
  76 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  77                   value arg6, value arg7, value arg8, value arg9, value arg10)\
  78 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  79                       conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
  80                       conv9(arg9), conv10(arg10))); }
  81 #define ML_11(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
  82               conv9, conv10, conv11, conv) \
  83 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  84                   value arg6, value arg7, value arg8, value arg9, value arg10,\
  85                   value arg11) \
  86 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  87                       conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
  88                       conv9(arg9), conv10(arg10), conv11(arg11))); }
  89 #define ML_12(cname, conv1, conv2, conv3, conv4, conv5, conv6, conv7, conv8, \
  90               conv9, conv10, conv11, conv12, conv) \
  91 value ml_##cname (value arg1, value arg2, value arg3, value arg4, value arg5, \
  92                   value arg6, value arg7, value arg8, value arg9, value arg10,\
  93                   value arg11, value arg12) \
  94 { return conv (cname (conv1(arg1), conv2(arg2), conv3(arg3), conv4(arg4), \
  95                       conv5(arg5), conv6(arg6), conv7(arg7), conv8(arg8), \
  96                       conv9(arg9), conv10(arg10), conv11(arg11), \
  97                       conv12(arg12))); }
  98
  99 /* Use with care: needs the argument index */
 100 #define Ignore(x)
 101 #define Insert(x) (x),
 102 #define Split(x,f,g) f(x), g(x) Ignore
 103 #define Split3(x,f,g,h) f(x), g(x), h(x) Ignore
 104 #define Pair(x,f,g) f(Field(x,0)), g(Field(x,1)) Ignore
 105 #define Triple(x,f,g,h) f(Field(x,0)), g(Field(x,1)), h(Field(x,2)) Ignore
 106
 107 /* For more than 5 arguments */
 108 #define ML_bc6(cname) \
 109 value cname##_bc (value *argv, int argn) \
 110 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5]); }
 111 #define ML_bc7(cname) \
 112 value cname##_bc (value *argv, int argn) \
 113 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6]); }
 114 #define ML_bc8(cname) \
 115 value cname##_bc (value *argv, int argn) \
 116 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
 117                argv[7]); }
 118 #define ML_bc9(cname) \
 119 value cname##_bc (value *argv, int argn) \
 120 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
 121                argv[7],argv[8]); }
 122 #define ML_bc10(cname) \
 123 value cname##_bc (value *argv, int argn) \
 124 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
 125                argv[7],argv[8],argv[9]); }
 126 #define ML_bc11(cname) \
 127 value cname##_bc (value *argv, int argn) \
 128 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
 129                argv[7],argv[8],argv[9],argv[10]); }
 130 #define ML_bc12(cname) \
 131 value cname##_bc (value *argv, int argn) \
 132 { return cname(argv[0],argv[1],argv[2],argv[3],argv[4],argv[5],argv[6], \
 133                argv[7],argv[8],argv[9],argv[10],argv[11]); }
 134
 135 /* result conversion */
 136 #define Unit(x) ((x), Val_unit)
 137 #define Id(x) x
 138 #define Val_char Val_int
 139
 140 /* parameter conversion */
 141 #define Bool_ptr(x) ((long) x - 1)
 142 #define Char_val Int_val
 143 #define Float_val(x) ((float)Double_val(x))
 144
 145 #define Option_val(val,unwrap,default) \
 146 ((long)val-1 ? unwrap(Field(val,0)) : default)
 147 #define String_option_val(s) Option_val(s,String_val,NULL)
 148
 149 /* Utility */
 150
 151 #define Copy_array(ret,l,src,conv) \
 152  if (!l) ret = Atom(0); \
 153  else if (l <= Max_young_wosize) { int i; ret = alloc_tuple(l); \
 154    for(i=0;i<l;i++) Field(ret,i) = conv(src[i]); } \
 155  else { int i; ret = alloc_shr(l,0); \
 156    for(i=0;i<l;i++) initialize (&Field(ret,i), conv(src[i])); }
 157
 158 #define Make_Val_final_pointer(type, init, final, adv) \
 159 static void ml_final_##type (value val) \
 160 { if (Field(val,1)) final ((type*)Field(val,1)); } \
 161 value Val_##type (type *p) \
 162 { value ret; if (!p) ml_raise_null_pointer(); \
 163   ret = alloc_final (2, ml_final_##type, adv, 1000); \
 164   initialize (&Field(ret,1), (value) p); init(p); return ret; }
 165
 166 #define Make_Val_final_pointer_ext(type, ext, init, final, adv) \
 167 static void ml_final_##type##ext (value val) \
 168 { if (Field(val,1)) final ((type*)Field(val,1)); } \
 169 value Val_##type##ext (type *p) \
 170 { value ret; if (!p) ml_raise_null_pointer(); \
 171   ret = alloc_final (2, ml_final_##type##ext, adv, 1000); \
 172   initialize (&Field(ret,1), (value) p); init(p); return ret; }
 173
 174 #define Pointer_val(val) ((void*)Field(val,1))
 175 #define MLPointer_val(val) (Field(val,1) == 2 ? &Field(val,2) : (void*)Field(val,1))
 176
 177 #define Val_addr(ptr) (1+(value)ptr)
 178 #define Addr_val(val) ((void*)(val-1))
 179
 180 #define Wosize_asize(x) ((x-1)/sizeof(value)+1)
 181 #define Wosizeof(x) Wosize_asize(sizeof(x))
 182
 183 #define Make_Extractor(name,conv1,field,conv2) \
 184 value ml_##name##_##field (value val) \
 185 { return conv2 ((conv1(val))->field); }
 186
 187 #define Make_Setter(name,conv1,conv2,field) \
 188 value ml_##name##_##field (value val, value new) \
 189 { (conv1(val))->field = conv2(new); return Val_unit; }
 190
 191 #define Make_Array_Extractor(name,conv1,conv2,field,conv) \
 192 value ml_##name##_##field (value val, value index) \
 193 { return conv ((conv1(val))->field[conv2(index)]); }
 194
 195 #define Make_Array_Setter(name,conv1,conv2,conv3,field) \
 196 value ml_##name##_##field (value val, value index, value new) \
 197 { (conv1(val))->field[conv2(index)] = conv3(new); return Val_unit; }
 198
 199 /* ML value is [flag list] */
 200 #define Make_Flags_val(conv) \
 201 int Flags_##conv (value list) \
 202 { int flags = 0L; \
 203   while Is_block(list) { flags |= conv(Field(list,0)); list = Field(list,1); }\
 204   return flags; }
 205
 206 /* ML value is [flag list option] */
 207 #define Make_OptFlags_val(conv) \
 208 int OptFlags_##conv (value list) \
 209 { int flags = 0L; \
 210   if Is_block(list) list = Field(list,0); \
 211   while Is_block(list) { flags |= conv(Field(list,0)); list = Field(list,1); }\
 212   return flags; }
 213
 214 #define Val_copy(val) copy_memblock_indirected (&val, sizeof(val))
 215 #define Val_string copy_string_check
 216 #define Val_optstring copy_string_or_null
 217 #define Optstring_val(v) (string_length(v) ? String_val(v) : (char*)NULL)
 218 #define Val_option(v,f) (v ? ml_some(f(v)) : Val_unit)
 219
 220 #define Check_null(v) (v ? v : (ml_raise_null_pointer (), v))
 221
 222 #endif /* _wrappers_ */