let rec parse_struct_definition ~is_union ~env decl =
let current_size = ref zero_big_int in
let current_align = ref zero_big_int in
let current_output = ref [] in
let current_pending_bitfields = ref [] in
let round_up ofs align =
mult_big_int (div_big_int
(sub_big_int (add_big_int ofs align) unit_big_int)
align) align
in
let emit_element elem elem_size elem_align =
let elem_offset = round_up !current_size elem_align in
current_output := !current_output @ [elem_offset, elem];
current_align := max_big_int !current_align elem_align;
current_size := add_big_int elem_offset elem_size;
()
in
let emit_bfields () =
if !current_pending_bitfields = [] then ()
else
let sizes = List.map (fun (_, _, size) -> size) !current_pending_bitfields in
let bf_pos, bf_bytesize, bf_align = calculate_bitfields_packing sizes in
let sf =
{ s_bf_size = big_int_of_int bf_bytesize;
s_bf_fields =
List.map2 (fun (id, ty, size) pos -> (id, ty, size, pos))
!current_pending_bitfields bf_pos } in
emit_element (BitField sf) (big_int_of_int bf_bytesize) (big_int_of_int bf_align)
in
List.iter
(fun (PstructDecl(dslist,sd)) ->
let (storageclass, (basetype : c_type)) = specs_to_type ~env dslist in
if storageclass != None then
failwith "parse error: storage class not allowed in argument type";
List.iter
(function
PstructDeclNormal(decl) ->
emit_bfields ();
let (id, t , _) = decl_to_type ~env decl basetype in
let size, align = match size_of_type ~env t, align_of_type ~env t with
Some s, Some a -> s, a
| _ -> failwith "incomplete type cannot be used as struct element"
in
emit_element
(NormalField {sf_id = id; sf_type = t; sf_size = size; })
size align
| PstructDeclBitfield(Some decl, es) ->
let (id, t, _) = decl_to_type ~env decl basetype in
let es = add_type_to_expr ~env es in
let s = get_integer_constant_value es in
if s = zero_big_int then
failwith "named zero-width bit field"
else if lt_big_int s zero_big_int then
failwith "negative-width bit field"
else if gt_big_int s (big_int_of_int max_bitfield_width) then
failwith "too-wide bit field"
else if equal_type t type_int || equal_type t type_unsigned_int then
current_pending_bitfields :=
(Some id, t, int_of_big_int s) :: !current_pending_bitfields
else
failwith "invalid type for bit fields"
| PstructDeclBitfield(None, es) ->
let es = add_type_to_expr ~env es in
let s = get_integer_constant_value es in
if s = zero_big_int then
emit_bfields ()
else if lt_big_int s zero_big_int then
failwith "negative-width bit fields"
) sd
) decl;
emit_bfields ();
let total_size = round_up !current_size !current_align in
{ str_union_p = is_union; str_size = Some total_size;
str_align = Some !current_align;
str_fields = !current_output }
and parse_enum_definition ~env decl =
ignore
(List.fold_left
(fun cur (name, v) ->
let v = match v with
None -> cur
| Some e1 ->
let e1 = add_type_to_expr ~env e1 in
get_integer_constant_value e1
in
define_enum_item ~env name v;
add_big_int v unit_big_int)
zero_big_int decl)
and specs_to_type ~env specs : ('a * c_type) =
let is_const = ref false in
let is_volatile = ref false in
let signedness = ref None in
let storageclass = ref None in
let modifier = ref None in
let builtin_basetype = ref None in
let full_basetype = ref None in
let is_void = ref false in
let repl r v =
match !r with
None -> r := Some v
| Some _ -> failwith "duplicated specifier"
in
let set r = match !r with
true -> failwith "parse error (specs_to_type::set)"
| false -> r := true
in
List.iter
(function
TypeQualifier Const -> set is_const
| TypeQualifier Volatile -> set is_volatile
| TypeSpec (PtypespecBuiltin Signed) -> repl signedness Tsigned
| TypeSpec (PtypespecBuiltin Unsigned) -> repl signedness Tunsigned
| TypeSpec (PtypespecBuiltin Void) -> set is_void
| TypeSpec (PtypespecBuiltin Long) ->
if !modifier = Some Tlong then
modifier := Some Tlonglong
else
repl modifier Tlong
| TypeSpec (PtypespecBuiltin Short) -> repl modifier Tshort
| TypeSpec (PtypespecBuiltin p) -> repl builtin_basetype p
| StorageClass s -> repl storageclass s
| TypeSpec (PtypespecEnumByName ename) ->
declare_enum ~env ename;
repl full_basetype type_int
| TypeSpec (PtypespecEnumByDef (nameopt, decl)) ->
parse_enum_definition ~env decl;
Option.iter (define_enum ~env) nameopt;
repl full_basetype type_int
| TypeSpec (PtypespecAlias ident) ->
begin
match lookup_var_type ~env ident with
(_, TypeDefName t) ->
repl full_basetype t
| _ -> failwith "panic: non-type appeared as typedef-name"
end
| TypeSpec (PtypespecStruct (is_union, Some name, None)) ->
let id = declare_struct ~env ~is_union name in
repl full_basetype (make_c_type (Tstruct id))
| TypeSpec (PtypespecStruct (is_union, Some name, Some def)) ->
let decl = parse_struct_definition ~env ~is_union def in
let id = define_named_struct ~env ~is_union name decl in
repl full_basetype (make_c_type (Tstruct id))
| TypeSpec (PtypespecStruct (is_union, None, Some def)) ->
let decl = parse_struct_definition ~env ~is_union def in
let id = define_anonymous_struct ~env ~is_union decl in
repl full_basetype (make_c_type (Tstruct id))
| TypeSpec (PtypespecStruct (_, None, None)) ->
failwith "struct declaration must have either definition or name"
) specs;
if !is_void then begin
if !builtin_basetype != None ||
!signedness != None || !full_basetype != None
then failwith "void should not be qualified"
else !storageclass, (make_c_type Tvoid)
end else match !full_basetype with
Some fb -> begin
if !signedness != None
then failwith "non-builtin should not be signedness qualified"
else if !builtin_basetype != None
then failwith "non-builtin should not be used with basetypes"
else
!storageclass,
{ fb with ct_const_p = fb.ct_const_p || !is_const;
ct_volatile_p = fb.ct_volatile_p || !is_volatile }
end
| None -> begin
let typ =
match !signedness, !modifier, !builtin_basetype with
None, None, Some Char -> Tbuiltin(Tchar)
| Some Tsigned, None, Some Char -> Tbuiltin(Tschar)
| Some Tunsigned, None, Some Char -> Tbuiltin(Tuchar)
| None, None, Some Float -> Tbuiltin(Tfloat)
| None, None, Some Double -> Tbuiltin(Tdouble)
| None, Some Tlong, Some Double -> Tbuiltin(Tlongdouble)
| Some Tunsigned, Some Tlonglong, (None | Some Int) -> Tbuiltin(Tulonglong)
| _, Some Tlonglong, (None | Some Int) -> Tbuiltin(Tlonglong)
| Some Tunsigned, Some Tlong, (None | Some Int) -> Tbuiltin(Tulong)
| _, Some Tlong, (None | Some Int) -> Tbuiltin(Tlong)
| Some Tunsigned, Some Tshort, (None | Some Int) -> Tbuiltin(Tushort)
| _, Some Tshort, (None | Some Int) -> Tbuiltin(Tshort)
| Some Tunsigned, None, (None | Some Int) -> Tbuiltin(Tuint)
| _, None, (None | Some Int) -> Tbuiltin(Tint)
| _ -> failwith "parse error (specs_to_type::typ)"
in
!storageclass, (make_c_type ~const:(!is_const) ~volatile:(!is_volatile) typ)
end
and parse_argtypes_iter acc ~env = function
[] -> List.rev acc, false
| (PpdeclConcrete(ts,d) |
PpdeclAbstract(ts,d)) :: tl ->
let storageclass, basetype = (specs_to_type ~env ts) in
if storageclass != None && storageclass <> Some C_abstree.Register then
failwith "parse error: storage class not allowed in argument type"
else
let (id,ty,_) = decl_to_type ~env d basetype in
parse_argtypes_iter ((id, convert_funcarg_type ty)::acc) ~env tl
| [PpdeclVariant] ->
List.rev acc, true
| PpdeclVariant :: _ ->
raise (Type_Error_local("\"...\" must be a final argument (parser error?)"))
and parse_argtypes acc ~env = function
[] -> [], true
| [PpdeclAbstract([TypeSpec (PtypespecBuiltin Void)], PdeclAnonymous)] -> [], false
| l -> parse_argtypes_iter acc ~env l
and decl_to_type ~env decl basetype =
match decl with
| PdeclAnonymous -> "", basetype, []
| PdeclIdent x -> x, basetype, []
| PdeclPointer(ql,decl) ->
decl_to_type ~env decl (make_c_type_ql ql (Tpointer(basetype)))
| PdeclArray(decl,None) ->
decl_to_type ~env decl (make_c_type (Tarray(basetype,None)))
| PdeclArray(decl,Some esz) ->
let size =
let e = (add_type_to_expr ~env esz : expr) in
get_integer_constant_value e
in
decl_to_type ~env decl (make_c_type (Tarray(basetype,Some size)))
| PdeclFuncType(decl,ptypes) ->
let bindings, is_varargs = parse_argtypes [] ~env ptypes in
let ident, rettype, _ =
decl_to_type ~env decl (make_c_type (Tfunction(List.map snd bindings, is_varargs, basetype))) in
ident, rettype, bindings
| PdeclFuncIdent(decl,[]) ->
decl_to_type ~env (PdeclFuncType(decl,[])) basetype
| PdeclFuncIdent(decl,idents) ->
failwith "unimp: decl_to_type : old-fashioned PdeclFuncIdent is not supported"
and type_of_typename ~env (Ptypename(specs,decl)) =
let (_, basetype) = specs_to_type ~env specs in
let (id, ty, _) = decl_to_type ~env decl basetype in
assert(id = "");
ty
and add_type_to_expr ~env exp =
let r = add_type_to_expr_simple ~env exp in
try
fold_constants r
with
NotConstant -> r
and add_type_to_expr_simple ~env (exp : C_abstree.expr) : expr =
let orig = exp in
try
match exp.pexp_t with
| PexpComma(e1, e2) ->
let e1' = add_type_to_expr ~env e1 in
let e2' = add_type_to_expr ~env e2 in
make_expr_p (CTTexpComma(cast_coerce (e1') type_void, e2')) (type_of e2') ~orig
| PexpAssign(e1, e2) ->
let e1' = add_type_to_expr ~env e1 in
let e2' = add_type_to_expr ~env e2 in
make_expr_p (CTTexpAssign(e1', assign_coerce e2' (type_of e1'))) (type_of e1') ~orig
| PexpBinAssign(PbinPlus, e1, e2) ->
begin
let e1 = coerce_implicit_pointer(add_type_to_expr ~env e1) in
let e2 = coerce_implicit_pointer(add_type_to_expr ~env e2) in
ensure_integer e2;
if is_pointer_nonnull e1 then begin
let e2 = arithmetic_coerce e2 type_ptrdiff_t in
ensure_sized_pointer ~env e1;
make_expr_p (CTTexpBinAssign(CTTbinPlusPV, e1, None, e2)) (type_of e1) ~orig
end
else begin
let e1c, e2 = coerce_merge_numeric e1 e2 in
let tcast = if e1c == e1 then None else Some (type_of e1c) in
make_expr_p ~orig (CTTexpBinAssign(CTTbinPlusVV, e1, tcast, e2)) (type_of e1)
end
end
| PexpBinAssign(PbinMinus, e1, e2) ->
begin
let e1 = coerce_implicit_pointer(add_type_to_expr ~env e1) in
let e2 = coerce_implicit_pointer(add_type_to_expr ~env e2) in
ensure_integer e2;
if is_pointer_nonnull e1 then begin
let e1 = coerce_implicit_pointer e1 in
let e2 = arithmetic_coerce e2 type_ptrdiff_t in
ensure_sized_pointer ~env e1;
make_expr_p ~orig (CTTexpBinAssign(CTTbinMinusPV, e1, None, e2)) (type_of e1)
end
else begin
let e1c, e2 = coerce_merge_numeric e1 e2 in
let tcast = if e1c == e1 then None else Some (type_of e1c) in
make_expr_p ~orig (CTTexpBinAssign(CTTbinMinusVV, e1, tcast, e2)) (type_of e1)
end
end
| PexpBinAssign((PbinTimes | PbinDiv) as op, e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
ensure_numeric e1;
ensure_numeric e2;
let e1c, e2 = coerce_merge_numeric e1 e2 in
let tcast = if e1c == e1 then None else Some (type_of e1c) in
make_expr_p ~orig (CTTexpBinAssign(cvt_binop op, e1, tcast, e2)) (type_of e1)
| PexpBinAssign((PbinModulo | PbinIntAnd | PbinIntOr | PbinIntXor) as op,
e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
ensure_integer e1;
ensure_integer e2;
let e1c, e2 = coerce_merge_numeric e1 e2 in
let tcast = if e1c == e1 then None else Some (type_of e1c) in
make_expr_p ~orig (CTTexpBinAssign(cvt_binop op, e1, tcast, e2)) (type_of e1)
| PexpBinAssign((PbinLshift | PbinRshift) as op,
e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
ensure_integer e1;
ensure_integer e2;
let e1c = coerce_at_least_integer e1 in
let tcast = if e1c == e1 then None else Some (type_of e1c) in
make_expr_p ~orig (CTTexpBinAssign(cvt_binop op, e1, tcast, e2)) (type_of e1)
| PexpBinAssign(op, e1, e2) -> assert false
| PexpConditional(e1, e2, e3) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
let e3 = add_type_to_expr ~env e3 in
let e1 = coerce_to_boolean e1 in
let e2, e3 = coerce_merge e2 e3 in
make_expr_p ~orig (CTTexpConditional(e1, e2, e3)) (type_of e2)
| PexpBinExpr(PbinPlus, e1, e2) ->
begin
let e1 = coerce_implicit_pointer(add_type_to_expr ~env e1) in
let e2 = coerce_implicit_pointer(add_type_to_expr ~env e2) in
match (is_pointer_nonnull e1, is_pointer_nonnull e2) with
true, true -> raise (Type_Error_local "adding pointer to pointer")
| true, false ->
let e2 = arithmetic_coerce e2 type_ptrdiff_t in
ensure_sized_pointer ~env e1;
make_expr_p ~orig (CTTexpBinExpr(CTTbinPlusPV, e1, e2)) (type_of e1)
| false, true ->
let e1 = arithmetic_coerce e1 type_ptrdiff_t in
ensure_sized_pointer ~env e2;
make_expr_p ~orig (CTTexpBinExpr(CTTbinPlusPV, e2, e1)) (type_of e2)
| false, false ->
ensure_numeric e1;
ensure_numeric e2;
let e1, e2 = coerce_merge_numeric e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(CTTbinPlusVV, e1, e2)) (type_of e1)
end
| PexpBinExpr(PbinMinus, e1, e2) ->
begin
let e1 = coerce_implicit_pointer(add_type_to_expr ~env e1) in
let e2 = coerce_implicit_pointer(add_type_to_expr ~env e2) in
match (is_pointer_nonnull e1, is_pointer_nonnull e2) with
true, true ->
ensure_same_type e1 e2;
ensure_sized_pointer ~env e1;
make_expr_p ~orig (CTTexpBinExpr(CTTbinMinusPP, e1, e2)) type_ptrdiff_t
| true, false ->
let e2 = arithmetic_coerce e2 type_ptrdiff_t in
ensure_sized_pointer ~env e1;
make_expr_p ~orig (CTTexpBinExpr(CTTbinMinusPV, e1, e2)) (type_of e1)
| false, true ->
raise (Type_Error_local "subtracting pointer from other types")
| false, false ->
ensure_numeric e1;
ensure_numeric e2;
let e1, e2 = coerce_merge_numeric e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(CTTbinMinusVV, e1, e2)) (type_of e1)
end
| PexpBinExpr((PbinTimes | PbinDiv) as op, e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
ensure_numeric e1;
ensure_numeric e2;
let e1, e2 = coerce_merge_numeric e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) (type_of e1)
| PexpBinExpr((PbinModulo | PbinIntAnd | PbinIntOr | PbinIntXor) as op,
e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
ensure_integer e1;
ensure_integer e2;
let e1, e2 = coerce_merge_numeric e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) (type_of e1)
| PexpBinExpr((PbinLshift | PbinRshift) as op,
e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
ensure_integer e1;
ensure_integer e2;
let e1 = coerce_at_least_integer e1 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) (type_of e1)
| PexpBinExpr((PbinLogAnd | PbinLogOr) as op, e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e1 = coerce_to_boolean e1 in
let e2 = add_type_to_expr ~env e2 in
let e2 = coerce_to_boolean e2 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) type_boolean
| PexpBinExpr((PbinLessThan | PbinGtrThan | PbinLessEqual | PbinGtrEqual) as op, e1, e2) ->
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
let e1 = coerce_implicit_pointer e1 in
let e2 = coerce_implicit_pointer e2 in
if is_numeric e1 && is_numeric e2 then begin
let e1, e2 = coerce_merge_numeric e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) type_boolean
end
else if is_pointer_nonnull e1 && is_pointer_nonnull e2 then begin
ensure_same_type e1 e2;
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) type_boolean
end
else
raise (Type_Error_local "")
| PexpBinExpr((PbinEqual | PbinNotEqual) as op, e1, e2) ->
let e1 = coerce_implicit_pointer(add_type_to_expr ~env e1) in
let e2 = coerce_implicit_pointer(add_type_to_expr ~env e2) in
if is_numeric e1 && is_numeric e2 then begin
let e1, e2 = coerce_merge_numeric e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) type_boolean
end
else if is_pointer_or_null e1 && is_pointer_or_null e2 then begin
let e1, e2 = coerce_merge_pointer e1 e2 in
make_expr_p ~orig (CTTexpBinExpr(cvt_binop op, e1, e2)) type_boolean
end
else
raise (Type_Error_local "")
| (PexpPreInc e1 | PexpPostInc e1 | PexpPostDec e1 | PexpPreDec e1) as e ->
let tagv, tagp = match e with
PexpPreInc _ -> CTTbinPlusVV, CTTbinPlusPV
| PexpPostInc _ -> CTTbinPostPlusVV, CTTbinPostPlusPV
| PexpPreDec _ -> CTTbinMinusVV, CTTbinMinusPV
| PexpPostDec _ -> CTTbinPostMinusVV, CTTbinPostMinusPV
| _ -> assert false
in
let e1 = add_type_to_expr ~env e1 in
if is_numeric e1 then
let e1c, e2 = coerce_merge_numeric e1 (exp_constant_one ~loc:(loc_of_p orig)) in
let tcast = if e1c == e1 then None else Some (type_of e1c) in
make_expr_p ~orig (CTTexpBinAssign(tagv, e1, tcast, e2)) (type_of e1)
else if is_sized_pointer ~env e1 then
make_expr_p ~orig (CTTexpBinAssign(tagp, e1, None, exp_constant_one_ptrdiff_t ~loc:(loc_of_p orig))) (type_of e1)
else
raise (Type_Error_local "")
| PexpCast (t, e1) ->
let t = type_of_typename ~env t in
let e1 = add_type_to_expr ~env e1 in
let e1 = cast_coerce e1 t in
e1
| PexpUnaryExpr(LogNot, e1) ->
let e1 = add_type_to_expr ~env e1 in
let e1 = coerce_to_boolean e1 in
make_expr_p ~orig (CTTexpUnaryExpr(LogNot,e1)) type_boolean
| PexpUnaryExpr(IntNot, e1) ->
let e1 = add_type_to_expr ~env e1 in
ensure_integer e1;
make_expr_p ~orig (CTTexpUnaryExpr(IntNot,e1)) (type_of e1)
| PexpUnaryExpr(uop, e1) ->
let e1 = add_type_to_expr ~env e1 in
ensure_numeric e1;
make_expr_p ~orig (CTTexpUnaryExpr(uop,e1)) (type_of e1)
| PexpAddress(e1) ->
let e1 = add_type_to_expr ~env e1 in
ensure_not_void e1;
let t1 = type_of e1 in
let new_type =
(make_c_type (Tpointer (type_of e1)))
in begin
match t1.ct_ty with
Tarray _ ->
make_expr_p ~orig (CTTexpCoerce(new_type,e1)) new_type
| _ ->
make_expr_p ~orig (CTTexpAddress(e1)) new_type
end
| PexpPtrDeref(e1) -> begin
let e1 = add_type_to_expr ~env e1 in
let e1 = coerce_implicit_pointer e1 in
let t1 = type_of e1 in
match t1.ct_ty with
Tpointer ( {ct_ty = Tarray(_)} as t ) ->
make_expr_p ~orig (CTTexpCoerce(t,e1)) t
| Tpointer t -> make_expr_p ~orig (CTTexpPtrDeref(e1)) t
| _ -> raise (Type_Error_local "dereferencing non-pointer")
end
| PexpSizeOfType(t) ->
let t = type_of_typename ~env t in begin
match size_of_type ~env t with
Some s ->
make_expr_p ~orig (CTTexpConstant (CTTconstInteger s)) type_size_t
| None ->
raise (Type_Error_local "taking size of incomplete type")
end
| PexpSizeOfExpr(e1) ->
let e1 = add_type_to_expr ~env e1 in begin
match size_of_type ~env (type_of e1) with
Some s ->
make_expr_p ~orig (CTTexpConstant (CTTconstInteger s)) type_size_t
| None ->
raise (Type_Error_local "taking size of incomplete type")
end
| PexpArrayRef(e1,e2) -> begin
let et =
begin
let e1 = add_type_to_expr ~env e1 in
let e2 = add_type_to_expr ~env e2 in
let e1 = coerce_implicit_pointer e1 in
let e2 = coerce_implicit_pointer e2 in
match (is_pointer_nonnull e1, is_pointer_nonnull e2) with
true, true -> raise (Type_Error_local "used pointer as array index")
| true, false ->
let e2 = arithmetic_coerce e2 type_ptrdiff_t in
ensure_sized_pointer ~env e1;
make_expr_p ~orig (CTTexpBinExpr(CTTbinPlusPV, e1, e2)) (type_of e1)
| false, true ->
let e1 = arithmetic_coerce e1 type_ptrdiff_t in
ensure_sized_pointer ~env e2;
make_expr_p ~orig (CTTexpBinExpr(CTTbinPlusPV, e2, e1)) (type_of e2)
| false, false ->
raise (Type_Error_local "both array and index are numeric type")
end
in
let tet = type_of et in
match tet.ct_ty with
Tpointer ( {ct_ty = Tarray(_)} as t ) ->
make_expr_p ~orig (CTTexpCoerce(t,et)) t
| Tpointer t -> make_expr_p ~orig (CTTexpPtrDeref(et)) t
| _ -> raise (Type_Error_local "dereferencing non-pointer")
end
| PexpInvoke(e1, es) ->
let e1 = add_type_to_expr ~env e1 in
let e1 =
if is_pointer_nonnull e1 then begin
let t1 = type_of e1 in
match t1.ct_ty with
Tpointer t -> make_expr_t (CTTexpPtrDeref(e1)) t ~orig:e1
| _ -> assert false
end
else e1
in
let rettype, argtypes, is_varargs = resolv_function_type (type_of e1) in
let argnum = List.length es in
let fargnum = List.length argtypes in
if argnum < fargnum then
raise (Type_Error_local
(Printf.sprintf "insufficient number of arguments (%d should be %d)" argnum fargnum));
if argnum > fargnum && not is_varargs then
raise (Type_Error_local
(Printf.sprintf "too many arguments (%d should be %d)" argnum fargnum));
let args_fixed, args_varargs =
split_list_at_nth fargnum es in
assert(List.length args_fixed = List.length argtypes);
let newargs_fixed =
List.map2
(fun e t -> assign_coerce ~check_qual:qual_dcare (add_type_to_expr ~env e) t)
args_fixed argtypes in
let newargs_variable =
List.map
(fun e -> promote_KandR (add_type_to_expr ~env e))
args_varargs
in
make_expr_p ~orig (CTTexpInvoke(e1,newargs_fixed @ newargs_variable)) rettype
| PexpField(e1,id) ->
let e1 = add_type_to_expr ~env e1 in
let t = get_field_type ~env (type_of e1) id in
make_expr_p ~orig (CTTexpField(e1,id)) t
| PexpPtrField(e1,id) -> begin
let star_e1 =
let e1 = add_type_to_expr ~env e1 in
let e1 = coerce_implicit_pointer e1 in
let t1 = type_of e1 in
match t1.ct_ty with
Tpointer t -> make_expr_t (CTTexpPtrDeref(e1)) t ~orig:e1
| _ -> raise (Type_Error_local "dereferencing non-pointer")
in
let t = get_field_type ~env (type_of star_e1) id in
make_expr_p ~orig (CTTexpField(star_e1,id)) t
end
| PexpConstant(c) ->
let d, t = parse_constant c in
make_expr_p ~orig (CTTexpConstant d) t
| PexpVar(id) ->
try
match lookup_var_type ~env id with
(_, EnumVal v) ->
make_expr_p ~orig (CTTexpConstant (CTTconstInteger v)) type_int
| (nid, Var t) ->
make_expr_p ~orig (CTTexpVar(nid)) t
| (_, TypeDefName t) ->
raise (Type_Error_local(id ^ "is not a variable but a type"))
with
Not_found -> raise (Type_Error_local "var not found")
with
Type_Error_local(s) -> raise (TypeError_untyped(exp,s))