open Cil
module F = Printf
module E = Errormsg

let unroll_to_struct t =
   match t with
   | TNamed(info,_) ->
         (match info.ttype with
         | TComp(comp,a) ->
               let name =
                  if Str.string_match (Str.regexp "^__anon") comp.cname 0 then
                     info.tname
                  else
                     comp.cname
               in
               let name =
                  if Str.string_match (Str.regexp "^_") name 0 then
                     name
                  else
                     "_" ^ name
               in
               let my_c = Cil.mkCompInfo true name (fun t -> []) [] in
               TComp(my_c,a)
         | _ -> Cil.unrollType t)
   | _ -> t
;;

let rec c_to_scheme t =
   match t with
   | TInt(IChar,_) -> "_byte"
   | TInt(IUChar,_) -> "_ubyte"
   | TInt(ISChar,_) -> "_sbyte"
   | TInt(IUInt,_) -> "_uint"
   | TInt(IInt,_) -> "_int"
   | TInt(ILong,_) -> "_long"
   | TInt(IULong,_) -> "_ulong"
   | TInt(_,_) -> "_int"
   | TPtr(TComp(comp,_),_) -> comp.cname ^ "-pointer"
   (* | TPtr(TNamed(info,_),a) -> (c_to_scheme (TPtr (info.ttype,a))) *)
   | TPtr(TNamed(info,info_a),a) ->
         (c_to_scheme (TPtr ((unroll_to_struct (TNamed (info,info_a))),a)))
   | TPtr(TInt(IChar,_),_) -> "_string"
   | TPtr(TPtr(TInt(IChar,_),_),_) -> "(_ptr i _string)"
   | TPtr(TInt(kind,a),_) -> F.sprintf "(_ptr i %s)" (c_to_scheme (TInt
   (kind,a)))
   | TPtr(TPtr(_,_),_) -> "_pointer"
   | TPtr(t,_) -> F.sprintf "(_ptr i %s)" (c_to_scheme t)
   | TNamed(info,_) -> (c_to_scheme (unroll_to_struct t))
   | TFun(t,Some(args),_,_) ->
         let p_args =
            match args with
            | [] -> "_void"
            | _ -> (parse_args args)
         in
         F.sprintf "(_fun %s -> %s)" p_args (c_to_scheme t)
   | TFun(t,None,_,_) -> F.sprintf "(_fun _void -> %s)" (c_to_scheme t)
   (* | TPtr(t,_) -> F.sprintf "(_ptr i %s)" (c_to_scheme t) *)
   | TVoid(_) -> "_void"
   | TArray(_,_,_) -> "_array"
   | TBuiltin_va_list(_) -> "_builtin"
   | TEnum(enum,_) -> enum.ename
   | TComp(_,_) -> "_comp"
   | TFloat(_,_) -> "float"
and
parse_args args =
   List.fold_left (fun a b -> a ^ b ^ " ") ""
   (List.map (fun arg ->
      match arg with
      | name,t,attrs -> (c_to_scheme t))
   args)
;;

class visitor output = object(self)
   inherit nopCilVisitor

   val define = "defx11*"

   method vglob glob = 
      (match glob with
      | GVar(var,init,loc) ->
            E.log "Visiting var %s\n" var.vname
      | GVarDecl(var,loc) ->
            (match var.vtype with
            | TFun(t,Some(args),var_args,attrs) ->
                  (* E.log "Visiting variable declaration %s\n" var.vname; *)
                  let p_args =
                     match args with
                     | [] -> "_void "
                     | _ -> (parse_args args)
                  in
                  F.fprintf output "(%s %s : %s-> %s)\n" define var.vname
                  p_args (c_to_scheme t)
            | TFun(t,None,_,_) ->
                  F.fprintf output "(%s %s : _void -> %s)\n" define var.vname
                  (c_to_scheme t)
            | _ -> ())
      | _ -> ());
      SkipChildren

end;;

let parse_ffi (file:Cil.file) =
   E.log "Parsing some file\n";
   let out = open_out "output" in
   visitCilFileSameGlobals (new visitor out) file;
   close_out out
;;

let feature : Cil.featureDescr =
   {
      fd_name = "ffi";
      fd_enabled = ref false;
      fd_description = "ffi generation from .c header files";
      fd_extraopt = [];
      fd_doit = parse_ffi;
      fd_post_check = false;
   }
