generate_structs.ml

#!/usr/bin/env ocaml
(* {{{ COPYING *(

  Code generator for wrapping C structs to OCaml.
  Copyright (C) 2008  Florent Monnier  <monnier.florent(_)gmail.com>

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation the
  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  sell copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  The Software is provided "as is", without warranty of any kind, express or
  implied, including but not limited to the warranties of merchantability,
  fitness for a particular purpose and noninfringement. In no event shall
  the authors or copyright holders be liable for any claim, damages or other
  liability, whether in an action of contract, tort or otherwise, arising
  from, out of or in connection with the software or the use or other dealings
  in the Software.

)* }}} *)
#load "str.cma"

type t = {
    fun_name_get: string;
    fun_name_set: string;
    item_type: string;
    param_name: string;
    struct_member: string;
    type_conv_c2ml: string -> string * string;
    type_conv_ml2c: unit -> string * string;
    ml_type: string;
  }

exception Not_used ;;

let conv_ml_to_c = function
  | "char"
  | "int" -> (fun () -> "", "Int_val(val)")
  | "cpFloat"
  | "float" -> (fun () -> "", "Double_val(val)")
  | "cpVect" -> (fun () -> "
        cpVect _val;
        _val.x = Double_field(val,0);
        _val.y = Double_field(val,1);\n", "_val")

  (* Read only members *)
  | "int_readonly"
  | "cpArray"
  | "cpShape"
  | "cpVectArray"
  | "cpHashValue" ->
      (fun () -> raise Not_used)
  | unknown -> invalid_arg unknown
;;


let conv_c_to_ml ml_type str = match ml_type with
  | "char"
  | "int" -> ("return Val_int(", ");")
  | "int_readonly" -> ("return Val_int(", ");")
  | "cpFloat"
  | "float" -> ("return caml_copy_double(", ");")
  | "cpArray" -> ("return (value) ", ";")
  | "cpShape" -> ("return (value) ", ";")
  | "cpHashValue" -> ("return Val_cpHashValue(", ");")
  | "cpVect" -> ("\
        CAMLparam0();
        CAMLlocal1( ml_ret );

        cpVect _ret = ", ";
        
        ml_ret = caml_alloc(2 * Double_wosize, Double_array_tag);
        Store_double_field( ml_ret, 0, _ret.x );
        Store_double_field( ml_ret, 1, _ret.y );

        CAMLreturn( ml_ret );")

  | "cpVectArray" -> (Printf.sprintf "\
        CAMLparam0();
        CAMLlocal2( ml_ret, vert_i );

        int num = ((%s *)this)->numVerts;
        cpVect *verts = " str, ";

        ml_ret = caml_alloc(num, 0);

        for (int i=0; i<num; i++) {

                vert_i = caml_alloc(2 * Double_wosize, Double_array_tag);

                Store_double_field( vert_i, 0, verts[i].x );
                Store_double_field( vert_i, 1, verts[i].y );

                Store_field( ml_ret, i, vert_i );
        }

        CAMLreturn( ml_ret );")

  | unknown -> invalid_arg unknown
;;


let get_ml_type t = match t with
  | "int"
  | "char"
  | "float"
  | "cpShape"
  | "cpArray"
  | "cpVect"
  | "cpVectArray" -> t
  | "cpFloat" -> "float"
  | "int_readonly" -> "int"
  | "cpHashValue" -> "int"
  | other ->
      Printf.fprintf stderr "Warning: ml type not recognised: %s" other;
      (other)
;;


let find_pos str c =
  let len = String.length str in
  let rec aux i =
    if i >= len then
      (Printf.printf "character '%c' not found in:\n%s\n%!" c str;
       raise Not_found)
    else if str.[i] = c then i
    else aux (succ i)
  in
  aux 0
;;


let strip_spaces str =
  let r = Array.of_list(Str.split (Str.regexp "[ \t\r\n]+") str) in
  r.(0)
;;


let parse_member st memb =
try
  let open_par = find_pos memb '('
  and close_par = find_pos memb ')'
  in
  let access_func = strip_spaces(String.sub memb 0 open_par)
  and cont_str = String.sub memb (open_par +1) (close_par - open_par -1)
  in
  let membs = Array.of_list(Str.split (Str.regexp "[ :]+") cont_str) in
  if Array.length membs <> 2 &&
     Array.length membs <> 3 then (
             Array.iter (Printf.printf "%s\n%!") membs;
             invalid_arg cont_str);
  {
    fun_name_get = st.(0) ^ "Get" ^ access_func;
    fun_name_set = st.(0) ^ "Set" ^ access_func;
    item_type = st.(0);
    param_name = st.(1);
    struct_member = membs.(1);
    type_conv_ml2c = conv_ml_to_c membs.(0);
    type_conv_c2ml = conv_c_to_ml membs.(0);
    ml_type = get_ml_type membs.(0);
  }
with
  Not_found ->
    Printf.printf "parse_member:\n%s\n" memb;
    exit 1;
;;


let parse_struct struct_ =
try
  (* structure name and type *)
  let open_bra = find_pos struct_ '{'
  and close_bra = find_pos struct_ '}' in
  let st_str = String.sub struct_ 0 open_bra in
  let st = Array.of_list(Str.split (Str.regexp "[ \r\n]+") st_str) in
  if Array.length st <> 2 then
    invalid_arg st_str;

  (* members of the structure *)
  let membs_str = String.sub struct_ (open_bra +1) (close_bra - open_bra -1) in
  let membs_li = Str.split (Str.regexp ",[ \r\n]*") membs_str in
  let membs = List.map (parse_member st) membs_li in
  (membs)
with
  Not_found ->
    Printf.printf "parse_struct:\n%s\n" struct_;
    exit 1;
;;


let parse_input structures =
  let structs_s = Str.split (Str.regexp ";[ \r\n]*") structures in
  let structs_t = List.map parse_struct structs_s in
  (structs_t)
;;


let print_set_func_c t =
try
  Printf.printf "
CAMLprim value
ml_%s(value this, value val)
{%s
        ((%s *)this)->%s = %s;
        return Val_unit;
}\n"
      t.fun_name_set
      (fst(t.type_conv_ml2c()))
      t.item_type
      t.struct_member
      (snd(t.type_conv_ml2c()));
with
  Not_used -> ()
;;


let print_get_func_c t =
  Printf.printf "
CAMLprim value
ml_%s(value this)
{
        %s ((%s *)this)->%s %s
}\n"
      t.fun_name_get
      (fst(t.type_conv_c2ml  t.item_type))
      t.item_type
      t.struct_member
      (snd(t.type_conv_c2ml  t.item_type));
;;


let print_set_func_ml t =
try
  ignore(t.type_conv_ml2c()); (* skip read only members *)
  Printf.printf "
external %s: %s:%s -> %s:%s -> unit = \"ml_%s\"\n"
      t.fun_name_set
      t.param_name
      t.item_type
      t.struct_member
      t.ml_type
      t.fun_name_set;
with
  Not_used -> ()
;;


let print_get_func_ml t =
  Printf.printf "
external %s: %s:%s -> %s = \"ml_%s\"\n"
      t.fun_name_get
      t.param_name
      t.item_type
      t.ml_type
      t.fun_name_get;
;;


let there_is_arg arg =
  let argc = Array.length Sys.argv in
  let rec aux i =
    if i >= argc then false
    else if Sys.argv.(i) = arg then true
      else aux(succ i)
  in
  aux 0
;;


let is_comment line =
  let len = String.length line in
  if len >= 2 && line.[0] = '/' && line.[1] = '/'
  then true else false
;;

let input_stdin () =
  let buf = Buffer.create 2000 in
  try
    let rec aux() =
      let line = input_line stdin in
      if not(is_comment line) then
        Buffer.add_string buf line;
        Buffer.add_char buf '\n';
      aux()
    in
    aux();
  with
    End_of_file -> (Buffer.contents buf)
;;


let () =
  let structures = input_stdin() in
  let structs = List.flatten(parse_input structures) in
  if there_is_arg "--gen-c" then begin
    List.iter print_set_func_c structs;
    List.iter print_get_func_c structs;
  end;
  if there_is_arg "--gen-ml" then begin
    List.iter print_set_func_ml structs;
    List.iter print_get_func_ml structs;
  end;
;;