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
|
(***********************************************************************)
(* *)
(* 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: file.ml,v 1.18 2002-04-19 13:24:29 xleroy Exp $ *)
(* Handling of interfaces *)
open Printf
open Utils
open Idltypes
open Intf
type diversion_type = Div_c | Div_h | Div_ml | Div_mli | Div_ml_mli
type component =
Comp_typedecl of Typedef.type_decl
| Comp_structdecl of struct_decl
| Comp_uniondecl of union_decl
| Comp_enumdecl of enum_decl
| Comp_fundecl of Funct.function_decl
| Comp_constdecl of Constdecl.constant_decl
| Comp_diversion of diversion_type * string
| Comp_interface of Intf.interface
| Comp_import of string * components
and components = component list
(* Evaluate all constant definitions *)
let rec eval_constants intf =
List.iter
(function Comp_constdecl cd -> Constdecl.record cd
| Comp_import(file, comps) -> eval_constants comps
| _ -> ())
intf
(* Generate the ML interface *)
(* Generate the type definitions common to the .ml and the .mli *)
let gen_type_def oc intf =
let first = ref true in
let start_decl () =
if !first then fprintf oc "type " else fprintf oc "and ";
first := false in
let emit_typedef = function
Comp_typedecl td ->
start_decl(); Typedef.ml_declaration oc td
| Comp_structdecl s ->
if s.sd_fields <> [] then begin
start_decl(); Structdecl.ml_declaration oc s
end
| Comp_uniondecl u ->
if u.ud_cases <> [] then begin
start_decl(); Uniondecl.ml_declaration oc u
end
| Comp_enumdecl e ->
start_decl(); Enumdecl.ml_declaration oc e
| Comp_interface i ->
if i.intf_methods <> [] then begin
start_decl(); Intf.ml_declaration oc i
end
| _ -> () in
List.iter emit_typedef intf;
fprintf oc "\n"
(* Generate the .mli file *)
let gen_mli_file oc intf =
fprintf oc "(* File generated from %s.idl *)\n\n" !module_name;
gen_type_def oc intf;
(* Generate the function declarations *)
let emit_fundecl = function
Comp_fundecl fd -> Funct.ml_declaration oc fd
| Comp_constdecl cd -> Constdecl.ml_declaration oc cd
| Comp_diversion((Div_mli | Div_ml_mli), txt) ->
output_string oc txt; output_char oc '\n'
| Comp_interface i ->
if i.intf_methods <> [] then Intf.ml_class_declaration oc i
| _ -> () in
List.iter emit_fundecl intf
(* Generate the .ml file *)
let gen_ml_file oc intf =
fprintf oc "(* File generated from %s.idl *)\n\n" !module_name;
gen_type_def oc intf;
(* Generate the function declarations and class definitions *)
let emit_fundecl = function
Comp_fundecl fd -> Funct.ml_declaration oc fd
| Comp_constdecl cd -> Constdecl.ml_definition oc cd
| Comp_diversion((Div_ml | Div_ml_mli), txt) ->
output_string oc txt; output_char oc '\n'
| Comp_interface i ->
if i.intf_methods <> [] then Intf.ml_class_definition oc i
| _ -> () in
List.iter emit_fundecl intf
(* Process an import: declare the translation functions *)
let rec declare_comp oc = function
Comp_typedecl td ->
Typedef.declare_transl oc td
| Comp_structdecl sd ->
if sd.sd_name <> "" then Structdecl.declare_transl oc sd
| Comp_uniondecl ud ->
if ud.ud_name <> "" then Uniondecl.declare_transl oc ud
| Comp_enumdecl en ->
if en.en_name <> "" then Enumdecl.declare_transl oc en
| Comp_fundecl fd ->
()
| Comp_constdecl cd ->
()
| Comp_diversion(kind, txt) ->
()
| Comp_interface i ->
Intf.declare_transl oc i
| Comp_import(filename, comps) ->
List.iter (declare_comp oc) comps
(* Process a component *)
let rec process_comp oc = function
Comp_typedecl td ->
Typedef.emit_transl oc td
| Comp_structdecl sd ->
if sd.sd_name <> "" then
if sd.sd_fields = []
then Structdecl.declare_transl oc sd
else Structdecl.emit_transl oc sd
| Comp_uniondecl ud ->
if ud.ud_name <> "" then
if ud.ud_cases = []
then Uniondecl.declare_transl oc ud
else Uniondecl.emit_transl oc ud
| Comp_enumdecl en ->
if en.en_name <> ""
then Enumdecl.emit_transl oc en
else Enumdecl.emit_transl_table oc en
| Comp_fundecl fd ->
Funct.emit_wrapper oc fd
| Comp_constdecl cd ->
()
| Comp_diversion(kind, txt) ->
if kind = Div_c || (kind = Div_h && not !Clflags.include_header)
then begin
output_string oc txt; output_char oc '\n'
end
| Comp_interface i ->
if i.intf_methods <> [] then Intf.emit_transl oc i
| Comp_import(filename, comps) ->
List.iter (declare_comp oc) comps
(* Generate the C stub file *)
let gen_c_stub oc intf =
(* Output the header *)
fprintf oc "/* File generated from %s.idl */\n\n" !module_name;
output_string oc "\
#include <stddef.h>\n\
#include <string.h>\n\
#include <caml/mlvalues.h>\n\
#include <caml/memory.h>\n\
#include <caml/alloc.h>\n\
#include <caml/fail.h>\n\
#include <caml/callback.h>\n\
#ifdef Custom_tag\n\
#include <caml/custom.h>\n\
#include <caml/bigarray.h>\n\
#endif\n\
#include <caml/camlidlruntime.h>\n\n";
if !Clflags.include_header then
(* Include the .h for the module
(as generated by us or by MIDL, or written by the user) *)
fprintf oc "\n#include \"%s.h\"\n\n" !module_name;
(* Process the interface *)
List.iter (process_comp oc) intf
(* Generate the C header file *)
let process_definition oc = function
Comp_typedecl td ->
Typedef.c_declaration oc td
| Comp_structdecl sd ->
if sd.sd_name <> "" then Structdecl.c_declaration oc sd
| Comp_uniondecl ud ->
if ud.ud_name <> "" then Uniondecl.c_declaration oc ud
| Comp_enumdecl en ->
if en.en_name <> "" then Enumdecl.c_declaration oc en
| Comp_fundecl fd ->
Funct.c_declaration oc fd
| Comp_constdecl cd ->
Constdecl.c_declaration oc cd
| Comp_diversion(kind, txt) ->
if kind = Div_h then begin
output_string oc txt; output_char oc '\n'
end
| Comp_interface i ->
Intf.c_declaration oc i
| Comp_import(basename, comps) ->
fprintf oc "#include \"%s.h\"\n" basename
let gen_c_header oc intf =
(* Output the header *)
fprintf oc "/* File generated from %s.idl */\n\n" !module_name;
(* TODO: emit relevant #include *)
let symbname = "_CAMLIDL_" ^ String.uppercase_ascii !module_name ^ "_H" in
fprintf oc "\
#ifndef %s\n\
#define %s\n\n" symbname symbname;
fprintf oc "\
#ifdef __cplusplus\n\
#define _CAMLIDL_EXTERN_C extern \"C\"\n\
#else\n\
#define _CAMLIDL_EXTERN_C extern\n\
#endif\n\n\
#ifdef _WIN32\n\
#pragma pack(push,8) /* necessary for COM interfaces */\n\
#endif\n\n";
(* Emit the definitions *)
List.iter (process_definition oc) intf;
fprintf oc "\
#ifdef _WIN32\n\
#pragma pack(pop)\n\
#endif\n\n";
fprintf oc "\n\
#endif /* !%s */\n" symbname
|
