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