1#use "topfind";;
2#require "unix";;
3#require "pcre";;
4
5type attribute_spec = {
6  function_name: string;
7  function_attrs: string list option;
8  parameter_attrs: (string * string list) list option;
9}
10
11(* These functions all require special handling beyond the more general rules
12   below. *)
13let manual_function_attributes =
14  [
15    {
16      function_name = "c_plimage";
17      function_attrs = None;
18      parameter_attrs = Some ["idata", ["in"; "size_is(nx, ny)"]];
19    };
20    {
21      function_name = "c_plstyl";
22      function_attrs = None;
23      parameter_attrs = Some ["mark", ["size_is(nms)"]; "space", ["size_is(nms)"]];
24    };
25    {
26      function_name = "plMinMax2dGrid";
27      function_attrs = None;
28      parameter_attrs = Some ["f", ["size_is(nx, ny)"]; "fmax", ["out"]; "fmin", ["out"]];
29    };
30    {
31      function_name = "c_plscmap1l";
32      function_attrs = None;
33      parameter_attrs = Some ["alt_hue_path", ["in"; "size_is(npts)"; "unique"]];
34    };
35    {
36      function_name = "c_plscmap1la";
37      function_attrs = None;
38      parameter_attrs = Some ["alt_hue_path", ["in"; "size_is(npts)"; "unique"]];
39    };
40    {
41      function_name = "c_plxormod";
42      function_attrs = None;
43      parameter_attrs = Some ["status", ["out"]];
44    };
45    {
46      function_name = "c_plrgbhls";
47      function_attrs = None;
48      parameter_attrs = Some ["p_h", ["out"]; "p_l", ["out"]; "p_s", ["out"]];
49    };
50    {
51      function_name = "c_plhlsrgb";
52      function_attrs = None;
53      parameter_attrs = Some ["p_r", ["out"]; "p_g", ["out"]; "p_b", ["out"]];
54    };
55    {
56      function_name = "c_plmkstrm";
57      function_attrs = None;
58      parameter_attrs = Some ["p_strm", ["out"]];
59    };
60    {
61      function_name = "c_plbin";
62      function_attrs = None;
63      parameter_attrs = Some ["x", ["in"; "size_is(nbin)"];
64                              "y", ["in"; "size_is(nbin)"]];
65    };
66    {
67      function_name = "c_plpat";
68      function_attrs = None;
69      parameter_attrs = Some ["inc", ["in"; "size_is(nlin)"];
70                              "del", ["in"; "size_is(nlin)"]];
71    };
72    {
73      function_name = "c_plctime";
74      function_attrs = None;
75      parameter_attrs = Some ["ctime", ["out"]];
76    };
77    (* For now, this will be wrapped by hand...
78    {
79      function_name = "c_plcolorbar";
80      function_attrs = None;
81      parameter_attrs = Some ["values", ["in"; "size_is(n_values)"];
82                              "p_colorbar_width", ["out"];
83                              "p_colorbar_height", ["out"]];
84    };
85    {
86      function_name = "c_plgriddata";
87      function_attrs = None;
88      parameter_attrs = Some ["xg", ["in"; "size_is(nptsx)"]; "yg", ["in"; "size_is(nptsy)"]; "zg", ["out"; "size_is(nptsx,nptsy)"]];
89    };
90    *)
91  ]
92
93(* Length to allocate for output strings. *)
94let max_string_length = "1024"
95
96(* Functions to read in everything on STDOUT from a given command. *)
97(* Many thanks to Richard M. Jones for the following two functions! *)
98
99(** Read in all of the lines from an input source *)
100let rec input_all_lines chan =
101  try
102    let line = input_line chan in
103    line :: input_all_lines chan
104  with
105      End_of_file -> []
106
107(** Read everything output on STDOUT from a given command-line *)
108let pget cmd =
109  let chan = Unix.open_process_in cmd in
110  let lines = input_all_lines chan in
111  let stat = Unix.close_process_in chan in
112  (match stat with
113       Unix.WEXITED 0 -> ()
114     | Unix.WEXITED i ->
115         failwith ("command failed with code " ^ string_of_int i)
116     | Unix.WSIGNALED i ->
117         failwith ("command killed by signal " ^ string_of_int i)
118     | Unix.WSTOPPED i ->
119         failwith ("command stopped by signal " ^ string_of_int i));
120  lines
121
122(** Read in a file, pre-processed with cpp, and return the output as a list of
123    lines. *)
124let read_file filename =
125  let preprocessed_text = pget ("cpp " ^ filename) in
126  let l = List.map (fun l -> l ^ "\n") preprocessed_text in
127  (*
128  let text_blob =
129    List.fold_left (^) "" l
130  in
131  print_endline text_blob;
132  text_blob
133  *)
134  l
135
136(** Utility functions *)
137let (|>) x f = f x
138let id x = x
139
140(** Clean up the text a bit, minimizing whitespace and cutting out leftover
141    cruft from the preprocessor. *)
142let cleanup_lines l =
143  (* Strip out #-started preprocessor lines, as well as lines with only
144     whitespace. *)
145  let blob =
146    let filtered =
147      List.filter (
148        fun line ->
149          if Pcre.pmatch ~pat:"^#|^\\s+$" line then
150            false
151          else
152            true
153      ) l
154    in
155    List.fold_left (^) "" filtered
156  in
157  blob
158  (* Compress lengths of whitespace down to a single character *)
159  |> Pcre.replace ~pat:"\\s+" ~templ:" "
160  (* Put newlines back in after each ; *)
161  |> Pcre.replace ~pat:"; " ~templ:";\n"
162
163(** Given a list of attributes, return a camlidl-ready string representing those
164    attributes. *)
165let make_attribute_string attributes =
166  match attributes with
167      [] -> ""
168    | a ->
169        "[" ^ String.concat ", " a ^"]"
170
171(** Get rid of extraneous whitespace (leading, trailing, runs) *)
172let minimize_whitespace s =
173  s
174  |> Pcre.replace ~pat:"^\\s+" ~templ:""
175  |> Pcre.replace ~pat:"\\s+$" ~templ:""
176  |> Pcre.replace ~pat:"\\s+" ~templ:" "
177
178(** Generate attributes specific to a given function, based in its return type
179    and name. *)
180let function_attributes return_type name =
181  let check_re re =
182    if Pcre.pmatch ~pat:re name then
183      Pcre.extract ~pat:re ~full_match:false name
184    else
185      [||]
186  in
187
188  let name_checks =
189    [
190      (* OCaml values can not begin with a capital letter.  Translate a name
191         like FOObar to foo_bar for OCaml. *)
192      "^([A-Z]+)(.*)$",
193      (
194        fun a -> ["mlname(" ^ (
195          match Array.length a with
196              1 -> String.lowercase_ascii a.(0)
197            | 2 ->
198                String.lowercase_ascii a.(0) ^ "_" ^ a.(1)
199            | _ -> raise (Failure "Bad result in function caps check")
200        ) ^ ")"]
201      );
202      (* Plplot names many of their functions c_* to avoid clashes with certain
203         language bindings.  There's no need to carry this over to OCaml.
204         This turns c_foo in to foo. *)
205      "^c_(\\w+)$", (fun a -> ["mlname(" ^ a.(0) ^ ")"]);
206    ]
207  in
208  let type_checks =
209    [
210      (* Treat strings properly *)
211      "char\\s*\\*",
212      ["string"; "length_is(" ^ max_string_length ^ ")"]
213    ]
214  in
215
216  (* Attributes based on the function name *)
217  let name_attrs =
218    List.map (
219      fun (re,attrf) ->
220        let a = check_re re in if Array.length a > 0 then attrf a else []
221    ) name_checks
222    |> List.flatten
223  in
224  (* Attributes based on the function type *)
225  let type_attrs =
226    List.map (
227      fun (re,attrs) -> if Pcre.pmatch ~pat:re return_type then attrs else []
228    ) type_checks
229    |> List.flatten
230  in
231  (* Any other attributes, specified manually *)
232  let manual_attrs =
233    try
234      let fa =
235        List.find (fun fa -> fa.function_name = name) manual_function_attributes
236      in
237      match fa.function_attrs with
238      | Some a -> a
239      | None -> []
240    with
241    | Not_found -> []
242  in
243  name_attrs @ type_attrs @ manual_attrs
244
245(** Generate attributes for function parameters *)
246let parameter_attributes function_name types names =
247  let pmatch re str = Pcre.pmatch ~pat:re str in
248  let non_get_functions = ["c_plgriddata"; "c_plgra"; "c_plgradient"] in
249
250  (* If all of the pieces are true, then the attribute(s) is(are) appropriate
251     for this parameter.  This is basically a long list of special cases
252     which usually, but not always, apply to multiple functions. *)
253  let checks p_type p_name =
254    [
255      (* Order goes:
256         function_name check
257         type check
258         attribute name check
259         misc. check (anything, as long as it's a bool)
260         attributes, if all of the above are true
261      *)
262      (* OCaml does not support unsigned integer values in its standard library
263         so use Int64.t values for unsigned ints to be safe. *)
264      true,
265      pmatch "unsigned int" p_type,
266      true,
267      true,
268      ["int64"];
269      (* "get" functions *)
270      pmatch "^c_plg" function_name,
271      pmatch "\\*" p_type,
272      true,
273      not (List.mem function_name non_get_functions),
274      ["out"] @
275        if pmatch "char" p_type then ["length_is(" ^ max_string_length ^ ")"]
276        else [];
277      (* Strings *)
278      true,
279      pmatch "(?:const )?char\\s*\\*$" p_type,
280      true,
281      true,
282      ["string"];
283      (* Pointers to arrays of n elements *)
284      true,
285      pmatch "\\*" p_type && not (pmatch "const char" p_type),
286      true,
287      List.mem "n" names,
288      ["in"; "size_is(n)"];
289      (* Pointers to arrays of npts elements *)
290      true,
291      pmatch "\\*" p_type,
292      not (pmatch "^[xyz]g$" p_name),
293      List.mem "npts" names,
294      ["in"; "size_is(npts)"];
295      (* x and y dimensions *)
296      true,
297      pmatch "\\*" p_type,
298      p_name = "x" || p_name = "y",
299      List.mem ("n" ^ p_name) names,
300      ["size_is(n" ^ p_name ^ ")"; "in"];
301      (* z dimensions *)
302      true,
303      pmatch "\\*\\*" p_type,
304      p_name = "z",
305      List.mem "nx" names && List.mem "ny" names,
306      ["size_is(nx, ny)"; "in"];
307      (* Contouring levels *)
308      true,
309      true,
310      p_name = "clevel",
311      List.mem "nlevel" names,
312      ["size_is(nlevel)"; "in"];
313      (* Color maps *)
314      true,
315      pmatch "\\*" p_type,
316      p_name = "r" || p_name = "g" || p_name = "b" || p_name = "alpha",
317      List.mem "ncol0" names,
318      ["size_is(ncol0)"; "in"];
319      true,
320      pmatch "\\*" p_type,
321      p_name = "r" || p_name = "g" || p_name = "b" || p_name = "alpha",
322      List.mem "ncol1" names,
323      ["size_is(ncol1)"; "in"];
324      (* Linear relationship color maps *)
325      pmatch "c_plscmap1l" function_name,
326      pmatch "\\*" p_type,
327      List.mem p_name ["intensity"; "coord1"; "coord2"; "coord3"; "alpha"],
328      true,
329      ["size_is(npts)"];
330      (* Relative to world coordinates *)
331      function_name = "c_plcalc_world",
332      pmatch "\\*" p_type,
333      List.mem p_name ["wx"; "wy"; "window"],
334      true,
335      ["out"];
336      (* Time conversion *)
337      function_name = "c_plbtime",
338      pmatch "\\*" p_type,
339      true,
340      true,
341      ["out"];
342      (* Index limits *)
343      true,
344      pmatch "\\*" p_type,
345      List.mem p_name ["indexymin"; "indexymax"],
346      true,
347      ["size_is(indexxmax)"; "in"];
348    ]
349  in
350
351  let attr_hash = Hashtbl.create 10 in
352
353  let perform_check param_type param_name =
354    (* Any other attributes, specified manually *)
355    let manual_attrs =
356      try
357        let fa =
358          List.find (fun fa -> fa.function_name = function_name)
359            manual_function_attributes
360        in
361        match fa.parameter_attrs with
362        | Some a -> List.assoc param_name a
363        | None -> []
364      with
365      | Not_found -> []
366    in
367    Hashtbl.add attr_hash param_name manual_attrs;
368    (* Check for attributes, filter the ones we don't want, then add the rest
369       to the attribute hash. *)
370    checks param_type param_name
371    |> List.filter (
372        fun (function_check, type_check, name_check, other_check, _) ->
373          List.for_all id [function_check; type_check; name_check; other_check]
374       )
375    |> List.iter (fun (_,_,_,_,attrs) -> Hashtbl.add attr_hash param_name attrs)
376  in
377  List.iter2 perform_check types names;
378  attr_hash
379
380(** Build a string from a list of attributes *)
381let build_attribute_list l =
382  List.map (
383    fun (attrs, t, n) ->
384      String.concat " " [make_attribute_string attrs; t; n]
385  ) l
386
387(** Given a C function prototype, chop it up and find out what camlidl
388    attributes it should have. *)
389let process_prototype line =
390  (* This is an ugly, but for now effective, regexp to parse the PLplot function
391     prototypes. *)
392  let pieces =
393    line
394    |> Pcre.extract ~pat:"^((?:(?:const|unsigned|enum) )?\\w+ (?:\\*\\s*)?)(\\w+)\\s*\\(([\\w\\s\\*\\[\\],]*)\\)" ~full_match:false
395    |> Array.map minimize_whitespace
396  in
397  (* Get the return type, name and arg list separately *)
398  let return_type = pieces.(0) in
399  let function_name = pieces.(1) in
400  let params =
401    pieces.(2)
402    |> Pcre.split ~pat:","
403    |> List.map minimize_whitespace
404  in
405  let param_types, param_names =
406    params
407    |> List.map (
408         fun param ->
409           let p = Pcre.extract ~pat:"(.*)?\\b(\\w+)" ~full_match:false param in
410           minimize_whitespace p.(0), minimize_whitespace p.(1)
411       )
412    |> List.split
413  in
414  let f_attrs = function_attributes return_type function_name in
415  let p_attrs = parameter_attributes function_name param_types param_names in
416  let params_with_attrs =
417    List.map2
418      (fun t n -> Hashtbl.find_all p_attrs n |> List.flatten, t, n)
419      param_types param_names
420  in
421  String.concat " " (
422    [
423      make_attribute_string f_attrs;
424      return_type;
425      function_name; "(";
426    ]
427    @ [String.concat ", " (build_attribute_list params_with_attrs)]
428    @ [");"]
429  )
430
431(** Write a list of lines out to the given filename *)
432let write_file filename lines =
433  let fout = open_out filename in
434  List.iter (output_string fout) lines;
435  close_out fout;
436  ()
437
438(** Given input and output filenames, process the contents of the input file
439    and write the results to the output file, which should be ready for
440    consumption by camlidl. *)
441let process_file () =
442  let infile, outfile =
443    if Array.length Sys.argv = 3 then
444      Sys.argv.(1), Sys.argv.(2)
445    else
446      "plplot_h", "plplot_h.inc"
447  in
448  read_file infile
449  |> cleanup_lines
450  |> Pcre.split ~pat:"\n"
451  |> List.map minimize_whitespace
452  |> List.map (
453       fun l ->
454         try
455           process_prototype l
456         with
457         | Not_found ->
458             failwith ("Unhandled or malformed prototype: " ^ l)
459     )
460  |> List.map minimize_whitespace
461  |> List.map (fun l -> l ^ "\n")
462  |> write_file outfile
463
464let () =
465  if !Sys.interactive then
466    ()
467  else
468    process_file ();
469    ()
470