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; }