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
238
239
240
241
242
|
(***********************************************************************)
(* *)
(* 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 Q Public License version 1.0 *)
(* *)
(***********************************************************************)
(* $Id: cvtval.ml,v 1.25 2004/07/08 10:10:18 xleroy Exp $ *)
open Printf
open Utils
open Idltypes
open Variables
open Cvttyp
(* Allocate space to hold a C value of type [ty], and store a pointer to
this space in [c].
If [on_stack] is true, the space is allocated on stack.
Otherwise, it is allocated in the heap. *)
let allocate_space oc onstack ty c =
if onstack then begin
let c' = new_c_variable ty in
iprintf oc "%s = &%s;\n" c c';
c'
end else begin
iprintf oc "%s = (%a *) camlidl_malloc(sizeof(%a), _ctx);\n"
c out_c_type ty out_c_type ty;
"*" ^ c
end
(* Helper functions to deal with option types / NULL pointers *)
let option_ml_to_c oc v c conv =
iprintf oc "if (%s == Val_int(0)) {\n" v;
increase_indent();
iprintf oc "%s = NULL;\n" c;
decrease_indent();
iprintf oc "} else {\n";
increase_indent();
let v' = new_ml_variable() in
iprintf oc "%s = Field(%s, 0);\n" v' v;
conv v';
decrease_indent();
iprintf oc "}\n"
let option_c_to_ml oc c v conv =
iprintf oc "if (%s == NULL) {\n" c;
increase_indent();
iprintf oc "%s = Val_int(0);\n" v;
decrease_indent();
iprintf oc "} else {\n";
increase_indent();
let v' = new_ml_variable() in
conv v';
iprintf oc "Begin_root(%s)\n" v';
increase_indent();
iprintf oc "%s = camlidl_alloc_small(1, 0);\n" v;
iprintf oc "Field(%s, 0) = %s;\n" v v';
decrease_indent();
iprintf oc "End_roots();\n";
decrease_indent();
iprintf oc "}\n"
(* Translate the ML value [v] and store it into the C lvalue [c].
[ty] is the IDL type of the value being converted.
[pref] is the access prefix for the dependent parameters (size,
discriminants, etc) to be updated.
[onstack] is true if C structures should be allocated on stack
(their lifetime is that of the current function).
[onstack] is false if C structures should be heap-allocated
(they may be returned by the current function). *)
let rec ml_to_c oc onstack pref ty v c =
match ty with
Type_int(kind, repr) ->
let conv =
match repr with
Iunboxed ->
if kind = Long || kind = ULong then "Long_val" else "Int_val"
| Inative -> "Nativeint_val"
| I32 -> "Int32_val"
| I64 -> "Int64_val" in
iprintf oc "%s = %s(%s);\n" c conv v
| Type_float | Type_double ->
iprintf oc "%s = Double_val(%s);\n" c v
| Type_void ->
()
| Type_struct sd ->
if sd.sd_name = "" then
Struct.struct_ml_to_c ml_to_c oc onstack pref sd v c
else begin
iprintf oc "camlidl_ml2c_%s_struct_%s(%s, &%s, _ctx);\n"
sd.sd_mod sd.sd_name v c;
need_context := true
end
| Type_union(ud, attr) ->
if ud.ud_name = "" then
Union.union_ml_to_c ml_to_c oc onstack pref ud v c
(Lexpr.tostring pref attr.discriminant)
else begin
iprintf oc "%a = camlidl_ml2c_%s_union_%s(%s, &%s, _ctx);\n"
Lexpr.output (pref, attr.discriminant)
ud.ud_mod ud.ud_name v c;
need_context := true
end
| Type_enum(en, attr) ->
if attr.bitset then
Enum.enumset_ml_to_c ml_to_c oc en v c
else if en.en_name = "" then
Enum.enum_ml_to_c ml_to_c oc en v c
else
iprintf oc "%s = camlidl_ml2c_%s_enum_%s(%s);\n"
c en.en_mod en.en_name v
| Type_named(modl, name) ->
iprintf oc "camlidl_ml2c_%s_%s(%s, &%s, _ctx);\n" modl name v c;
need_context := true
| Type_pointer(Ref, Type_interface(modl, name)) ->
iprintf oc "%s = (struct %s *) camlidl_unpack_interface(%s, _ctx);\n"
c name v;
need_context := true
| Type_pointer(Ref, ty_elt) ->
let c' = allocate_space oc onstack ty_elt c in
ml_to_c oc onstack pref ty_elt v c'
| Type_pointer(Unique, ty_elt) ->
option_ml_to_c oc v c
(fun v' -> ml_to_c oc onstack pref (Type_pointer(Ref, ty_elt)) v' c)
| Type_pointer(Ptr, ty_elt) ->
iprintf oc "%s = (%a) Field(%s, 0);\n" c out_c_type ty v
| Type_pointer(Ignore, ty_elt) ->
iprintf oc "%s = NULL;\n" c
| Type_array({maybe_null=false} as attr, ty_elt) ->
Array.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v c
| Type_array({maybe_null=true} as attr, ty_elt) ->
option_ml_to_c oc v c
(fun v' ->
Array.array_ml_to_c ml_to_c oc onstack pref attr ty_elt v' c)
| Type_bigarray({bigarray_maybe_null=false} as attr, ty_elt) ->
Array.bigarray_ml_to_c oc pref attr ty_elt v c
| Type_bigarray({bigarray_maybe_null=true} as attr, ty_elt) ->
option_ml_to_c oc v c
(fun v' ->
Array.bigarray_ml_to_c oc pref attr ty_elt v' c)
| Type_interface(modl, name) ->
error (sprintf "Reference to interface %s that is not a pointer" name)
| Type_const ty' ->
ml_to_c oc onstack pref ty' v c
(* Translate the C value [c] and store it into the ML variable [v].
[ty] is the IDL type of the value being converted.
[pref] is the access prefix for the dependent parameters (size,
discriminants, etc) to be updated. *)
let rec c_to_ml oc pref ty c v =
match ty with
| Type_int((Char | SChar), repr) ->
iprintf oc "%s = Val_int((unsigned char)(%s));\n" v c
| Type_int(kind, repr) ->
let conv =
match repr with
Iunboxed ->
if kind = Long || kind = ULong then "Val_long" else "Val_int"
| Inative -> "copy_nativeint"
| I32 -> "copy_int32"
| I64 -> "copy_int64" in
iprintf oc "%s = %s(%s);\n" v conv c
| Type_float | Type_double ->
iprintf oc "%s = copy_double(%s);\n" v c
| Type_void ->
()
| Type_struct sd ->
if sd.sd_name = ""
then Struct.struct_c_to_ml c_to_ml oc pref sd c v
else iprintf oc "%s = camlidl_c2ml_%s_struct_%s(&%s, _ctx);\n"
v sd.sd_mod sd.sd_name c;
need_context := true
| Type_union(ud, attr) ->
if ud.ud_name = ""
then Union.union_c_to_ml c_to_ml oc pref ud c v
(Lexpr.tostring pref attr.discriminant)
else iprintf oc "%s = camlidl_c2ml_%s_union_%s(%a, &%s, _ctx);\n"
v ud.ud_mod ud.ud_name
Lexpr.output (pref, attr.discriminant) c;
need_context := true
| Type_enum(en, attr) ->
if attr.bitset then
Enum.enumset_c_to_ml c_to_ml oc en c v
else if en.en_name = "" then
Enum.enum_c_to_ml c_to_ml oc en c v
else
iprintf oc "%s = camlidl_c2ml_%s_enum_%s(%s);\n"
v en.en_mod en.en_name c
| Type_named(modl, name) ->
iprintf oc "%s = camlidl_c2ml_%s_%s(&%s, _ctx);\n" v modl name c;
need_context := true
| Type_pointer(Ref, Type_interface(modl, name)) ->
iprintf oc "%s = camlidl_pack_interface(%s, _ctx);\n" v c;
need_context := true
| Type_pointer(Ref, ty_elt) ->
c_to_ml oc pref ty_elt (sprintf "*%s" c) v;
| Type_pointer(Unique, ty_elt) ->
option_c_to_ml oc c v
(c_to_ml oc pref (Type_pointer(Ref, ty_elt)) c)
| Type_pointer(Ptr, ty_elt) ->
iprintf oc "%s = camlidl_alloc_small(1, Abstract_tag);\n" v;
iprintf oc "Field(%s, 0) = (value) %s;\n" v c
| Type_pointer(Ignore, ty_elt) ->
()
| Type_array({maybe_null=false} as attr, ty_elt) ->
Array.array_c_to_ml c_to_ml oc pref attr ty_elt c v
| Type_array({maybe_null=true} as attr, ty_elt) ->
option_c_to_ml oc c v
(Array.array_c_to_ml c_to_ml oc pref attr ty_elt c)
| Type_bigarray({bigarray_maybe_null=false} as attr, ty_elt) ->
Array.bigarray_c_to_ml oc pref attr ty_elt c v
| Type_bigarray({bigarray_maybe_null=true} as attr, ty_elt) ->
option_c_to_ml oc c v
(Array.bigarray_c_to_ml oc pref attr ty_elt c)
| Type_interface(modl, name) ->
error (sprintf "Reference to interface %s that is not a pointer" name)
| Type_const ty' ->
c_to_ml oc pref ty' c v
(* Allocate suitable space for the C out parameter [c]. *)
let rec allocate_output_space oc pref c ty =
match ty with
Type_pointer(attr, ty_arg) ->
let c' = new_c_variable ty_arg in
iprintf oc "%s = &%s;\n" c c'
| Type_array(attr, ty_arg) ->
Array.array_allocate_output_space oc pref attr ty_arg c
| Type_bigarray(attr, ty_arg) ->
Array.bigarray_allocate_output_space oc pref attr ty_arg c
| Type_const ty' -> (* does this make sense? *)
allocate_output_space oc pref c ty'
| _ -> ()
|
