1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
(***********************************************************************)
(* *)
(* CamlIDL *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU Lesser General Public License LGPL v2.1 *)
(* *)
(***********************************************************************)
(* $Id: typedef.ml,v 1.17 2002-05-01 15:23:15 xleroy Exp $ *)
(* Handling of typedefs *)
open Printf
open Utils
open Variables
open Idltypes
open Cvttyp
open Cvtval
type type_decl =
{ td_name: string;
td_mod: string;
td_type: idltype;
td_abstract: bool;
td_c2ml: string option;
td_ml2c: string option;
td_finalize: string option;
td_compare: string option;
td_hash: string option;
td_errorcode: bool;
td_errorcheck: string option;
td_mltype: string option }
(* Record typedefs by name *)
let find =
ref ((fun _ -> invalid_arg "Typedef.find") : string -> type_decl)
(* Generate the ML type definition corresponding to the typedef *)
let ml_declaration oc td =
match td with
{td_mltype = Some s} ->
fprintf oc "%s = %s\n" (String.uncapitalize_ascii td.td_name) s
| {td_abstract = true} ->
fprintf oc "%s\n" (String.uncapitalize_ascii td.td_name)
| _ ->
fprintf oc "%s = %a\n"
(String.uncapitalize_ascii td.td_name) out_ml_type td.td_type
(* Generate the C typedef corresponding to the typedef *)
let c_declaration oc td =
fprintf oc "typedef %a;\n" out_c_decl (td.td_name, td.td_type);
begin match td.td_ml2c with
None -> ()
| Some s -> fprintf oc "extern void %s(value, %s *);\n" s td.td_name
end;
begin match td.td_c2ml with
None -> ()
| Some s -> fprintf oc "extern value %s(%s *);\n" s td.td_name
end;
begin match td.td_finalize with
None -> ()
| Some s -> fprintf oc "extern void %s(%s *);\n" s td.td_name
end;
begin match td.td_compare with
None -> ()
| Some s ->
fprintf oc "extern int %s(%s *, %s *);\n" s td.td_name td.td_name
end;
begin match td.td_hash with
None -> ()
| Some s -> fprintf oc "extern long %s(%s *);\n" s td.td_name
end;
fprintf oc "\n"
(* External (forward) declaration of the translation functions *)
let declare_transl oc td =
begin match td.td_ml2c with
Some s ->
fprintf oc "extern void %s(value, %s *);\n"
s td.td_name;
fprintf oc "#define camlidl_ml2c_%s_%s(v,c,ctx) %s(v,c)\n\n"
td.td_mod td.td_name s
| None ->
fprintf oc "extern void camlidl_ml2c_%s_%s(value, %s *, camlidl_ctx _ctx);\n"
td.td_mod td.td_name td.td_name
end;
begin match td.td_c2ml with
Some s ->
fprintf oc "extern value %s(%s *);\n"
s td.td_name;
fprintf oc "#define camlidl_c2ml_%s_%s(c,ctx) %s(c)\n\n"
td.td_mod td.td_name s
| None ->
fprintf oc "extern value camlidl_c2ml_%s_%s(%s *, camlidl_ctx _ctx);\n"
td.td_mod td.td_name td.td_name
end;
fprintf oc "\n"
(* Translation function from the ML type to the C type *)
let is_custom_block td =
td.td_abstract &&
not (td.td_finalize = None && td.td_compare = None && td.td_hash = None)
let transl_ml_to_c oc td =
current_function := sprintf "typedef %s" td.td_name;
let v = new_var "_v" in
let c = new_var "_c" in
fprintf oc "void camlidl_ml2c_%s_%s(value %s, %s * %s, camlidl_ctx _ctx)\n"
td.td_mod td.td_name v td.td_name c;
fprintf oc "{\n";
let pc = divert_output() in
increase_indent();
if td.td_abstract then
if is_custom_block td then begin
iprintf pc "*%s = *((%s *) Data_custom_val(%s));\n"
c td.td_name v
end else begin
iprintf pc "*%s = *((%s *) Bp_val(%s));\n" c td.td_name v
end
else begin
ml_to_c pc false Prefix.empty td.td_type v (sprintf "(*%s)" c);
end;
decrease_indent();
output_variable_declarations oc;
end_diversion oc;
fprintf oc "}\n\n";
current_function := ""
(* Translation function from the C type to the ML type *)
let transl_c_to_ml oc td =
begin match td.td_finalize with
None -> ()
| Some f ->
fprintf oc "\
static void camlidl_finalize_%s_%s(value v)
{
%s((%s *) Data_custom_val(v));
}
" td.td_mod td.td_name f td.td_name
end;
begin match td.td_compare with
None -> ()
| Some f ->
fprintf oc "\
static int camlidl_compare_%s_%s(value v1, value v2)
{
return %s((%s *) Data_custom_val(v1), (%s *) Data_custom_val(v2));
}
" td.td_mod td.td_name f td.td_name td.td_name
end;
begin match td.td_hash with
None -> ()
| Some f ->
fprintf oc "\
static long camlidl_hash_%s_%s(value v)
{
return %s((%s *) Data_custom_val(v));
}
" td.td_mod td.td_name f td.td_name
end;
if is_custom_block td then begin
fprintf oc "struct custom_operations camlidl_cops_%s_%s = {\n"
td.td_mod td.td_name;
fprintf oc " NULL,\n";
begin match td.td_finalize with
None -> iprintf oc " custom_finalize_default,\n"
| Some f -> iprintf oc " camlidl_finalize_%s_%s,\n" td.td_mod td.td_name
end;
begin match td.td_compare with
None -> iprintf oc " custom_compare_default,\n"
| Some f -> iprintf oc " camlidl_compare_%s_%s,\n" td.td_mod td.td_name
end;
begin match td.td_hash with
None -> iprintf oc " custom_hash_default,\n"
| Some f -> iprintf oc " camlidl_hash_%s_%s,\n" td.td_mod td.td_name
end;
iprintf oc " custom_serialize_default,\n";
iprintf oc " custom_deserialize_default\n";
fprintf oc "};\n\n"
end;
current_function := sprintf "typedef %s" td.td_name;
let v = new_ml_variable() in
let c = new_var "_c" in
fprintf oc "value camlidl_c2ml_%s_%s(%s * %s, camlidl_ctx _ctx)\n"
td.td_mod td.td_name td.td_name c;
fprintf oc "{\n";
let pc = divert_output() in
increase_indent();
if td.td_abstract then
if is_custom_block td then begin
iprintf pc "%s = caml_alloc_custom(&camlidl_cops_%s_%s, sizeof(%s), 0, 1);\n"
v td.td_mod td.td_name td.td_name;
iprintf pc "*((%s *) Data_custom_val(%s)) = *%s;\n"
td.td_name v c
end else begin
iprintf pc "%s = camlidl_alloc((sizeof(%s) + sizeof(value) - 1) / sizeof(value), Abstract_tag);\n"
v td.td_name;
iprintf pc "*((%s *) Bp_val(%s)) = *%s;\n"
td.td_name v c
end
else begin
c_to_ml pc Prefix.empty td.td_type (sprintf "(*%s)" c) v
end;
iprintf pc "return %s;\n" v;
decrease_indent();
output_variable_declarations oc;
end_diversion oc;
fprintf oc "}\n\n";
current_function := ""
(* Emit the translation functions *)
let emit_transl oc td =
begin match td.td_ml2c with
Some s ->
fprintf oc "#define camlidl_ml2c_%s_%s(v,c,ctx) %s(v,c)\n\n"
td.td_mod td.td_name s
| None ->
transl_ml_to_c oc td
end;
begin match td.td_c2ml with
Some s ->
fprintf oc "#define camlidl_c2ml_%s_%s(c,ctx) %s(c)\n\n"
td.td_mod td.td_name s
| None ->
transl_c_to_ml oc td
end
|
